,n-result
(cond ,@more))))
(if (eq t test)
- `(progn ,@forms)
+ ;; 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 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))
(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!c:%compiler-defun name inline-lambda nil)
(when (fboundp name)
(/show0 "redefining NAME in %DEFUN")
- (style-warn 'sb!kernel::redefinition-with-defun :name name
- :old (fdefinition name) :new def
- :new-location source-location))
+ (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)
(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
- ;; (2) doing probably isn't even really safe.
- #+nil (setf (%fun-name def) name)
-
(when doc
- (setf (fdocumentation name 'function) doc)
- #!+sb-eval
- (when (typep def 'sb!eval:interpreted-function)
- (setf (sb!eval:interpreted-function-documentation def)
- 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."
;;; 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)
+ (cond ((integerp count)
`(do ((,var 0 (1+ ,var)))
((>= ,var ,count) ,result)
(declare (type unsigned-byte ,var))
;; var.
(multiple-value-bind (forms decls) (parse-body body :doc-string-allowed nil)
(let* ((n-list (gensym "N-LIST"))
- (start (gensym "START"))
- (tmp (gensym "TMP")))
+ (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)
- (when dot
+ (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))
- (values value all t))))
+ (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))))
(tagbody
,start
(unless (endp ,n-list)
- (let* (,@(if clist-ok
- `((,tmp (truly-the (member ,@members) (car ,n-list)))
- (,var ,tmp))
- `((,var (car ,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))
;;; 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))))
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))
(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)))))
(push `(,fun ,ll ,@body) local-funs)
(list tag type ll fun))))
cases)))
- (with-unique-names (block var form-fun)
+ (with-unique-names (block cell form-fun)
`(dx-flet ((,form-fun ()
#!-x86 ,form
;; Need to catch FP errors here!
,@(reverse local-funs))
(declare (optimize (sb!c::check-tag-existence 0)))
(block ,block
- (dx-let ((,var nil))
- (declare (ignorable ,var))
+ ;; 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)
(list type
`(lambda (temp)
,(if ll
- `(setf ,var temp)
+ `(setf (cdr ,cell) temp)
'(declare (ignore temp)))
(go ,tag)))))
annotated-cases)
(list tag
`(return-from ,block
,(if ll
- `(,fun-name ,var)
+ `(,fun-name (cdr ,cell))
`(,fun-name))))))
annotated-cases))))))))))
\f
projects / sbcl.git / blobdiff