common-lisp/sbcl.sbcl
1
0
Fork 0
mirror of git://git.code.sf.net/p/sbcl/sbcl synced 2026-09-10 07:26:40 -04:00
Code Issues Actions 8 Packages Projects Releases Wiki Activity

Make COND a non-recursive macro

Browse source 
Doing so simplifies life for the interpreter, as the entire expansion is
available at once (and can be memoized directly with no special-casing).

This change also elides unneeded PROGNs in the expansion.
This commit is contained in:
Ron Gut 2016-10-24 13:13:06 -04:00 committed by Douglas Katzman
parent b7c66feab4
commit 893795b1c3
2 changed files with 27 additions and 32 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

55
src/code/defboot.lisp
View file

@ -65,39 +65,36 @@
;;;; various conditional constructs
;;; COND defined in terms of IF
(sb!xc:defmacro cond (&rest clauses)
(if (endp clauses)
nil
(let ((clause (first clauses))
(more (rest clauses)))
(if (atom clause)
(error 'simple-type-error
:format-control "COND clause is not a ~S: ~S"
:format-arguments (list 'cons clause)
:expected-type 'cons
:datum clause)
(let ((test (first clause))
(forms (rest clause)))
(if (endp forms)
(let ((n-result (gensym)))
`(let ((,n-result ,test))
(if ,n-result
,n-result
(cond ,@more))))
(if (and (eq test t)
(not more))
;; THE to preserve non-toplevelness for FOO in
;; (COND (T (FOO)))
`(the t (progn ,@forms))
`(if ,test
(progn ,@forms)
,(when more `(cond ,@more))))))))))
(flet ((prognify (forms)
(cond ((singleton-p forms) (car forms))
((not forms) nil)
(t `(progn ,@forms)))))
;; COND defined in terms of IF
(sb!xc:defmacro cond (&rest clauses)
(named-let make-clauses ((clauses clauses))
(if (endp clauses)
nil
(let ((clause (first clauses))
(more (rest clauses)))
(if (atom clause)
(error 'simple-type-error
:format-control "COND clause is not a ~S: ~S"
:format-arguments (list 'cons clause)
:expected-type 'cons
:datum clause)
(let ((test (first clause))
(forms (rest clause)))
(if (endp forms)
`(or ,test ,(make-clauses more))
(if (and (eq test t)
(not more))
;; THE to preserve non-toplevelness for FOO in
;; (COND (T (FOO)))
`(the t ,(prognify forms))
`(if ,test
,(prognify forms)
,(when more (make-clauses more)))))))))))
(sb!xc:defmacro when (test &body forms)
#!+sb-doc
"If the first argument is true, the rest of the forms are

4
tests/walk.impure.lisp
View file

@ -984,11 +984,9 @@ Form: 2 Context: EVAL
(take-it-out-for-a-test-walk (cond (a b)
((foo bar) a (foo a)))))
"Form: (COND (A B) ((FOO BAR) A (FOO A))) Context: EVAL
Form: (IF A (PROGN B) (COND ((FOO BAR) A (FOO A)))) Context: EVAL
Form: (IF A B (IF (FOO BAR) (PROGN A (FOO A)) NIL)) Context: EVAL
Form: A Context: EVAL
Form: (PROGN B) Context: EVAL
Form: B Context: EVAL
Form: (COND ((FOO BAR) A (FOO A))) Context: EVAL
Form: (IF (FOO BAR) (PROGN A (FOO A)) NIL) Context: EVAL
Form: (FOO BAR) Context: EVAL
Form: 'GLOBAL-FOO Context: EVAL