X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fdefboot.lisp;h=440fe2d8a2676ce55d06b529169d30595031d070;hb=ff57884e206ac28660af6af34315bc9b81697f57;hp=4c4d897eaf0e8eadd34cfffb1fb68e43946377b7;hpb=4f64f131a7bca59d0dc8be9e74d05a7645f27e67;p=sbcl.git diff --git a/src/code/defboot.lisp b/src/code/defboot.lisp index 4c4d897..440fe2d 100644 --- a/src/code/defboot.lisp +++ b/src/code/defboot.lisp @@ -26,7 +26,7 @@ `(eval-when (:compile-toplevel :load-toplevel :execute) (setq *package* (find-undeleted-package-or-lose ',package-designator)))) -;;; MULTIPLE-VALUE-FOO +;;;; MULTIPLE-VALUE-FOO (defun list-of-symbols-p (x) (and (listp x) @@ -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) @@ -141,102 +128,132 @@ (defmacro-mundanely prog2 (form1 result &body body) `(prog1 (progn ,form1 ,result) ,@body)) -;;; Now that we have the definition of MULTIPLE-VALUE-BIND, we can make a -;;; reasonably readable definition of DEFUN. -;;; -;;; DEFUN expands into %DEFUN which is a function that is treated -;;; magically by the compiler (through an IR1 transform) in order to -;;; handle stuff like inlining. After the compiler has gotten the -;;; information it wants out of macro definition, it compiles a call -;;; to %%DEFUN which happens at load time. -(defmacro-mundanely defun (&whole whole name args &body body) +;;;; DEFUN + +;;; Should we save the inline expansion of the function named NAME? +(defun inline-fun-name-p (name) + (or + ;; the normal reason for saving the inline expansion + (info :function :inlinep name) + ;; another reason for saving the inline expansion: If the + ;; ANSI-recommended idiom + ;; (DECLAIM (INLINE FOO)) + ;; (DEFUN FOO ..) + ;; (DECLAIM (NOTINLINE FOO)) + ;; has been used, and then we later do another + ;; (DEFUN FOO ..) + ;; without a preceding + ;; (DECLAIM (INLINE FOO)) + ;; what should we do with the old inline expansion when we see the + ;; new DEFUN? Overwriting it with the new definition seems like + ;; the only unsurprising choice. + (info :function :inline-expansion-designator name))) + +(defmacro-mundanely defun (&environment env name args &body body) + "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)) (multiple-value-bind (forms decls doc) (parse-body body) - (let ((def `(lambda ,args - ,@decls - (block ,(function-name-block-name name) - ,@forms)))) - `(sb!c::%defun ',name #',def ,doc ',whole)))) -#+sb-xc-host (/show "before PROCLAIM" (sb!c::info :function :kind 'sb!c::%%defun)) -#+sb-xc-host (sb!xc:proclaim '(ftype function sb!c::%%defun)) ; to avoid - ; undefined function warnings -#+sb-xc-host (/show "after PROCLAIM" (sb!c::info :function :kind 'sb!c::%%defun)) -(defun sb!c::%%defun (name def doc &optional inline-expansion) + (let* (;; stuff shared between LAMBDA and INLINE-LAMBDA and NAMED-LAMBDA + (lambda-guts `(,args + ,@decls + (block ,(fun-name-block-name name) + ,@forms))) + (lambda `(lambda ,@lambda-guts)) + #-sb-xc-host + (named-lambda `(named-lambda ,name ,@lambda-guts)) + (inline-lambda + (when (inline-fun-name-p name) + ;; we want to attempt to inline, so complain if we can't + (or (sb!c:maybe-inline-syntactic-closure lambda env) + (progn + (#+sb-xc-host warn + #-sb-xc-host sb!c:maybe-compiler-notify + "lexical environment too hairy, can't inline DEFUN ~S" + 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 + (cold-fset ,name ,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) + (declare (type function def)) + (declare (type (or null simple-string) doc)) + (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)) (setf (sb!xc:fdefinition name) def) + + ;; FIXME: I want to do this here (and fix bug 137), but until the + ;; breathtaking CMU CL function name architecture is converted into + ;; 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 - ;; FIXME: This should use shared SETF-name parsing logic. - (if (and (consp name) (eq (first name) 'setf)) - (setf (fdocumentation (second name) 'setf) doc) - (setf (fdocumentation name 'function) doc))) - (become-defined-function-name name) - (when (or inline-expansion - (info :function :inline-expansion name)) - (setf (info :function :inline-expansion name) - inline-expansion)) + (setf (fdocumentation name 'function) doc)) name) -;;; Ordinarily this definition of SB!C:%DEFUN as an ordinary function is not -;;; used: the parallel (but different) definition as an IR1 transform takes -;;; precedence. However, it's still good to define this in order to keep the -;;; interpreter happy. We define it here (instead of alongside the parallel -;;; IR1 transform) because while the IR1 transform is needed and appropriate -;;; in the cross-compiler running in the host Common Lisp, this parallel -;;; ordinary function definition is only appropriate in the target Lisp. -(defun sb!c::%defun (name def doc source) - (declare (ignore source)) - (setf (sb!eval:interpreted-function-name def) name) - (ecase (info :function :where-from name) - (:assumed - (setf (info :function :where-from name) :defined) - (setf (info :function :type name) - (extract-function-type def)) - (when (info :function :assumed-type name) - (setf (info :function :assumed-type name) nil))) - (:declared) - (:defined - (setf (info :function :type name) (extract-function-type def)))) - (sb!c::%%defun name def doc)) ;;;; DEFVAR and DEFPARAMETER (defmacro-mundanely defvar (var &optional (val nil valp) (doc nil docp)) #!+sb-doc - "For defining global variables at top level. Declares the variable - SPECIAL and, optionally, initializes it. If the variable already has a + "Define a global variable at top level. Declare the variable + SPECIAL and, optionally, initialize it. If the variable already has a 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) - (setq ,var ,val)))) + (set ',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)) #!+sb-doc - "Defines a parameter that is not normally changed by the program, - but that may be changed without causing an error. Declares the - variable special and sets its value to VAL. The third argument is - an optional documentation string for the parameter." + "Define a parameter that is not normally changed by the program, + but that may be changed without causing an error. Declare the + variable special and sets its value to VAL, overwriting any + previous value. The third argument is an optional documentation + string for the parameter." `(progn (declaim (special ,var)) - (setq ,var ,val) + (set ',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 -;;; (These macros are defined in terms of a function DO-DO-BODY which is also -;;; used by SB!INT:DO-ANONYMOUS. Since these macros should not be loaded -;;; on the cross-compilation host, but SB!INT:DO-ANONYMOUS and DO-DO-BODY -;;; should be, these macros can't conveniently be in the same file as -;;; DO-DO-BODY.) +;;; (These macros are defined in terms of a function FROB-DO-BODY which +;;; is also used by SB!INT:DO-ANONYMOUS. Since these macros should not +;;; be loaded on the cross-compilation host, but SB!INT:DO-ANONYMOUS +;;; and FROB-DO-BODY should be, these macros can't conveniently be in +;;; the same file as FROB-DO-BODY.) (defmacro-mundanely do (varlist endlist &body body) #!+sb-doc "DO ({(Var [Init] [Step])}*) (Test Exit-Form*) Declaration* Form* @@ -247,7 +264,7 @@ are evaluated as a PROGN, with the result being the value of the DO. A block named NIL is established around the entire expansion, allowing RETURN to be used as an alternate exit mechanism." - (do-do-body varlist endlist body 'let 'psetq 'do nil)) + (frob-do-body varlist endlist body 'let 'psetq 'do nil)) (defmacro-mundanely do* (varlist endlist &body body) #!+sb-doc "DO* ({(Var [Init] [Step])}*) (Test Exit-Form*) Declaration* Form* @@ -258,53 +275,317 @@ the Exit-Forms are evaluated as a PROGN, with the result being the value of the DO. A block named NIL is established around the entire expansion, allowing RETURN to be used as an laternate exit mechanism." - (do-do-body varlist endlist body 'let* 'setq 'do* nil)) - -;;; DOTIMES and DOLIST could be defined more concisely using destructuring -;;; macro lambda lists or DESTRUCTURING-BIND, but then it'd be tricky to use -;;; them before those things were defined. They're used enough times before -;;; destructuring mechanisms are 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 w/o 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. + (frob-do-body varlist endlist body 'let* 'setq 'do* nil)) + +;;; DOTIMES and DOLIST could be defined more concisely using +;;; destructuring macro lambda lists or DESTRUCTURING-BIND, but then +;;; it'd be tricky to use them before those things were defined. +;;; They're used enough times before destructuring mechanisms are +;;; 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 &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)))))) + +;;;; conditions, handlers, restarts + +;;; KLUDGE: we PROCLAIM these special here so that we can use restart +;;; macros in the compiler before the DEFVARs are compiled. +(sb!xc:proclaim + '(special *handler-clusters* *restart-clusters* *condition-restarts*)) + +(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. + 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))) + `(let ((*condition-restarts* + (cons (let ((,n-cond ,condition-form)) + (cons ,n-cond + (append ,restarts-form + (cdr (assoc ,n-cond *condition-restarts*))))) + *condition-restarts*))) + ,@body))) + +(defmacro-mundanely restart-bind (bindings &body forms) + #!+sb-doc + "Executes forms in a dynamic context where the given restart bindings are + in effect. Users probably want to use RESTART-CASE. When clauses contain + the same restart name, FIND-RESTART will find the first such clause." + `(let ((*restart-clusters* + (cons (list + ,@(mapcar (lambda (binding) + (unless (or (car binding) + (member :report-function + binding + :test #'eq)) + (warn "Unnamed restart does not have a ~ + report function: ~S" + binding)) + `(make-restart :name ',(car binding) + :function ,(cadr binding) + ,@(cddr binding))) + bindings)) + *restart-clusters*))) + ,@forms)) + +;;; Wrap the RESTART-CASE expression in a WITH-CONDITION-RESTARTS if +;;; appropriate. Gross, but it's what the book seems to say... +(defun munge-restart-case-expression (expression env) + (let ((exp (sb!xc:macroexpand expression env))) + (if (consp exp) + (let* ((name (car exp)) + (args (if (eq name 'cerror) (cddr exp) (cdr exp)))) + (if (member name '(signal error cerror warn)) + (once-only ((n-cond `(coerce-to-condition + ,(first args) + (list ,@(rest args)) + ',(case name + (warn 'simple-warning) + (signal 'simple-condition) + (t 'simple-error)) + ',name))) + `(with-condition-restarts + ,n-cond + (car *restart-clusters*) + ,(if (eq name 'cerror) + `(cerror ,(second expression) ,n-cond) + `(,name ,n-cond)))) + expression)) + expression))) + +;;; FIXME: I did a fair amount of rearrangement of this code in order to +;;; get WITH-KEYWORD-PAIRS to work cleanly. This code should be tested.. +(defmacro-mundanely restart-case (expression &body clauses &environment env) + #!+sb-doc + "(RESTART-CASE form + {(case-name arg-list {keyword value}* body)}*) + The form is evaluated in a dynamic context where the clauses have special + meanings as points to which control may be transferred (see INVOKE-RESTART). + When clauses contain the same case-name, FIND-RESTART will find the first + such clause. If Expression is a call to SIGNAL, ERROR, CERROR or WARN (or + macroexpands into such) then the signalled condition will be associated with + the new restarts." + (flet ((transform-keywords (&key report interactive test) + (let ((result '())) + (when report + (setq result (list* (if (stringp report) + `#'(lambda (stream) + (write-string ,report stream)) + `#',report) + :report-function + result))) + (when interactive + (setq result (list* `#',interactive + :interactive-function + result))) + (when test + (setq result (list* `#',test :test-function result))) + (nreverse result))) + (parse-keyword-pairs (list keys) + (do ((l list (cddr l)) + (k '() (list* (cadr l) (car l) k))) + ((or (null l) (not (member (car l) keys))) + (values (nreverse k) l))))) + (let ((block-tag (gensym)) + (temp-var (gensym)) + (data + (macrolet (;; KLUDGE: This started as an old DEFMACRO + ;; WITH-KEYWORD-PAIRS general utility, which was used + ;; only in this one place in the code. It was translated + ;; literally into this MACROLET in order to avoid some + ;; cross-compilation bootstrap problems. It would almost + ;; certainly be clearer, and it would certainly be more + ;; concise, to do a more idiomatic translation, merging + ;; this with the TRANSFORM-KEYWORDS logic above. + ;; -- WHN 19990925 + (with-keyword-pairs ((names expression) &body forms) + (let ((temp (member '&rest names))) + (unless (= (length temp) 2) + (error "&REST keyword is ~:[missing~;misplaced~]." + temp)) + (let* ((key-vars (ldiff names temp)) + (keywords (mapcar #'keywordicate key-vars)) + (key-var (gensym)) + (rest-var (cadr temp))) + `(multiple-value-bind (,key-var ,rest-var) + (parse-keyword-pairs ,expression ',keywords) + (let ,(mapcar (lambda (var keyword) + `(,var (getf ,key-var + ,keyword))) + key-vars keywords) + ,@forms)))))) + (mapcar (lambda (clause) + (with-keyword-pairs ((report interactive test + &rest forms) + (cddr clause)) + (list (car clause) ;name=0 + (gensym) ;tag=1 + (transform-keywords :report report ;keywords=2 + :interactive interactive + :test test) + (cadr clause) ;bvl=3 + forms))) ;body=4 + clauses)))) + `(block ,block-tag + (let ((,temp-var nil)) + (tagbody + (restart-bind + ,(mapcar (lambda (datum) + (let ((name (nth 0 datum)) + (tag (nth 1 datum)) + (keys (nth 2 datum))) + `(,name #'(lambda (&rest temp) + (setq ,temp-var temp) + (go ,tag)) + ,@keys))) + data) + (return-from ,block-tag + ,(munge-restart-case-expression expression env))) + ,@(mapcan (lambda (datum) + (let ((tag (nth 1 datum)) + (bvl (nth 3 datum)) + (body (nth 4 datum))) + (list tag + `(return-from ,block-tag + (apply (lambda ,bvl ,@body) + ,temp-var))))) + data))))))) + +(defmacro-mundanely with-simple-restart ((restart-name format-string + &rest format-arguments) + &body forms) + #!+sb-doc + "(WITH-SIMPLE-RESTART (restart-name format-string format-arguments) + body) + If restart-name is not invoked, then all values returned by forms are + returned. If control is transferred to this restart, it immediately + returns the values NIL and T." + `(restart-case + ;; If there's just one body form, then don't use PROGN. This allows + ;; RESTART-CASE to "see" calls to ERROR, etc. + ,(if (= (length forms) 1) (car forms) `(progn ,@forms)) + (,restart-name () + :report (lambda (stream) + (format stream ,format-string ,@format-arguments)) + (values nil t)))) + +(defmacro-mundanely handler-bind (bindings &body forms) + #!+sb-doc + "(HANDLER-BIND ( {(type handler)}* ) body) + Executes body in a dynamic context where the given handler bindings are + in effect. Each handler must take the condition being signalled as an + argument. The bindings are searched first to last in the event of a + signalled condition." + (let ((member-if (member-if (lambda (x) + (not (proper-list-of-length-p x 2))) + bindings))) + (when member-if + (error "ill-formed handler binding: ~S" (first member-if)))) + `(let ((*handler-clusters* + (cons (list ,@(mapcar (lambda (x) `(cons ',(car x) ,(cadr x))) + bindings)) + *handler-clusters*))) + (multiple-value-prog1 + (progn + ,@forms) + ;; Wait for any float exceptions. + #!+x86 (float-wait)))) + +(defmacro-mundanely handler-case (form &rest cases) + "(HANDLER-CASE form + { (type ([var]) body) }* ) + Execute FORM in a context with handlers established for the condition + types. A peculiar property allows type to be :NO-ERROR. If such a clause + occurs, and form returns normally, all its values are passed to this clause + as if by MULTIPLE-VALUE-CALL. The :NO-ERROR clause accepts more than one + var specification." + ;; FIXME: Replacing CADR, CDDDR and friends with DESTRUCTURING-BIND + ;; and names for the subexpressions would make it easier to + ;; understand the code below. + (let ((no-error-clause (assoc ':no-error cases))) + (if no-error-clause + (let ((normal-return (make-symbol "normal-return")) + (error-return (make-symbol "error-return"))) + `(block ,error-return + (multiple-value-call (lambda ,@(cdr no-error-clause)) + (block ,normal-return + (return-from ,error-return + (handler-case (return-from ,normal-return ,form) + ,@(remove no-error-clause cases))))))) + (let ((tag (gensym)) + (var (gensym)) + (annotated-cases (mapcar (lambda (case) (cons (gensym) case)) + cases))) + `(block ,tag + (let ((,var nil)) + (declare (ignorable ,var)) + (tagbody + (handler-bind + ,(mapcar (lambda (annotated-case) + (list (cadr annotated-case) + `(lambda (temp) + ,(if (caddr annotated-case) + `(setq ,var temp) + '(declare (ignore temp))) + (go ,(car annotated-case))))) + annotated-cases) + (return-from ,tag + #!-x86 ,form + #!+x86 (multiple-value-prog1 ,form + ;; Need to catch FP errors here! + (float-wait)))) + ,@(mapcan + (lambda (annotated-case) + (list (car annotated-case) + (let ((body (cdddr annotated-case))) + `(return-from + ,tag + ,(cond ((caddr annotated-case) + `(let ((,(caaddr annotated-case) + ,var)) + ,@body)) + ((not (cdr body)) + (car body)) + (t + `(progn ,@body))))))) + annotated-cases)))))))) ;;;; miscellaneous @@ -313,26 +594,57 @@ (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)) `#',whole) + +(defmacro-mundanely named-lambda (&whole whole name args &body body) + (declare (ignore name args body)) + `#',whole) + +(defmacro-mundanely lambda-with-lexenv (&whole whole + declarations macros symbol-macros + &body body) + (declare (ignore declarations macros symbol-macros body)) + `#',whole) + +;;; this eliminates a whole bundle of unknown function STYLE-WARNINGs +;;; when cross-compiling. It's not critical for behaviour, but is +;;; aesthetically pleasing, except inasmuch as there's this list of +;;; magic functions here. -- CSR, 2003-04-01 +#+sb-xc-host +(sb!xc:proclaim '(ftype (function * *) + ;; functions appearing in fundamental defining + ;; macro expansions: + %compiler-deftype + %defun + %defsetf + sb!c:%compiler-defun + sb!c::%define-symbol-macro + sb!c::%defconstant + sb!c::%define-compiler-macro + sb!c::%defmacro + sb!kernel::%compiler-defstruct + sb!kernel::%compiler-define-condition + sb!kernel::%defstruct + sb!kernel::%define-condition + ;; miscellaneous functions commonly appearing + ;; as a result of macro expansions or compiler + ;; transformations: + sb!int:find-undeleted-package-or-lose ; IN-PACKAGE + sb!kernel::arg-count-error ; PARSE-DEFMACRO + ))