X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=src%2Fcode%2Fdefboot.lisp;h=16fd031579d3eb8daeb3ce3fcf055e875c2674ec;hb=2e002dae2f9a3c64f147ca651751ed833806ad5e;hp=f87d263331a339c4ac0f313e28fb31843bd83ff0;hpb=4898ef32c639b1c7f4ee13a5ba566ce6debd03e6;p=sbcl.git diff --git a/src/code/defboot.lisp b/src/code/defboot.lisp index f87d263..16fd031 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 @@ -67,7 +69,8 @@ (defmacro-mundanely cond (&rest clauses) (if (endp clauses) nil - (let ((clause (first clauses))) + (let ((clause (first clauses)) + (more (rest clauses))) (if (atom clause) (error "COND clause is not a list: ~S" clause) (let ((test (first clause)) @@ -77,22 +80,25 @@ `(let ((,n-result ,test)) (if ,n-result ,n-result - (cond ,@(rest clauses))))) - `(if ,test - (progn ,@forms) - (cond ,@(rest clauses))))))))) + (cond ,@more)))) + (if (eq t test) + `(progn ,@forms) + `(if ,test + (progn ,@forms) + ,(when more `(cond ,@more)))))))))) -;;; other things defined in terms of COND (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)) @@ -100,6 +106,7 @@ `(if ,(first forms) (and ,@(rest forms)) nil)))) + (defmacro-mundanely or (&rest forms) (cond ((endp forms) nil) ((endp (rest forms)) (first forms)) @@ -200,10 +207,12 @@ #-sb-xc-host ,named-lambda #+sb-xc-host (fdefinition ',name) ,doc - ',inline-lambda)))))) + ',inline-lambda + (sb!c:source-location))))))) #-sb-xc-host -(defun %defun (name def doc inline-lambda) +(defun %defun (name def doc inline-lambda source-location) + (declare (ignore source-location)) (declare (type function def)) (declare (type (or null simple-string) doc)) (aver (legal-fun-name-p name)) ; should've been checked by DEFMACRO DEFUN @@ -213,6 +222,8 @@ (style-warn "redefining ~S in DEFUN" name)) (setf (sb!xc:fdefinition name) def) + (sb!c::note-name-defined name :function) + ;; 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 @@ -220,7 +231,11 @@ #+nil (setf (%fun-name def) name) (when doc - (setf (fdocumentation name 'function) doc)) + (setf (fdocumentation name 'function) doc) + #!+sb-eval + (when (typep def 'sb!eval:interpreted-function) + (setf (sb!eval:interpreted-function-documentation def) + doc))) name) ;;;; DEFVAR and DEFPARAMETER @@ -235,7 +250,9 @@ (eval-when (:compile-toplevel) (%compiler-defvar ',var)) (eval-when (:load-toplevel :execute) - (%defvar ',var (unless (boundp ',var) ,val) ',valp ,doc ',docp)))) + (%defvar ',var (unless (boundp ',var) ,val) + ',valp ,doc ',docp + (sb!c:source-location))))) (defmacro-mundanely defparameter (var val &optional (doc nil docp)) #!+sb-doc @@ -248,27 +265,31 @@ (eval-when (:compile-toplevel) (%compiler-defvar ',var)) (eval-when (:load-toplevel :execute) - (%defparameter ',var ,val ,doc ',docp)))) + (%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) +(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) +(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 @@ -310,25 +331,18 @@ ;;; 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))))) - -(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)) + `(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) ;; We repeatedly bind the var instead of setting it so that we never