(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))
: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)
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
;; 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))
;;; KLUDGE: we PROCLAIM these special here so that we can use restart
;;; macros in the compiler before the DEFVARs are compiled.
-(sb!xc:proclaim
- '(special *handler-clusters* *restart-clusters* *condition-restarts*))
+;;;
+;;; 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)
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."
- (let ((n-cond (gensym)))
- `(let ((*condition-restarts*
- (cons (let ((,n-cond ,condition-form))
- (cons ,n-cond
- (append ,restarts-form
- (cdr (assoc ,n-cond *condition-restarts*)))))
- *condition-restarts*)))
- ,@body)))
+ (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
- "Executes forms in a dynamic context where the given restart bindings are
- in effect. Users probably want to use RESTART-CASE. When clauses contain
- the same restart name, FIND-RESTART will find the first such clause."
- `(let ((*restart-clusters*
- (cons (list
- ,@(mapcar (lambda (binding)
- (unless (or (car binding)
- (member :report-function
- binding
- :test #'eq))
- (warn "Unnamed restart does not have a ~
- report function: ~S"
- binding))
- `(make-restart :name ',(car binding)
- :function ,(cadr binding)
- ,@(cddr binding)))
- bindings))
- *restart-clusters*)))
- ,@forms))
+ "(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 (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))))
expression))
expression)))
-;;; FIXME: I did a fair amount of rearrangement of this code in order to
-;;; get WITH-KEYWORD-PAIRS to work cleanly. This code should be tested..
(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 Expression is a call to SIGNAL, ERROR, CERROR or WARN (or
- macroexpands into such) then the signalled condition will be associated with
- the new restarts."
- (flet ((transform-keywords (&key report interactive test)
- (let ((result '()))
- (when report
- (setq result (list* (if (stringp report)
+ "(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 ,report stream))
- `#',report)
- :report-function
- result)))
- (when interactive
- (setq result (list* `#',interactive
- :interactive-function
- result)))
- (when test
- (setq result (list* `#',test :test-function result)))
- (nreverse result)))
- (parse-keyword-pairs (list keys)
- (do ((l list (cddr l))
- (k '() (list* (cadr l) (car l) k)))
- ((or (null l) (not (member (car l) keys)))
- (values (nreverse k) l)))))
- (let ((block-tag (sb!xc:gensym "BLOCK"))
- (temp-var (gensym))
- (data
- (macrolet (;; KLUDGE: This started as an old DEFMACRO
- ;; WITH-KEYWORD-PAIRS general utility, which was used
- ;; only in this one place in the code. It was translated
- ;; literally into this MACROLET in order to avoid some
- ;; cross-compilation bootstrap problems. It would almost
- ;; certainly be clearer, and it would certainly be more
- ;; concise, to do a more idiomatic translation, merging
- ;; this with the TRANSFORM-KEYWORDS logic above.
- ;; -- WHN 19990925
- (with-keyword-pairs ((names expression) &body forms)
- (let ((temp (member '&rest names)))
- (unless (= (length temp) 2)
- (error "&REST keyword is ~:[missing~;misplaced~]."
- temp))
- (let* ((key-vars (ldiff names temp))
- (keywords (mapcar #'keywordicate key-vars))
- (key-var (gensym))
- (rest-var (cadr temp)))
- `(multiple-value-bind (,key-var ,rest-var)
- (parse-keyword-pairs ,expression ',keywords)
- (let ,(mapcar (lambda (var keyword)
- `(,var (getf ,key-var
- ,keyword)))
- 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
- (sb!xc:gensym "TAG") ;tag=1
- (transform-keywords :report report ;keywords=2
- :interactive interactive
- :test test)
- (cadr clause) ;bvl=3
- forms))) ;body=4
- clauses))))
- `(block ,block-tag
- (let ((,temp-var nil))
- (tagbody
- (restart-bind
- ,(mapcar (lambda (datum)
- (let ((name (nth 0 datum))
- (tag (nth 1 datum))
- (keys (nth 2 datum)))
- `(,name #'(lambda (&rest temp)
- (setq ,temp-var temp)
- (go ,tag))
- ,@keys)))
- data)
- (return-from ,block-tag
- ,(munge-restart-case-expression expression env)))
- ,@(mapcan (lambda (datum)
- (let ((tag (nth 1 datum))
- (bvl (nth 3 datum))
- (body (nth 4 datum)))
- (list tag
- `(return-from ,block-tag
- (apply (lambda ,bvl ,@body)
- ,temp-var)))))
- data)))))))
+ (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
+ (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)
projects / sbcl.git / blobdiff