X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fdefboot.lisp;h=1e915ca4b5bc40dea3c389feafe274149b393686;hb=4ba392170e98744f0ef0b8e08a5d42b988f1d0c9;hp=aa4c5a771b124edc72ef126c75583eda0c850e84;hpb=97406970b74c0213bb6eec93bb1554f1d3125241;p=sbcl.git diff --git a/src/code/defboot.lisp b/src/code/defboot.lisp index aa4c5a7..1e915ca 100644 --- a/src/code/defboot.lisp +++ b/src/code/defboot.lisp @@ -19,12 +19,14 @@ ;;;; files for more information. (in-package "SB!IMPL") + ;;;; IN-PACKAGE -(defmacro-mundanely in-package (package-designator) - `(eval-when (:compile-toplevel :load-toplevel :execute) - (setq *package* (find-undeleted-package-or-lose ',package-designator)))) +(defmacro-mundanely in-package (string-designator) + (let ((string (string string-designator))) + `(eval-when (:compile-toplevel :load-toplevel :execute) + (setq *package* (find-undeleted-package-or-lose ,string))))) ;;;; MULTIPLE-VALUE-FOO @@ -38,18 +40,25 @@ ;; at this level, but the CMU CL code did it, so.. -- WHN 19990411 (if (= (length vars) 1) `(let ((,(car vars) ,value-form)) - ,@body) - (let ((ignore (gensym))) - `(multiple-value-call #'(lambda (&optional ,@vars &rest ,ignore) - (declare (ignore ,ignore)) - ,@body) - ,value-form))) + ,@body) + (let ((ignore (sb!xc:gensym))) + `(multiple-value-call #'(lambda (&optional ,@(mapcar #'list vars) + &rest ,ignore) + (declare (ignore ,ignore)) + ,@body) + ,value-form))) (error "Vars is not a list of symbols: ~S" vars))) (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)) @@ -60,64 +69,73 @@ (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))))))))) - -;;; other things defined in terms of COND + (let ((clause (first clauses)) + (more (rest 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 ,@more)))) + (if (eq t test) + ;; THE to perserve non-toplevelness for FOO in + ;; (COND (T (FOO))) + `(the t (progn ,@forms)) + `(if ,test + (progn ,@forms) + ,(when more `(cond ,@more)))))))))) + (defmacro-mundanely when (test &body forms) #!+sb-doc "If the first argument is true, the rest of the forms are - evaluated as a PROGN." - `(cond (,test nil ,@forms))) +evaluated as a PROGN." + `(if ,test (progn ,@forms) nil)) + (defmacro-mundanely unless (test &body forms) #!+sb-doc "If the first argument is not true, the rest of the forms are - evaluated as a PROGN." - `(cond ((not ,test) nil ,@forms))) +evaluated as a PROGN." + `(if ,test nil (progn ,@forms))) + (defmacro-mundanely and (&rest forms) (cond ((endp forms) t) - ((endp (rest forms)) (first forms)) - (t - `(if ,(first forms) - (and ,@(rest forms)) - nil)))) + ((endp (rest forms)) + ;; Preserve non-toplevelness of the form! + `(the t ,(first forms))) + (t + `(if ,(first forms) + (and ,@(rest forms)) + nil)))) + (defmacro-mundanely or (&rest forms) (cond ((endp forms) nil) - ((endp (rest forms)) (first forms)) - (t - (let ((n-result (gensym))) - `(let ((,n-result ,(first forms))) - (if ,n-result - ,n-result - (or ,@(rest forms)))))))) + ((endp (rest forms)) + ;; Preserve non-toplevelness of the form! + `(the t ,(first forms))) + (t + (let ((n-result (gensym))) + `(let ((,n-result ,(first forms))) + (if ,n-result + ,n-result + (or ,@(rest forms)))))))) ;;;; various sequencing constructs -(defmacro-mundanely prog (varlist &body body-decls) - (multiple-value-bind (body decls) (parse-body body-decls nil) - `(block nil - (let ,varlist - ,@decls - (tagbody ,@body))))) - -(defmacro-mundanely prog* (varlist &body body-decls) - (multiple-value-bind (body decls) (parse-body body-decls nil) - `(block nil - (let* ,varlist - ,@decls - (tagbody ,@body))))) +(flet ((prog-expansion-from-let (varlist body-decls let) + (multiple-value-bind (body decls) + (parse-body body-decls :doc-string-allowed nil) + `(block nil + (,let ,varlist + ,@decls + (tagbody ,@body)))))) + (defmacro-mundanely prog (varlist &body body-decls) + (prog-expansion-from-let varlist body-decls 'let)) + (defmacro-mundanely prog* (varlist &body body-decls) + (prog-expansion-from-let varlist body-decls 'let*))) (defmacro-mundanely prog1 (result &body body) (let ((n-result (gensym))) @@ -134,7 +152,8 @@ (defun inline-fun-name-p (name) (or ;; the normal reason for saving the inline expansion - (info :function :inlinep name) + (let ((inlinep (info :function :inlinep name))) + (member inlinep '(:inline :maybe-inline))) ;; another reason for saving the inline expansion: If the ;; ANSI-recommended idiom ;; (DECLAIM (INLINE FOO)) @@ -149,108 +168,96 @@ ;; 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 (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 - ,@decls - (block ,(fun-name-block-name name) - ,@forms))) - (lambda `(lambda ,@lambda-guts)) + (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 - (cond (;; Does the user not even want to inline? - (not (inline-fun-name-p name)) - nil) - (;; Does inlining look too hairy to handle? - (not (sb!c:lambda-independent-of-lexenv-p lambda env)) - (sb!c:maybe-compiler-note - "lexical environment too hairy, can't inline DEFUN ~S" - name) - nil) - (t - ;; FIXME: The only reason that we return - ;; LAMBDA-WITH-LEXENV instead of returning bare - ;; LAMBDA is to avoid modifying downstream code - ;; which expects LAMBDA-WITH-LEXENV. But the code - ;; here is the only code which feeds into the - ;; downstream code, and the generality of the - ;; interface is no longer used, so it'd make sense - ;; to simplify the interface instead of using the - ;; old general LAMBDA-WITH-LEXENV interface in this - ;; simplified way. - `(sb!c:lambda-with-lexenv - nil nil nil ; i.e. no DECLS, no MACROS, no SYMMACS - ,@lambda-guts))))) + (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) + (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 + (sb!c:source-location))))))) - ;; 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) +(defun %defun (name def doc inline-lambda source-location) (declare (type function def)) - (declare (type (or null simple-string doc))) + (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)) + (warn 'sb!kernel::redefinition-with-defun + :name name + :new-function def + :new-location source-location)) (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) + ;; %COMPILER-DEFUN doesn't do this except at compile-time, when it + ;; also checks package locks. By doing this here we let (SETF + ;; FDEFINITION) do the load-time package lock checking before + ;; we frob any existing inline expansions. + (sb!c::%set-inline-expansion name nil inline-lambda) + + (sb!c::note-name-defined name :function) (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 (the symbol name) 'function) doc))) + (setf (%fun-doc def) doc)) + name) ;;;; DEFVAR and DEFPARAMETER (defmacro-mundanely defvar (var &optional (val nil valp) (doc nil docp)) #!+sb-doc - "Define a global variable at top level. Declare the variable + "Define a special 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)))) - ,@(when docp - `((funcall #'(setf fdocumentation) ',doc ',var 'variable))) - ',var)) + (eval-when (:compile-toplevel) + (%compiler-defvar ',var)) + (eval-when (:load-toplevel :execute) + (%defvar ',var (unless (boundp ',var) ,val) + ',valp ,doc ',docp + (sb!c:source-location))))) (defmacro-mundanely defparameter (var val &optional (doc nil docp)) #!+sb-doc @@ -260,14 +267,35 @@ previous value. The third argument is an optional documentation string for the parameter." `(progn - (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))) - ',var)) + (eval-when (:compile-toplevel) + (%compiler-defvar ',var)) + (eval-when (:load-toplevel :execute) + (%defparameter ',var ,val ,doc ',docp (sb!c:source-location))))) + +(defun %compiler-defvar (var) + (sb!xc:proclaim `(special ,var))) + +#-sb-xc-host +(defun %defvar (var val valp doc docp source-location) + (%compiler-defvar var) + (when valp + (unless (boundp var) + (set var val))) + (when docp + (setf (fdocumentation var 'variable) doc)) + (sb!c:with-source-location (source-location) + (setf (info :source-location :variable var) source-location)) + var) + +#-sb-xc-host +(defun %defparameter (var val doc docp source-location) + (%compiler-defvar var) + (set var val) + (when docp + (setf (fdocumentation var 'variable) doc)) + (sb!c:with-source-location (source-location) + (setf (info :source-location :variable var) source-location)) + var) ;;;; iteration constructs @@ -296,7 +324,7 @@ evaluated before each evaluation of the body Forms. When the Test is true, 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." + allowing RETURN to be used as an alternate exit mechanism." (frob-do-body varlist endlist body 'let* 'setq 'do* nil)) ;;; DOTIMES and DOLIST could be defined more concisely using @@ -306,49 +334,374 @@ ;;; 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 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))) - ,@decls +(defmacro-mundanely dotimes ((var count &optional (result nil)) &body body) + (cond ((integerp count) + `(do ((,var 0 (1+ ,var))) + ((>= ,var ,count) ,result) + (declare (type unsigned-byte ,var)) + ,@body)) + (t + (let ((c (gensym "COUNT"))) + `(do ((,var 0 (1+ ,var)) + (,c ,count)) + ((>= ,var ,c) ,result) + (declare (type unsigned-byte ,var) + (type integer ,c)) + ,@body))))) + +(defmacro-mundanely dolist ((var list &optional (result nil)) &body body &environment env) + ;; 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 :doc-string-allowed nil) + (let* ((n-list (gensym "N-LIST")) + (start (gensym "START"))) + (multiple-value-bind (clist members clist-ok) + (cond ((sb!xc:constantp list env) + (let ((value (constant-form-value list env))) + (multiple-value-bind (all dot) (list-members value :max-length 20) + (when (eql dot t) + ;; Full warning is too much: the user may terminate the loop + ;; early enough. Contents are still right, though. + (style-warn "Dotted list ~S in DOLIST." value)) + (if (eql dot :maybe) + (values value nil nil) + (values value all t))))) + ((and (consp list) (eq 'list (car list)) + (every (lambda (arg) (sb!xc:constantp arg env)) (cdr list))) + (let ((values (mapcar (lambda (arg) (constant-form-value arg env)) (cdr list)))) + (values values values t))) + (t + (values nil nil nil))) + `(block nil + (let ((,n-list ,(if clist-ok (list 'quote clist) list))) + (tagbody + ,start + (unless (endp ,n-list) + (let ((,var ,(if clist-ok + `(truly-the (member ,@members) (car ,n-list)) + `(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 + +;;; KLUDGE: we PROCLAIM these special here so that we can use restart +;;; macros in the compiler before the DEFVARs are compiled. +;;; +;;; For an explanation of these data structures, see DEFVARs in +;;; target-error.lisp. +(sb!xc:proclaim '(special *handler-clusters* *restart-clusters*)) + +(defmacro-mundanely with-condition-restarts + (condition-form restarts-form &body body) + #!+sb-doc + "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." + (once-only ((restarts restarts-form)) + (with-unique-names (restart) + ;; FIXME: check the need for interrupt-safety. + `(unwind-protect + (progn + (dolist (,restart ,restarts) + (push ,condition-form + (restart-associated-conditions ,restart))) + ,@body) + (dolist (,restart ,restarts) + (pop (restart-associated-conditions ,restart))))))) + +(defmacro-mundanely restart-bind (bindings &body forms) + #!+sb-doc + "(RESTART-BIND ({(case-name function {keyword value}*)}*) forms) + Executes forms in a dynamic context where the given bindings are in + effect. Users probably want to use RESTART-CASE. A case-name of NIL + indicates an anonymous restart. When bindings contain the same + restart name, FIND-RESTART will find the first such binding." + (flet ((parse-binding (binding) + (unless (>= (length binding) 2) + (error "ill-formed restart binding: ~S" binding)) + (destructuring-bind (name function + &key interactive-function + test-function + report-function) + binding + (unless (or name report-function) + (warn "Unnamed restart does not have a report function: ~ + ~S" binding)) + `(make-restart ',name ,function + ,report-function + ,interactive-function + ,@(and test-function + `(,test-function)))))) + `(let ((*restart-clusters* + (cons (list ,@(mapcar #'parse-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 (%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 exp) ,n-cond) + `(,name ,n-cond)))) + expression)) + expression))) + +(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 form is a call to + SIGNAL, ERROR, CERROR or WARN (or macroexpands into such) then the + signalled condition will be associated with the new restarts." + ;; PARSE-CLAUSE (which uses PARSE-KEYWORDS-AND-BODY) is used to + ;; parse all clauses into lists of the form + ;; + ;; (NAME TAG KEYWORDS LAMBDA-LIST BODY) + ;; + ;; where KEYWORDS are suitable keywords for use in HANDLER-BIND + ;; bindings. These lists are then passed to + ;; * MAKE-BINDING which generates bindings for the respective NAME + ;; for HANDLER-BIND + ;; * MAKE-APPLY-AND-RETURN which generates TAGBODY entries executing + ;; the respective BODY. + (let ((block-tag (sb!xc:gensym "BLOCK")) + (temp-var (gensym))) + (labels ((parse-keywords-and-body (keywords-and-body) + (do ((form keywords-and-body (cddr form)) + (result '())) (nil) + (destructuring-bind (&optional key (arg nil argp) &rest rest) + form + (declare (ignore rest)) + (setq result + (append + (cond + ((and (eq key :report) argp) + (list :report-function + (if (stringp arg) + `#'(lambda (stream) + (write-string ,arg stream)) + `#',arg))) + ((and (eq key :interactive) argp) + (list :interactive-function `#',arg)) + ((and (eq key :test) argp) + (list :test-function `#',arg)) + (t + (return (values result form)))) + result))))) + (parse-clause (clause) + (unless (and (listp clause) (>= (length clause) 2) + (listp (second clause))) + (error "ill-formed ~S clause, no lambda-list:~% ~S" + 'restart-case clause)) + (destructuring-bind (name lambda-list &body body) clause + (multiple-value-bind (keywords body) + (parse-keywords-and-body body) + (list name (sb!xc:gensym "TAG") keywords lambda-list body)))) + (make-binding (clause-data) + (destructuring-bind (name tag keywords lambda-list body) clause-data + (declare (ignore body)) + `(,name + (lambda ,(cond ((null lambda-list) + ()) + ((and (null (cdr lambda-list)) + (not (member (car lambda-list) + '(&optional &key &aux)))) + '(temp)) + (t + '(&rest temp))) + ,@(when lambda-list `((setq ,temp-var temp))) + (locally (declare (optimize (safety 0))) + (go ,tag))) + ,@keywords))) + (make-apply-and-return (clause-data) + (destructuring-bind (name tag keywords lambda-list body) clause-data + (declare (ignore name keywords)) + `(,tag (return-from ,block-tag + ,(cond ((null lambda-list) + `(progn ,@body)) + ((and (null (cdr lambda-list)) + (not (member (car lambda-list) + '(&optional &key &aux)))) + `(funcall (lambda ,lambda-list ,@body) ,temp-var)) + (t + `(apply (lambda ,lambda-list ,@body) ,temp-var)))))))) + (let ((clauses-data (mapcar #'parse-clause clauses))) + `(block ,block-tag + (let ((,temp-var nil)) + (declare (ignorable ,temp-var)) (tagbody - ,@forms))))))) + (restart-bind + ,(mapcar #'make-binding clauses-data) + (return-from ,block-tag + ,(munge-restart-case-expression expression env))) + ,@(mapcan #'make-apply-and-return clauses-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 form) + (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* ((local-funs nil) + (mapped-bindings (mapcar (lambda (binding) + (destructuring-bind (type handler) binding + (let ((lambda-form handler)) + (if (and (consp handler) + (or (eq 'lambda (car handler)) + (and (eq 'function (car handler)) + (consp (cdr handler)) + (let ((x (second handler))) + (and (consp x) + (eq 'lambda (car x)) + (setf lambda-form x)))))) + (let ((name (sb!xc:gensym "LAMBDA"))) + (push `(,name ,@(cdr lambda-form)) local-funs) + (list type `(function ,name))) + binding)))) + bindings))) + `(dx-flet (,@(reverse local-funs)) + (let ((*handler-clusters* + (cons (list ,@(mapcar (lambda (x) `(cons ',(car x) ,(cadr x))) + mapped-bindings)) + *handler-clusters*))) + #!+stack-allocatable-fixed-objects + (declare (truly-dynamic-extent *handler-clusters*)) + (progn ,form))))) + +(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." + `(%handler-bind ,bindings + #!-x86 (progn ,@forms) + ;; Need to catch FP errors here! + #!+x86 (multiple-value-prog1 (progn ,@forms) (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." + (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* ((local-funs nil) + (annotated-cases + (mapcar (lambda (case) + (with-unique-names (tag fun) + (destructuring-bind (type ll &body body) case + (push `(,fun ,ll ,@body) local-funs) + (list tag type ll fun)))) + cases))) + (with-unique-names (block cell form-fun) + `(dx-flet ((,form-fun () + #!-x86 ,form + ;; Need to catch FP errors here! + #!+x86 (multiple-value-prog1 ,form (float-wait))) + ,@(reverse local-funs)) + (declare (optimize (sb!c::check-tag-existence 0))) + (block ,block + ;; KLUDGE: We use a dx CONS cell instead of just assigning to + ;; the variable directly, so that we can stack allocate + ;; robustly: dx value cells don't work quite right, and it is + ;; possible to construct user code that should loop + ;; indefinitely, but instead eats up some stack each time + ;; around. + (dx-let ((,cell (cons :condition nil))) + (declare (ignorable ,cell)) + (tagbody + (%handler-bind + ,(mapcar (lambda (annotated-case) + (destructuring-bind (tag type ll fun-name) annotated-case + (declare (ignore fun-name)) + (list type + `(lambda (temp) + ,(if ll + `(setf (cdr ,cell) temp) + '(declare (ignore temp))) + (go ,tag))))) + annotated-cases) + (return-from ,block (,form-fun))) + ,@(mapcan + (lambda (annotated-case) + (destructuring-bind (tag type ll fun-name) annotated-case + (declare (ignore type)) + (list tag + `(return-from ,block + ,(if ll + `(,fun-name (cdr ,cell)) + `(,fun-name)))))) + annotated-cases)))))))))) ;;;; miscellaneous @@ -361,22 +714,56 @@ 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 + %compiler-defvar + %defun + %defsetf + %defparameter + %defvar + 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 + ))