X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fdefboot.lisp;h=383c9f31f95e8adf72fddb063acf85c94a39f1bf;hb=4ecf0abf29f8a8cb2a59c67e192e1f83efaa31f7;hp=fdec8087a2396789a874494e5b737f364295b8c6;hpb=ec2616d216958a608581802c47496c0194478dc8;p=sbcl.git diff --git a/src/code/defboot.lisp b/src/code/defboot.lisp index fdec808..383c9f3 100644 --- a/src/code/defboot.lisp +++ b/src/code/defboot.lisp @@ -47,22 +47,9 @@ (error "Vars is not a list of symbols: ~S" vars))) (defmacro-mundanely multiple-value-setq (vars value-form) - (cond ((null vars) - ;; The ANSI spec says that the primary value of VALUE-FORM must be - ;; returned. The general-case-handling code below doesn't do this - ;; correctly in the special case when there are no vars bound, so we - ;; handle this special case separately here. - (let ((g (gensym))) - `(multiple-value-bind (,g) ,value-form - ,g))) - ((list-of-symbols-p vars) - (let ((temps (make-gensym-list (length vars)))) - `(multiple-value-bind ,temps ,value-form - ,@(mapcar (lambda (var temp) - `(setq ,var ,temp)) - vars temps) - ,(car temps)))) - (t (error "Vars is not a list of symbols: ~S" vars)))) + (unless (list-of-symbols-p vars) + (error "Vars is not a list of symbols: ~S" vars)) + `(values (setf (values ,@vars) ,value-form))) (defmacro-mundanely multiple-value-list (value-form) `(multiple-value-call #'list ,value-form)) @@ -72,21 +59,21 @@ ;;; COND defined in terms of IF (defmacro-mundanely cond (&rest clauses) (if (endp clauses) - nil - (let ((clause (first clauses))) - (if (atom clause) - (error "Cond clause is not a list: ~S" 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 ,@(rest clauses))))) - `(if ,test - (progn ,@forms) - (cond ,@(rest clauses))))))))) + nil + (let ((clause (first clauses))) + (if (atom clause) + (error "COND clause is not a list: ~S" 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 ,@(rest clauses))))) + `(if ,test + (progn ,@forms) + (cond ,@(rest clauses))))))))) ;;; other things defined in terms of COND (defmacro-mundanely when (test &body forms) @@ -162,8 +149,6 @@ ;; the only unsurprising choice. (info :function :inline-expansion-designator name))) -;;; Now that we have the definition of MULTIPLE-VALUE-BIND, we can -;;; make a reasonably readable definition of DEFUN. (defmacro-mundanely defun (&environment env name args &body body) "Define a function at top level." #+sb-xc-host @@ -229,7 +214,7 @@ (defun %defun (name def doc) (declare (type function def)) (declare (type (or null simple-string doc))) - (aver (legal-fun-name-p name)) + (aver (legal-fun-name-p name)) ; should've been checked by DEFMACRO DEFUN (when (fboundp name) (/show0 "redefining NAME in %DEFUN") (style-warn "redefining ~S in DEFUN" name)) @@ -262,7 +247,7 @@ `((unless (boundp ',var) (setq ,var ,val)))) ,@(when docp - `((funcall #'(setf fdocumentation) ',doc ',var 'variable))) + `((setf (fdocumentation ',var 'variable) ',doc ))) ',var)) (defmacro-mundanely defparameter (var val &optional (doc nil docp)) @@ -276,10 +261,7 @@ (declaim (special ,var)) (setq ,var ,val) ,@(when docp - ;; FIXME: The various FUNCALL #'(SETF FDOCUMENTATION) and - ;; other FUNCALL #'(SETF FOO) forms in the code should - ;; unbogobootstrapized back to ordinary SETF forms. - `((funcall #'(setf fdocumentation) ',doc ',var 'variable))) + `((setf (fdocumentation ',var 'variable) ',doc))) ',var)) ;;;; iteration constructs @@ -319,46 +301,40 @@ ;;; defined that it looks as though it's worth just implementing them ;;; ASAP, at the cost of being unable to use the standard ;;; destructuring mechanisms. -(defmacro-mundanely dotimes (var-count-result &body body) - (multiple-value-bind ; to roll our own destructuring - (var count result) - (apply (lambda (var count &optional (result nil)) - (values var count result)) - var-count-result) - (cond ((numberp count) - `(do ((,var 0 (1+ ,var))) - ((>= ,var ,count) ,result) - (declare (type unsigned-byte ,var)) - ,@body)) - (t (let ((v1 (gensym))) - `(do ((,var 0 (1+ ,var)) (,v1 ,count)) - ((>= ,var ,v1) ,result) - (declare (type unsigned-byte ,var)) - ,@body)))))) -(defmacro-mundanely dolist (var-list-result &body body) - (multiple-value-bind ; to roll our own destructuring - (var list result) - (apply (lambda (var list &optional (result nil)) - (values var list result)) - var-list-result) - ;; We repeatedly bind the var instead of setting it so that we - ;; never have to give the var an arbitrary value such as NIL - ;; (which might conflict with a declaration). If there is a result - ;; form, we introduce a gratuitous binding of the variable to NIL - ;; without the declarations, then evaluate the result form in that - ;; environment. We spuriously reference the gratuitous variable, - ;; since since we don't want to use IGNORABLE on what might be a - ;; special var. +(defmacro-mundanely dotimes ((var count &optional (result nil)) &body body) + (cond ((numberp count) + `(do ((,var 0 (1+ ,var))) + ((>= ,var ,count) ,result) + (declare (type unsigned-byte ,var)) + ,@body)) + (t (let ((v1 (gensym))) + `(do ((,var 0 (1+ ,var)) (,v1 ,count)) + ((>= ,var ,v1) ,result) + (declare (type unsigned-byte ,var)) + ,@body))))) + +(defmacro-mundanely dolist ((var list &optional (result nil)) &body body) + ;; We repeatedly bind the var instead of setting it so that we never + ;; have to give the var an arbitrary value such as NIL (which might + ;; conflict with a declaration). If there is a result form, we + ;; introduce a gratuitous binding of the variable to NIL without the + ;; declarations, then evaluate the result form in that + ;; environment. We spuriously reference the gratuitous variable, + ;; since we don't want to use IGNORABLE on what might be a special + ;; var. + (multiple-value-bind (forms decls) (parse-body body nil) (let ((n-list (gensym))) - `(do ((,n-list ,list (cdr ,n-list))) - ((endp ,n-list) - ,@(if result - `((let ((,var nil)) - ,var - ,result)) - '(nil))) - (let ((,var (car ,n-list))) - ,@body))))) + `(do* ((,n-list ,list (cdr ,n-list))) + ((endp ,n-list) + ,@(if result + `((let ((,var nil)) + ,var + ,result)) + '(nil))) + (let ((,var (car ,n-list))) + ,@decls + (tagbody + ,@forms)))))) ;;;; miscellaneous @@ -367,25 +343,19 @@ (defmacro-mundanely psetq (&rest pairs) #!+sb-doc - "SETQ {var value}* + "PSETQ {var value}* Set the variables to the values, like SETQ, except that assignments happen in parallel, i.e. no assignments take place until all the forms have been evaluated." - ;; (This macro is used in the definition of DO, so we can't use DO in the - ;; definition of this macro without getting into confusing bootstrap issues.) - (prog ((lets nil) - (setqs nil) - (pairs pairs)) - :again - (when (atom (cdr pairs)) - (return `(let ,(nreverse lets) - (setq ,@(nreverse setqs)) - nil))) - (let ((gen (gensym))) - (setq lets (cons `(,gen ,(cadr pairs)) lets) - setqs (list* gen (car pairs) setqs) - pairs (cddr pairs))) - (go :again))) + ;; Given the possibility of symbol-macros, we delegate to PSETF + ;; which knows how to deal with them, after checking that syntax is + ;; compatible with PSETQ. + (do ((pair pairs (cddr pair))) + ((endp pair) `(psetf ,@pairs)) + (unless (symbolp (car pair)) + (error 'simple-program-error + :format-control "variable ~S in PSETQ is not a SYMBOL" + :format-arguments (list (car pair)))))) (defmacro-mundanely lambda (&whole whole args &body body) (declare (ignore args body))