X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=src%2Fcode%2Fdefboot.lisp;h=aa4c5a771b124edc72ef126c75583eda0c850e84;hb=97e52e46f9bcb054eec35a9c326db75993441ca1;hp=73cf75333b8012ff51c35ee1763985c988fd071f;hpb=cd176690400f8b6fa23faa4dc6fa8494bcbce480;p=sbcl.git diff --git a/src/code/defboot.lisp b/src/code/defboot.lisp index 73cf753..aa4c5a7 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) @@ -170,12 +157,14 @@ (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* (;; stuff shared between LAMBDA and INLINE-LAMBDA + (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 (cond (;; Does the user not even want to inline? (not (inline-fun-name-p name)) @@ -204,6 +193,11 @@ ;; 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) @@ -215,19 +209,25 @@ ;; where the compiled LAMBDA first appears. In ;; cross-compilation, we manipulate the ;; previously-statically-linked LAMBDA here. - #-sb-xc-host ,lambda + #-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)) + (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) - (setf (%fun-name def) name) + + ;; 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)) @@ -271,11 +271,11 @@ ;;;; iteration constructs -;;; (These macros are defined in terms of a function DO-DO-BODY which +;;; (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 DO-DO-BODY should be, these macros can't conveniently be in -;;; the same file as DO-DO-BODY.) +;;; 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* @@ -286,7 +286,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* @@ -297,7 +297,7 @@ 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)) + (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 @@ -323,8 +323,8 @@ (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) + (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) @@ -334,18 +334,21 @@ ;; 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. - (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))))) + ;; 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 + (tagbody + ,@forms))))))) ;;;; miscellaneous @@ -354,7 +357,7 @@ (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."