;;;; files for more information.
(in-package "SB!IMPL")
+
\f
;;;; 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)))))
\f
;;;; MULTIPLE-VALUE-FOO
(if (= (length vars) 1)
`(let ((,(car vars) ,value-form))
,@body)
- (let ((ignore (gensym)))
+ (let ((ignore (sb!xc:gensym)))
`(multiple-value-call #'(lambda (&optional ,@(mapcar #'list vars)
&rest ,ignore)
(declare (ignore ,ignore))
(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))
`(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)
+ ;; THE to perserve non-toplevelness for FOO in
+ ;; (COND (T (FOO)))
+ `(the t (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))
+ ((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))
+ ((endp (rest forms))
+ ;; Preserve non-toplevelness of the form!
+ `(the t ,(first forms)))
(t
(let ((n-result (gensym)))
`(let ((,n-result ,(first forms)))
(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))
#-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 (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))
+ (warn 'sb!kernel::redefinition-with-defun
+ :name name
+ :new-function def
+ :new-location source-location))
(setf (sb!xc:fdefinition name) def)
+ ;; %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)
- ;; 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)
+ (sb!c::note-name-defined name :function)
(when doc
- (setf (fdocumentation name 'function) doc))
+ (setf (%fun-doc def) doc))
+
name)
\f
;;;; 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."
(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
(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)
\f
;;;; iteration constructs
;;; 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)))))
-
-(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)
+ (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
;; 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")))
- `(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)))))
+ (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))))))
\f
;;;; conditions, handlers, restarts
;;; 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)))
+ (let ((exp (%macroexpand expression env)))
(if (consp exp)
(let* ((name (car exp))
(args (if (eq name 'cerror) (cddr exp) (cdr exp))))
(k '() (list* (cadr l) (car l) k)))
((or (null l) (not (member (car l) keys)))
(values (nreverse k) l)))))
- (let ((block-tag (gensym))
+ (let ((block-tag (sb!xc:gensym "BLOCK"))
(temp-var (gensym))
(data
(macrolet (;; KLUDGE: This started as an old DEFMACRO
key-vars keywords)
,@forms))))))
(mapcar (lambda (clause)
+ (unless (listp (second clause))
+ (error "Malformed ~S clause, no lambda-list:~% ~S"
+ 'restart-case clause))
(with-keyword-pairs ((report interactive test
&rest forms)
(cddr clause))
(list (car clause) ;name=0
- (gensym) ;tag=1
+ (sb!xc:gensym "TAG") ;tag=1
(transform-keywords :report report ;keywords=2
:interactive interactive
:test test)
(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."
+(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 ((*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))))
+ (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."
- ;; FIXME: Replacing CADR, CDDDR and friends with DESTRUCTURING-BIND
- ;; and names for the subexpressions would make it easier to
- ;; understand the code below.
+ "(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"))
(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))
- (t
- `(locally ,@body)))))))
- annotated-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))))))))))
\f
;;;; miscellaneous
projects / sbcl.git / blobdiff