cont
form
&optional
- (proxy ``(error "execution of a form compiled with errors:~% ~S"
- ',,form)))
+ (proxy ``(error 'simple-program-error
+ :format-control "execution of a form compiled with errors:~% ~S"
+ :format-arguments (list ',,form))))
&body body)
(let ((skip (gensym "SKIP")))
`(block ,skip
;;; functional instead.
(defun reference-leaf (start cont leaf)
(declare (type continuation start cont) (type leaf leaf))
- (let* ((leaf (or (and (defined-fun-p leaf)
- (not (eq (defined-fun-inlinep leaf)
- :notinline))
- (let ((functional (defined-fun-functional leaf)))
- (when (and functional
- (not (functional-kind functional)))
- (maybe-reanalyze-functional functional))))
- leaf))
- (res (make-ref (or (lexenv-find leaf type-restrictions)
- (leaf-type leaf))
- leaf)))
- (push res (leaf-refs leaf))
- (setf (leaf-ever-used leaf) t)
- (link-node-to-previous-continuation res start)
- (use-continuation res cont)))
+ (with-continuation-type-assertion
+ (cont (or (lexenv-find leaf type-restrictions) *wild-type*)
+ "in DECLARE")
+ (let* ((leaf (or (and (defined-fun-p leaf)
+ (not (eq (defined-fun-inlinep leaf)
+ :notinline))
+ (let ((functional (defined-fun-functional leaf)))
+ (when (and functional
+ (not (functional-kind functional)))
+ (maybe-reanalyze-functional functional))))
+ leaf))
+ (res (make-ref (leaf-type leaf)
+ leaf)))
+ (push res (leaf-refs leaf))
+ (setf (leaf-ever-used leaf) t)
+ (link-node-to-previous-continuation res start)
+ (use-continuation res cont))))
;;; Convert a reference to a symbolic constant or variable. If the
;;; symbol is entered in the LEXENV-VARS we use that definition,
(values))
;;; Convert anything that looks like a special form, global function
-;;; or macro call.
+;;; or compiler-macro call.
(defun ir1-convert-global-functoid (start cont form)
(declare (type continuation start cont) (list form))
- (let* ((fun (first form))
- (translator (info :function :ir1-convert fun))
- (cmacro (info :function :compiler-macro-function fun)))
- (cond (translator (funcall translator start cont form))
- ((and cmacro
- (not (eq (info :function :inlinep fun)
- :notinline)))
- (let ((res (careful-expand-macro cmacro form)))
+ (let* ((fun-name (first form))
+ (translator (info :function :ir1-convert fun-name))
+ (cmacro-fun (sb!xc:compiler-macro-function fun-name *lexenv*)))
+ (cond (translator
+ (when cmacro-fun
+ (compiler-warn "ignoring compiler macro for special form"))
+ (funcall translator start cont form))
+ ((and cmacro-fun
+ ;; gotcha: If you look up the DEFINE-COMPILER-MACRO
+ ;; macro in the ANSI spec, you might think that
+ ;; suppressing compiler-macro expansion when NOTINLINE
+ ;; is some pre-ANSI hack. However, if you look up the
+ ;; NOTINLINE declaration, you'll find that ANSI
+ ;; requires this behavior after all.
+ (not (eq (info :function :inlinep fun-name) :notinline)))
+ (let ((res (careful-expand-macro cmacro-fun form)))
(if (eq res form)
- (ir1-convert-global-functoid-no-cmacro start cont form fun)
+ (ir1-convert-global-functoid-no-cmacro
+ start cont form fun-name)
(ir1-convert start cont res))))
(t
- (ir1-convert-global-functoid-no-cmacro start cont form fun)))))
+ (ir1-convert-global-functoid-no-cmacro start cont form fun-name)))))
;;; Handle the case of where the call was not a compiler macro, or was
;;; a compiler macro and passed.
`(values ,@types))
cont
res
- 'values))))
+ "in VALUES declaration"))))
(dynamic-extent
(when (policy *lexenv* (> speed inhibit-warnings))
(compiler-note
(declaim (ftype (function (list) (values list boolean boolean list list))
make-lambda-vars))
(defun make-lambda-vars (list)
- (multiple-value-bind (required optional restp rest keyp keys allowp aux
+ (multiple-value-bind (required optional restp rest keyp keys allowp auxp aux
morep more-context more-count)
(parse-lambda-list list)
+ (declare (ignore auxp)) ; since we just iterate over AUX regardless
(collect ((vars)
(names-so-far)
(aux-vars)
(multiple-value-bind (vars keyp allow-other-keys aux-vars aux-vals)
(make-lambda-vars (cadr form))
- (multiple-value-bind (forms decls) (sb!sys:parse-body (cddr form))
+ (multiple-value-bind (forms decls) (parse-body (cddr form))
(let* ((result-cont (make-continuation))
(*lexenv* (process-decls decls
(append aux-vars vars)
:source-name source-name
:debug-name debug-name))))
-;;; Get a DEFINED-FUN object for a function we are about to
-;;; define. If the function has been forward referenced, then
-;;; substitute for the previous references.
+;;; Get a DEFINED-FUN object for a function we are about to define. If
+;;; the function has been forward referenced, then substitute for the
+;;; previous references.
(defun get-defined-fun (name)
(proclaim-as-fun-name name)
(let ((found (find-free-fun name "shouldn't happen! (defined-fun)")))
(setf (functional-inlinep fun) (defined-fun-inlinep var))
(assert-new-definition var fun)
(setf (defined-fun-inline-expansion var) var-expansion)
- ;; If definitely not an interpreter stub, then substitute for any
- ;; old references.
+ ;; If definitely not an interpreter stub, then substitute for
+ ;; any old references.
(unless (or (eq (defined-fun-inlinep var) :notinline)
(not *block-compile*)
(and fun-info
projects / sbcl.git / blobdiff