X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fdefboot.lisp;h=43ad076d5cbe0f3923e28a510ea84e43e34f7d97;hb=51d5b9c8ca4e5e3d302e8ebf49042ac49b92c4e4;hp=2379081aada5f6ae40a24a599d7f378a8cf082be;hpb=c41cb4c87eae7b04f844dca5f7edb5086c5d2d68;p=sbcl.git diff --git a/src/code/defboot.lisp b/src/code/defboot.lisp index 2379081..43ad076 100644 --- a/src/code/defboot.lisp +++ b/src/code/defboot.lisp @@ -40,7 +40,8 @@ `(let ((,(car vars) ,value-form)) ,@body) (let ((ignore (gensym))) - `(multiple-value-call #'(lambda (&optional ,@vars &rest ,ignore) + `(multiple-value-call #'(lambda (&optional ,@(mapcar #'list vars) + &rest ,ignore) (declare (ignore ,ignore)) ,@body) ,value-form))) @@ -49,7 +50,13 @@ (defmacro-mundanely multiple-value-setq (vars value-form) (unless (list-of-symbols-p vars) (error "Vars is not a list of symbols: ~S" vars)) - `(values (setf (values ,@vars) ,value-form))) + ;; MULTIPLE-VALUE-SETQ is required to always return just the primary + ;; value of the value-from, even if there are no vars. (SETF VALUES) + ;; in turn is required to return as many values as there are + ;; value-places, hence this: + (if vars + `(values (setf (values ,@vars) ,value-form)) + `(values ,value-form))) (defmacro-mundanely multiple-value-list (value-form) `(multiple-value-call #'list ,value-form)) @@ -151,7 +158,7 @@ "Define a function at top level." #+sb-xc-host (unless (symbol-package (fun-name-block-name name)) - (warn "DEFUN of uninterned symbol ~S (tricky for GENESIS)" name)) + (warn "DEFUN of uninterned function name ~S (tricky for GENESIS)" name)) (multiple-value-bind (forms decls doc) (parse-body body) (let* (;; stuff shared between LAMBDA and INLINE-LAMBDA and NAMED-LAMBDA (lambda-guts `(,args @@ -172,33 +179,35 @@ name) nil))))) `(progn - - ;; In cross-compilation of toplevel DEFUNs, we arrange - ;; for the LAMBDA to be statically linked by GENESIS. - ;; - ;; It may seem strangely inconsistent not to use NAMED-LAMBDA - ;; here instead of LAMBDA. The reason is historical: - ;; COLD-FSET was written before NAMED-LAMBDA, and has special - ;; logic of its own to notify the compiler about NAME. - #+sb-xc-host + ;; In cross-compilation of toplevel DEFUNs, we arrange for + ;; the LAMBDA to be statically linked by GENESIS. + ;; + ;; It may seem strangely inconsistent not to use NAMED-LAMBDA + ;; here instead of LAMBDA. The reason is historical: + ;; COLD-FSET was written before NAMED-LAMBDA, and has special + ;; logic of its own to notify the compiler about NAME. + #+sb-xc-host (cold-fset ,name ,lambda) + + (eval-when (:compile-toplevel) + (sb!c:%compiler-defun ',name ',inline-lambda t)) + (eval-when (:load-toplevel :execute) + (%defun ',name + ;; In normal compilation (not for cold load) this is + ;; where the compiled LAMBDA first appears. In + ;; cross-compilation, we manipulate the + ;; previously-statically-linked LAMBDA here. + #-sb-xc-host ,named-lambda + #+sb-xc-host (fdefinition ',name) + ,doc + ',inline-lambda)))))) - (eval-when (:compile-toplevel :load-toplevel :execute) - (sb!c:%compiler-defun ',name ',inline-lambda)) - - (%defun ',name - ;; In normal compilation (not for cold load) this is - ;; where the compiled LAMBDA first appears. In - ;; cross-compilation, we manipulate the - ;; previously-statically-linked LAMBDA here. - #-sb-xc-host ,named-lambda - #+sb-xc-host (fdefinition ',name) - ,doc))))) #-sb-xc-host -(defun %defun (name def doc) +(defun %defun (name def doc inline-lambda) (declare (type function def)) (declare (type (or null simple-string) doc)) (aver (legal-fun-name-p name)) ; should've been checked by DEFMACRO DEFUN + (sb!c:%compiler-defun name inline-lambda nil) (when (fboundp name) (/show0 "redefining NAME in %DEFUN") (style-warn "redefining ~S in DEFUN" name)) @@ -209,7 +218,7 @@ ;; something sane, (1) doing so doesn't really fix the bug, and ;; (2) doing probably isn't even really safe. #+nil (setf (%fun-name def) name) - + (when doc (setf (fdocumentation name 'function) doc)) name) @@ -223,13 +232,10 @@ value, the old value is not clobbered. The third argument is an optional documentation string for the variable." `(progn - (declaim (special ,var)) - ,@(when valp - `((unless (boundp ',var) - (set ',var ,val)))) - ,@(when docp - `((setf (fdocumentation ',var 'variable) ',doc ))) - ',var)) + (eval-when (:compile-toplevel) + (%compiler-defvar ',var)) + (eval-when (:load-toplevel :execute) + (%defvar ',var (unless (boundp ',var) ,val) ',valp ,doc ',docp)))) (defmacro-mundanely defparameter (var val &optional (doc nil docp)) #!+sb-doc @@ -239,11 +245,31 @@ previous value. The third argument is an optional documentation string for the parameter." `(progn - (declaim (special ,var)) - (set ',var ,val) - ,@(when docp - `((setf (fdocumentation ',var 'variable) ',doc))) - ',var)) + (eval-when (:compile-toplevel) + (%compiler-defvar ',var)) + (eval-when (:load-toplevel :execute) + (%defparameter ',var ,val ,doc ',docp)))) + +(defun %compiler-defvar (var) + (sb!xc:proclaim `(special ,var))) + +#-sb-xc-host +(defun %defvar (var val valp doc docp) + (%compiler-defvar var) + (when valp + (unless (boundp var) + (set var val))) + (when docp + (setf (fdocumentation var 'variable) doc)) + var) + +#-sb-xc-host +(defun %defparameter (var val doc docp) + (%compiler-defvar var) + (set var val) + (when docp + (setf (fdocumentation var 'variable) doc)) + var) ;;;; iteration constructs @@ -285,15 +311,25 @@ (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)) + ((>= ,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))))) - + ((>= ,var ,v1) ,result) + (declare (type unsigned-byte ,var)) + ,@body))))) + +(defun filter-dolist-declarations (decls) + (mapcar (lambda (decl) + `(declare ,@(remove-if + (lambda (clause) + (and (consp clause) + (or (eq (car clause) 'type) + (eq (car clause) 'ignore)))) + (cdr decl)))) + decls)) + (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 @@ -304,18 +340,28 @@ ;; since we don't want to use IGNORABLE on what might be a special ;; var. (multiple-value-bind (forms decls) (parse-body body :doc-string-allowed 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))) - ,@decls - (tagbody - ,@forms)))))) + (let ((n-list (gensym "N-LIST")) + (start (gensym "START"))) + `(block nil + (let ((,n-list ,list)) + (tagbody + ,start + (unless (endp ,n-list) + (let ((,var (car ,n-list))) + ,@decls + (setq ,n-list (cdr ,n-list)) + (tagbody ,@forms)) + (go ,start)))) + ,(if result + `(let ((,var nil)) + ;; Filter out TYPE declarations (VAR gets bound to NIL, + ;; and might have a conflicting type declaration) and + ;; IGNORE (VAR might be ignored in the loop body, but + ;; it's used in the result form). + ,@(filter-dolist-declarations decls) + ,var + ,result) + nil))))) ;;;; conditions, handlers, restarts @@ -327,9 +373,8 @@ (defmacro-mundanely with-condition-restarts (condition-form restarts-form &body body) #!+sb-doc - "WITH-CONDITION-RESTARTS Condition-Form Restarts-Form Form* - Evaluates the Forms in a dynamic environment where the restarts in the list - Restarts-Form are associated with the condition returned by Condition-Form. + "Evaluates the BODY in a dynamic environment where the restarts in the list + RESTARTS-FORM are associated with the condition returned by CONDITION-FORM. This allows FIND-RESTART, etc., to recognize restarts that are not related to the error currently being debugged. See also RESTART-CASE." (let ((n-cond (gensym))) @@ -354,7 +399,7 @@ binding :test #'eq)) (warn "Unnamed restart does not have a ~ - report function: ~S" + report function: ~S" binding)) `(make-restart :name ',(car binding) :function ,(cadr binding) @@ -383,7 +428,7 @@ ,n-cond (car *restart-clusters*) ,(if (eq name 'cerror) - `(cerror ,(second expression) ,n-cond) + `(cerror ,(second exp) ,n-cond) `(,name ,n-cond)))) expression)) expression))) @@ -579,10 +624,8 @@ `(let ((,(caaddr annotated-case) ,var)) ,@body)) - ((not (cdr body)) - (car body)) (t - `(progn ,@body))))))) + `(locally ,@body))))))) annotated-cases)))))))) ;;;; miscellaneous @@ -629,8 +672,11 @@ ;; functions appearing in fundamental defining ;; macro expansions: %compiler-deftype + %compiler-defvar %defun %defsetf + %defparameter + %defvar sb!c:%compiler-defun sb!c::%define-symbol-macro sb!c::%defconstant