(def-ir1-translator progn ((&rest forms) start next result)
#!+sb-doc
- "Progn Form*
- Evaluates each Form in order, returning the values of the last form. With no
- forms, returns NIL."
+ "PROGN form*
+
+Evaluates each FORM in order, returning the values of the last form. With no
+forms, returns NIL."
(ir1-convert-progn-body start next result forms))
(def-ir1-translator if ((test then &optional else) start next result)
#!+sb-doc
- "If Predicate Then [Else]
- If Predicate evaluates to non-null, evaluate Then and returns its values,
- otherwise evaluate Else and return its values. Else defaults to NIL."
+ "IF predicate then [else]
+
+If PREDICATE evaluates to true, evaluate THEN and return its values,
+otherwise evaluate ELSE and return its values. ELSE defaults to NIL."
(let* ((pred-ctran (make-ctran))
(pred-lvar (make-lvar))
- (then-ctran (make-ctran))
- (then-block (ctran-starts-block then-ctran))
- (else-ctran (make-ctran))
- (else-block (ctran-starts-block else-ctran))
- (node (make-if :test pred-lvar
- :consequent then-block
- :alternative else-block)))
+ (then-ctran (make-ctran))
+ (then-block (ctran-starts-block then-ctran))
+ (else-ctran (make-ctran))
+ (else-block (ctran-starts-block else-ctran))
+ (maybe-instrument *instrument-if-for-code-coverage*)
+ (*instrument-if-for-code-coverage* t)
+ (node (make-if :test pred-lvar
+ :consequent then-block
+ :alternative else-block)))
;; IR1-CONVERT-MAYBE-PREDICATE requires DEST to be CIF, so the
;; order of the following two forms is important
(setf (lvar-dest pred-lvar) node)
- (ir1-convert start pred-ctran pred-lvar test)
+ (multiple-value-bind (context count) (possible-rest-arg-context test)
+ (if context
+ (ir1-convert start pred-ctran pred-lvar `(%rest-true ,test ,context ,count))
+ (ir1-convert start pred-ctran pred-lvar test)))
(link-node-to-previous-ctran node pred-ctran)
(let ((start-block (ctran-block pred-ctran)))
(link-blocks start-block then-block)
(link-blocks start-block else-block))
- (ir1-convert then-ctran next result then)
- (ir1-convert else-ctran next result else)))
+ (let ((path (best-sub-source-path test)))
+ (ir1-convert (if (and path maybe-instrument)
+ (let ((*current-path* path))
+ (instrument-coverage then-ctran :then test))
+ then-ctran)
+ next result then)
+ (ir1-convert (if (and path maybe-instrument)
+ (let ((*current-path* path))
+ (instrument-coverage else-ctran :else test))
+ else-ctran)
+ next result else))))
+
+;;; To get even remotely sensible results for branch coverage
+;;; tracking, we need good source paths. If the macroexpansions
+;;; interfere enough the TEST of the conditional doesn't actually have
+;;; an original source location (e.g. (UNLESS FOO ...) -> (IF (NOT
+;;; FOO) ...). Look through the form, and try to find some subform
+;;; that has one.
+(defun best-sub-source-path (form)
+ (if (policy *lexenv* (= store-coverage-data 0))
+ nil
+ (labels ((sub (form)
+ (or (get-source-path form)
+ (when (consp form)
+ (unless (eq 'quote (car form))
+ (somesub form)))))
+ (somesub (forms)
+ (when (consp forms)
+ (or (sub (car forms))
+ (somesub (cdr forms))))))
+ (sub form))))
\f
;;;; BLOCK and TAGBODY
;;; environment.
(def-ir1-translator block ((name &rest forms) start next result)
#!+sb-doc
- "Block Name Form*
- Evaluate the Forms as a PROGN. Within the lexical scope of the body,
- (RETURN-FROM Name Value-Form) can be used to exit the form, returning the
- result of Value-Form."
+ "BLOCK name form*
+
+Evaluate the FORMS as a PROGN. Within the lexical scope of the body,
+RETURN-FROM can be used to exit the form."
(unless (symbolp name)
(compiler-error "The block name ~S is not a symbol." name))
(start-block start)
(ctran-starts-block next)
(let* ((dummy (make-ctran))
- (entry (make-entry))
- (cleanup (make-cleanup :kind :block
- :mess-up entry)))
+ (entry (make-entry))
+ (cleanup (make-cleanup :kind :block
+ :mess-up entry)))
(push entry (lambda-entries (lexenv-lambda *lexenv*)))
(setf (entry-cleanup entry) cleanup)
(link-node-to-previous-ctran entry start)
(let* ((env-entry (list entry next result))
(*lexenv* (make-lexenv :blocks (list (cons name env-entry))
- :cleanup cleanup)))
+ :cleanup cleanup)))
(ir1-convert-progn-body dummy next result forms))))
(def-ir1-translator return-from ((name &optional value) start next result)
#!+sb-doc
- "Return-From Block-Name Value-Form
- Evaluate the Value-Form, returning its values from the lexically enclosing
- BLOCK Block-Name. This is constrained to be used only within the dynamic
- extent of the BLOCK."
+ "RETURN-FROM block-name value-form
+
+Evaluate the VALUE-FORM, returning its values from the lexically enclosing
+block BLOCK-NAME. This is constrained to be used only within the dynamic
+extent of the block."
;; old comment:
;; We make NEXT start a block just so that it will have a block
;; assigned. People assume that when they pass a ctran into
(declare (ignore result))
(ctran-starts-block next)
(let* ((found (or (lexenv-find name blocks)
- (compiler-error "return for unknown block: ~S" name)))
+ (compiler-error "return for unknown block: ~S" name)))
(exit-ctran (second found))
- (value-ctran (make-ctran))
+ (value-ctran (make-ctran))
(value-lvar (make-lvar))
- (entry (first found))
- (exit (make-exit :entry entry
- :value value-lvar)))
+ (entry (first found))
+ (exit (make-exit :entry entry
+ :value value-lvar)))
(when (ctran-deleted-p exit-ctran)
(throw 'locall-already-let-converted exit-ctran))
(push exit (entry-exits entry))
(link-node-to-previous-ctran exit value-ctran)
(let ((home-lambda (ctran-home-lambda-or-null start)))
(when home-lambda
- (push entry (lambda-calls-or-closes home-lambda))))
+ (sset-adjoin entry (lambda-calls-or-closes home-lambda))))
(use-continuation exit exit-ctran (third found))))
;;; Return a list of the segments of a TAGBODY. Each segment looks
;;; like (<tag> <form>* (go <next tag>)). That is, we break up the
;;; tagbody into segments of non-tag statements, and explicitly
;;; represent the drop-through with a GO. The first segment has a
-;;; dummy NIL tag, since it represents code before the first tag. The
+;;; dummy NIL tag, since it represents code before the first tag. Note
+;;; however that NIL may appear as the tag of an inner segment. The
;;; last segment (which may also be the first segment) ends in NIL
;;; rather than a GO.
(defun parse-tagbody (body)
(declare (list body))
- (collect ((segments))
- (let ((current (cons nil body)))
+ (collect ((tags)
+ (segments))
+ (let ((current body))
(loop
- (let ((tag-pos (position-if (complement #'listp) current :start 1)))
- (unless tag-pos
- (segments `(,@current nil))
- (return))
- (let ((tag (elt current tag-pos)))
- (when (assoc tag (segments))
- (compiler-error
- "The tag ~S appears more than once in the tagbody."
- tag))
- (unless (or (symbolp tag) (integerp tag))
- (compiler-error "~S is not a legal tagbody statement." tag))
- (segments `(,@(subseq current 0 tag-pos) (go ,tag))))
- (setq current (nthcdr tag-pos current)))))
- (segments)))
+ (let ((next-segment (member-if #'atom current)))
+ (unless next-segment
+ (segments `(,@current nil))
+ (return))
+ (let ((tag (car next-segment)))
+ (when (member tag (tags))
+ (compiler-error
+ "The tag ~S appears more than once in a tagbody."
+ tag))
+ (unless (or (symbolp tag) (integerp tag))
+ (compiler-error "~S is not a legal go tag." tag))
+ (tags tag)
+ (segments `(,@(ldiff current next-segment) (go ,tag))))
+ (setq current (rest next-segment))))
+ (mapcar #'cons (cons nil (tags)) (segments)))))
;;; Set up the cleanup, emitting the entry node. Then make a block for
;;; each tag, building up the tag list for LEXENV-TAGS as we go.
;;; values.
(def-ir1-translator tagbody ((&rest statements) start next result)
#!+sb-doc
- "Tagbody {Tag | Statement}*
- Define tags for used with GO. The Statements are evaluated in order
- (skipping Tags) and NIL is returned. If a statement contains a GO to a
- defined Tag within the lexical scope of the form, then control is transferred
- to the next statement following that tag. A Tag must an integer or a
- symbol. A statement must be a list. Other objects are illegal within the
- body."
+ "TAGBODY {tag | statement}*
+
+Define tags for use with GO. The STATEMENTS are evaluated in order, skipping
+TAGS, and NIL is returned. If a statement contains a GO to a defined TAG
+within the lexical scope of the form, then control is transferred to the next
+statement following that tag. A TAG must be an integer or a symbol. A
+STATEMENT must be a list. Other objects are illegal within the body."
(start-block start)
(ctran-starts-block next)
(let* ((dummy (make-ctran))
- (entry (make-entry))
- (segments (parse-tagbody statements))
- (cleanup (make-cleanup :kind :tagbody
- :mess-up entry)))
+ (entry (make-entry))
+ (segments (parse-tagbody statements))
+ (cleanup (make-cleanup :kind :tagbody
+ :mess-up entry)))
(push entry (lambda-entries (lexenv-lambda *lexenv*)))
(setf (entry-cleanup entry) cleanup)
(link-node-to-previous-ctran entry start)
(use-ctran entry dummy)
(collect ((tags)
- (starts)
- (ctrans))
+ (starts)
+ (ctrans))
(starts dummy)
(dolist (segment (rest segments))
- (let* ((tag-ctran (make-ctran))
+ (let* ((tag-ctran (make-ctran))
(tag (list (car segment) entry tag-ctran)))
- (ctrans tag-ctran)
- (starts tag-ctran)
- (ctran-starts-block tag-ctran)
+ (ctrans tag-ctran)
+ (starts tag-ctran)
+ (ctran-starts-block tag-ctran)
(tags tag)))
(ctrans next)
(let ((*lexenv* (make-lexenv :cleanup cleanup :tags (tags))))
- (mapc (lambda (segment start end)
- (ir1-convert-progn-body start end
+ (mapc (lambda (segment start end)
+ (ir1-convert-progn-body start end
(when (eq end next) result)
(rest segment)))
- segments (starts) (ctrans))))))
+ segments (starts) (ctrans))))))
;;; Emit an EXIT node without any value.
(def-ir1-translator go ((tag) start next result)
#!+sb-doc
- "Go Tag
- Transfer control to the named Tag in the lexically enclosing TAGBODY. This
- is constrained to be used only within the dynamic extent of the TAGBODY."
+ "GO tag
+
+Transfer control to the named TAG in the lexically enclosing TAGBODY. This is
+constrained to be used only within the dynamic extent of the TAGBODY."
(ctran-starts-block next)
(let* ((found (or (lexenv-find tag tags :test #'eql)
- (compiler-error "attempt to GO to nonexistent tag: ~S"
- tag)))
- (entry (first found))
- (exit (make-exit :entry entry)))
+ (compiler-error "attempt to GO to nonexistent tag: ~S"
+ tag)))
+ (entry (first found))
+ (exit (make-exit :entry entry)))
(push exit (entry-exits entry))
(link-node-to-previous-ctran exit start)
(let ((home-lambda (ctran-home-lambda-or-null start)))
(when home-lambda
- (push entry (lambda-calls-or-closes home-lambda))))
+ (sset-adjoin entry (lambda-calls-or-closes home-lambda))))
(use-ctran exit (second found))))
\f
;;;; translators for compiler-magic special forms
;;; form; otherwise, the forms in the body are ignored.
(def-ir1-translator eval-when ((situations &rest forms) start next result)
#!+sb-doc
- "EVAL-WHEN (Situation*) Form*
- Evaluate the Forms in the specified Situations (any of :COMPILE-TOPLEVEL,
- :LOAD-TOPLEVEL, or :EXECUTE, or (deprecated) COMPILE, LOAD, or EVAL)."
+ "EVAL-WHEN (situation*) form*
+
+Evaluate the FORMS in the specified SITUATIONS (any of :COMPILE-TOPLEVEL,
+:LOAD-TOPLEVEL, or :EXECUTE, or (deprecated) COMPILE, LOAD, or EVAL)."
(multiple-value-bind (ct lt e) (parse-eval-when-situations situations)
(declare (ignore ct lt))
(ir1-convert-progn-body start next result (and e forms)))
;;; in-lexenv representation, stuff the results into *LEXENV*, and
;;; call FUN (with no arguments).
(defun %funcall-in-foomacrolet-lexenv (definitionize-fun
- definitionize-keyword
- definitions
- fun)
+ definitionize-keyword
+ definitions
+ fun)
(declare (type function definitionize-fun fun))
(declare (type (member :vars :funs) definitionize-keyword))
(declare (type list definitions))
;;; EVAL can likewise make use of it.
(defun macrolet-definitionize-fun (context lexenv)
(flet ((fail (control &rest args)
- (ecase context
- (:compile (apply #'compiler-error control args))
- (:eval (error 'simple-program-error
+ (ecase context
+ (:compile (apply #'compiler-error control args))
+ (:eval (error 'simple-program-error
:format-control control
:format-arguments args)))))
(lambda (definition)
(destructuring-bind (name arglist &body body) definition
(unless (symbolp name)
(fail "The local macro name ~S is not a symbol." name))
- (when (fboundp name)
- (compiler-assert-symbol-home-package-unlocked
- name "binding ~A as a local macro"))
+ (when (fboundp name)
+ (program-assert-symbol-home-package-unlocked
+ context name "binding ~A as a local macro"))
(unless (listp arglist)
(fail "The local macro argument list ~S is not a list."
arglist))
(def-ir1-translator macrolet ((definitions &rest body) start next result)
#!+sb-doc
- "MACROLET ({(Name Lambda-List Form*)}*) Body-Form*
- Evaluate the Body-Forms in an environment with the specified local macros
- defined. Name is the local macro name, Lambda-List is the DEFMACRO style
- destructuring lambda list, and the Forms evaluate to the expansion.."
+ "MACROLET ({(name lambda-list form*)}*) body-form*
+
+Evaluate the BODY-FORMS in an environment with the specified local macros
+defined. NAME is the local macro name, LAMBDA-LIST is a DEFMACRO style
+destructuring lambda list, and the FORMS evaluate to the expansion."
(funcall-in-macrolet-lexenv
definitions
(lambda (&key funs)
(defun symbol-macrolet-definitionize-fun (context)
(flet ((fail (control &rest args)
- (ecase context
- (:compile (apply #'compiler-error control args))
- (:eval (error 'simple-program-error
+ (ecase context
+ (:compile (apply #'compiler-error control args))
+ (:eval (error 'simple-program-error
:format-control control
:format-arguments args)))))
(lambda (definition)
(destructuring-bind (name expansion) definition
(unless (symbolp name)
(fail "The local symbol macro name ~S is not a symbol." name))
- (when (or (boundp name) (eq (info :variable :kind name) :macro))
- (compiler-assert-symbol-home-package-unlocked
- name "binding ~A as a local symbol-macro"))
+ (when (or (boundp name) (eq (info :variable :kind name) :macro))
+ (program-assert-symbol-home-package-unlocked
+ context name "binding ~A as a local symbol-macro"))
(let ((kind (info :variable :kind name)))
- (when (member kind '(:special :constant))
+ (when (member kind '(:special :constant :global))
(fail "Attempt to bind a ~(~A~) variable with SYMBOL-MACROLET: ~S"
kind name)))
- ;; A magical cons that MACROEXPAND-1 understands.
+ ;; A magical cons that MACROEXPAND-1 understands.
`(,name . (macro . ,expansion))))))
(defun funcall-in-symbol-macrolet-lexenv (definitions fun context)
(def-ir1-translator symbol-macrolet
((macrobindings &body body) start next result)
#!+sb-doc
- "SYMBOL-MACROLET ({(Name Expansion)}*) Decl* Form*
- Define the Names as symbol macros with the given Expansions. Within the
- body, references to a Name will effectively be replaced with the Expansion."
+ "SYMBOL-MACROLET ({(name expansion)}*) decl* form*
+
+Define the NAMES as symbol macros with the given EXPANSIONS. Within the
+body, references to a NAME will effectively be replaced with the EXPANSION."
(funcall-in-symbol-macrolet-lexenv
macrobindings
(lambda (&key vars)
(handler-case (mapcar #'eval args)
(error (condition)
(compiler-error "Lisp error during evaluation of info args:~%~A"
- condition))))
+ condition))))
;;; Convert to the %%PRIMITIVE funny function. The first argument is
;;; the template, the second is a list of the results of any
(def-ir1-translator %primitive ((name &rest args) start next result)
(declare (type symbol name))
(let* ((template (or (gethash name *backend-template-names*)
- (bug "undefined primitive ~A" name)))
- (required (length (template-arg-types template)))
- (info (template-info-arg-count template))
- (min (+ required info))
- (nargs (length args)))
+ (bug "undefined primitive ~A" name)))
+ (required (length (template-arg-types template)))
+ (info (template-info-arg-count template))
+ (min (+ required info))
+ (nargs (length args)))
(if (template-more-args-type template)
- (when (< nargs min)
- (bug "Primitive ~A was called with ~R argument~:P, ~
+ (when (< nargs min)
+ (bug "Primitive ~A was called with ~R argument~:P, ~
but wants at least ~R."
- name
- nargs
- min))
- (unless (= nargs min)
- (bug "Primitive ~A was called with ~R argument~:P, ~
+ name
+ nargs
+ min))
+ (unless (= nargs min)
+ (bug "Primitive ~A was called with ~R argument~:P, ~
but wants exactly ~R."
- name
- nargs
- min)))
+ name
+ nargs
+ min)))
- (when (eq (template-result-types template) :conditional)
+ (when (template-conditional-p template)
(bug "%PRIMITIVE was used with a conditional template."))
(when (template-more-results-type template)
(bug "%PRIMITIVE was used with an unknown values template."))
(ir1-convert start next result
- `(%%primitive ',template
- ',(eval-info-args
- (subseq args required min))
- ,@(subseq args 0 required)
- ,@(subseq args min)))))
+ `(%%primitive ',template
+ ',(eval-info-args
+ (subseq args required min))
+ ,@(subseq args 0 required)
+ ,@(subseq args min)))))
\f
;;;; QUOTE
(def-ir1-translator quote ((thing) start next result)
#!+sb-doc
- "QUOTE Value
- Return Value without evaluating it."
+ "QUOTE value
+
+Return VALUE without evaluating it."
(reference-constant start next result thing))
\f
+(defun name-context ()
+ ;; Name of the outermost non-NIL BLOCK, or the source namestring
+ ;; of the source file.
+ (let ((context
+ (or (car (find-if (lambda (b)
+ (let ((name (pop b)))
+ (and name
+ ;; KLUDGE: High debug adds this block on
+ ;; some platforms.
+ #!-unwind-to-frame-and-call-vop
+ (neq 'return-value-tag name)
+ ;; KLUDGE: CATCH produces blocks whose
+ ;; cleanup is :CATCH.
+ (neq :catch (cleanup-kind (entry-cleanup (pop b)))))))
+ (lexenv-blocks *lexenv*) :from-end t))
+ *source-namestring*
+ (let ((p (or *compile-file-truename* *load-truename*)))
+ (when p (namestring p))))))
+ (when context
+ (list :in context))))
+
;;;; FUNCTION and NAMED-LAMBDA
(defun name-lambdalike (thing)
- (ecase (car thing)
+ (case (car thing)
((named-lambda)
- (second thing))
- ((lambda instance-lambda)
- `(lambda ,(second thing)))
- ((lambda-with-lexenv)'
- `(lambda ,(fifth thing)))))
+ (or (second thing)
+ `(lambda ,(third thing) ,(name-context))))
+ ((lambda)
+ `(lambda ,(second thing) ,@(name-context)))
+ ((lambda-with-lexenv)
+ ;; FIXME: Get the original DEFUN name here.
+ `(lambda ,(fifth thing)))
+ (otherwise
+ (compiler-error "Not a valid lambda expression:~% ~S"
+ thing))))
(defun fun-name-leaf (thing)
(if (consp thing)
(cond
- ((member (car thing)
- '(lambda named-lambda instance-lambda lambda-with-lexenv))
- (values (ir1-convert-lambdalike
+ ((member (car thing)
+ '(lambda named-lambda lambda-with-lexenv))
+ (values (ir1-convert-lambdalike
thing
:debug-name (name-lambdalike thing))
t))
- ((legal-fun-name-p thing)
- (values (find-lexically-apparent-fun
+ ((legal-fun-name-p thing)
+ (values (find-lexically-apparent-fun
thing "as the argument to FUNCTION")
nil))
- (t
- (compiler-error "~S is not a legal function name." thing)))
+ (t
+ (compiler-error "~S is not a legal function name." thing)))
(values (find-lexically-apparent-fun
thing "as the argument to FUNCTION")
nil)))
(dolist (lambda lambdas)
(setf (functional-allocator lambda) allocator)))))
-(defmacro with-fun-name-leaf ((leaf thing start) &body body)
- `(multiple-value-bind (,leaf allocate-p) (fun-name-leaf ,thing)
+(defmacro with-fun-name-leaf ((leaf thing start &key global-function) &body body)
+ `(multiple-value-bind (,leaf allocate-p)
+ (if ,global-function
+ (find-global-fun ,thing t)
+ (fun-name-leaf ,thing))
(if allocate-p
- (let ((.new-start. (make-ctran)))
- (ir1-convert ,start .new-start. nil `(%%allocate-closures ,leaf))
- (let ((,start .new-start.))
- ,@body))
- (locally
- ,@body))))
+ (let ((.new-start. (make-ctran)))
+ (ir1-convert ,start .new-start. nil `(%%allocate-closures ,leaf))
+ (let ((,start .new-start.))
+ ,@body))
+ (locally
+ ,@body))))
(def-ir1-translator function ((thing) start next result)
#!+sb-doc
- "FUNCTION Name
- Return the lexically apparent definition of the function Name. Name may also
- be a lambda expression."
+ "FUNCTION name
+
+Return the lexically apparent definition of the function NAME. NAME may also
+be a lambda expression."
(with-fun-name-leaf (leaf thing start)
(reference-leaf start next result leaf)))
+
+;;; Like FUNCTION, but ignores local definitions and inline
+;;; expansions, and doesn't nag about undefined functions.
+;;; Used for optimizing things like (FUNCALL 'FOO).
+(def-ir1-translator global-function ((thing) start next result)
+ (with-fun-name-leaf (leaf thing start :global-function t)
+ (reference-leaf start next result leaf)))
+
+(defun constant-global-fun-name (thing)
+ (let ((constantp (sb!xc:constantp thing)))
+ (when constantp
+ (let ((name (constant-form-value thing)))
+ (when (legal-fun-name-p name)
+ name)))))
+
+(defun lvar-constant-global-fun-name (lvar)
+ (when (constant-lvar-p lvar)
+ (let ((name (lvar-value lvar)))
+ (when (legal-fun-name-p name)
+ name))))
+
+(defun ensure-source-fun-form (source &optional give-up)
+ (let ((op (when (consp source) (car source))))
+ (cond ((eq op '%coerce-callable-to-fun)
+ (ensure-source-fun-form (second source)))
+ ((member op '(function global-function lambda named-lambda))
+ (values source nil))
+ (t
+ (let ((cname (constant-global-fun-name source)))
+ (if cname
+ (values `(global-function ,cname) nil)
+ (values `(%coerce-callable-to-fun ,source) give-up)))))))
+
+(defun ensure-lvar-fun-form (lvar lvar-name &optional give-up)
+ (aver (and lvar-name (symbolp lvar-name)))
+ (if (csubtypep (lvar-type lvar) (specifier-type 'function))
+ lvar-name
+ (let ((cname (lvar-constant-global-fun-name lvar)))
+ (cond (cname
+ `(global-function ,cname))
+ (give-up
+ (give-up-ir1-transform "not known to be a function"))
+ (t
+ `(%coerce-callable-to-fun ,lvar-name))))))
\f
;;;; FUNCALL
(deftransform funcall ((function &rest args) * *)
(let ((arg-names (make-gensym-list (length args))))
`(lambda (function ,@arg-names)
- (%funcall ,(if (csubtypep (lvar-type function)
- (specifier-type 'function))
- 'function
- '(%coerce-callable-to-fun function))
- ,@arg-names))))
+ (declare (ignorable function))
+ `(%funcall ,(ensure-lvar-fun-form function 'function) ,@arg-names))))
(def-ir1-translator %funcall ((function &rest args) start next result)
- (if (and (consp function) (eq (car function) 'function))
- (with-fun-name-leaf (leaf (second function) start)
- (ir1-convert start next result `(,leaf ,@args)))
- (let ((ctran (make-ctran))
- (fun-lvar (make-lvar)))
- (ir1-convert start ctran fun-lvar `(the function ,function))
- (ir1-convert-combination-args fun-lvar ctran next result args))))
+ ;; MACROEXPAND so that (LAMBDA ...) forms arriving here don't get an
+ ;; extra cast inserted for them.
+ (let* ((function (%macroexpand function *lexenv*))
+ (op (when (consp function) (car function))))
+ (cond ((eq op 'function)
+ (compiler-destructuring-bind (thing) (cdr function)
+ function
+ (with-fun-name-leaf (leaf thing start)
+ (ir1-convert start next result `(,leaf ,@args)))))
+ ((eq op 'global-function)
+ (compiler-destructuring-bind (thing) (cdr function)
+ global-function
+ (with-fun-name-leaf (leaf thing start :global-function t)
+ (ir1-convert start next result `(,leaf ,@args)))))
+ (t
+ (let ((ctran (make-ctran))
+ (fun-lvar (make-lvar)))
+ (ir1-convert start ctran fun-lvar `(the function ,function))
+ (ir1-convert-combination-args fun-lvar ctran next result args))))))
;;; This source transform exists to reduce the amount of work for the
;;; compiler. If the called function is a FUNCTION form, then convert
;;; directly to %FUNCALL, instead of waiting around for type
;;; inference.
(define-source-transform funcall (function &rest args)
- (if (and (consp function) (eq (car function) 'function))
- `(%funcall ,function ,@args)
- (values nil t)))
+ `(%funcall ,(ensure-source-fun-form function) ,@args))
-(deftransform %coerce-callable-to-fun ((thing) (function) *)
+(deftransform %coerce-callable-to-fun ((thing) * * :node node)
"optimize away possible call to FDEFINITION at runtime"
- 'thing)
+ (ensure-lvar-fun-form thing 'thing t))
+
+(define-source-transform %coerce-callable-to-fun (thing)
+ (ensure-source-fun-form thing t))
\f
;;;; LET and LET*
;;;;
;;; variables are marked as such. Context is the name of the form, for
;;; error reporting purposes.
(declaim (ftype (function (list symbol) (values list list))
- extract-let-vars))
+ extract-let-vars))
(defun extract-let-vars (bindings context)
(collect ((vars)
- (vals)
- (names))
+ (vals)
+ (names))
(flet ((get-var (name)
- (varify-lambda-arg name
- (if (eq context 'let*)
- nil
- (names)))))
+ (varify-lambda-arg name
+ (if (eq context 'let*)
+ nil
+ (names))
+ context)))
(dolist (spec bindings)
- (cond ((atom spec)
- (let ((var (get-var spec)))
- (vars var)
- (names spec)
- (vals nil)))
- (t
- (unless (proper-list-of-length-p spec 1 2)
- (compiler-error "The ~S binding spec ~S is malformed."
- context
- spec))
- (let* ((name (first spec))
- (var (get-var name)))
- (vars var)
- (names name)
- (vals (second spec)))))))
+ (cond ((atom spec)
+ (let ((var (get-var spec)))
+ (vars var)
+ (names spec)
+ (vals nil)))
+ (t
+ (unless (proper-list-of-length-p spec 1 2)
+ (compiler-error "The ~S binding spec ~S is malformed."
+ context
+ spec))
+ (let* ((name (first spec))
+ (var (get-var name)))
+ (vars var)
+ (names name)
+ (vals (second spec)))))))
(dolist (name (names))
(when (eq (info :variable :kind name) :macro)
- (compiler-assert-symbol-home-package-unlocked
- name "lexically binding symbol-macro ~A")))
+ (program-assert-symbol-home-package-unlocked
+ :compile name "lexically binding symbol-macro ~A")))
(values (vars) (vals))))
(def-ir1-translator let ((bindings &body body) start next result)
#!+sb-doc
- "LET ({(Var [Value]) | Var}*) Declaration* Form*
- During evaluation of the Forms, bind the Vars to the result of evaluating the
- Value forms. The variables are bound in parallel after all of the Values are
- evaluated."
+ "LET ({(var [value]) | var}*) declaration* form*
+
+During evaluation of the FORMS, bind the VARS to the result of evaluating the
+VALUE forms. The variables are bound in parallel after all of the VALUES forms
+have been evaluated."
(cond ((null bindings)
(ir1-translate-locally body start next result))
((listp bindings)
(fun-lvar (make-lvar))
((next result)
(processing-decls (decls vars nil next result
- post-binding-lexenv)
+ post-binding-lexenv)
(let ((fun (ir1-convert-lambda-body
forms
vars
- :post-binding-lexenv post-binding-lexenv
+ :post-binding-lexenv post-binding-lexenv
:debug-name (debug-name 'let bindings))))
(reference-leaf start ctran fun-lvar fun))
(values next result))))
(compiler-error "Malformed LET bindings: ~S." bindings))))
(def-ir1-translator let* ((bindings &body body)
- start next result)
+ start next result)
#!+sb-doc
- "LET* ({(Var [Value]) | Var}*) Declaration* Form*
- Similar to LET, but the variables are bound sequentially, allowing each Value
- form to reference any of the previous Vars."
+ "LET* ({(var [value]) | var}*) declaration* form*
+
+Similar to LET, but the variables are bound sequentially, allowing each VALUE
+form to reference any of the previous VARS."
(if (listp bindings)
(multiple-value-bind (forms decls)
(parse-body body :doc-string-allowed nil)
(multiple-value-bind (vars values) (extract-let-vars bindings 'let*)
- (processing-decls (decls vars nil start next post-binding-lexenv)
+ (processing-decls (decls vars nil next result post-binding-lexenv)
(ir1-convert-aux-bindings start
next
result
forms
vars
values
- post-binding-lexenv))))
+ post-binding-lexenv))))
(compiler-error "Malformed LET* bindings: ~S." bindings)))
;;; logic shared between IR1 translators for LOCALLY, MACROLET,
(def-ir1-translator locally ((&body body) start next result)
#!+sb-doc
- "LOCALLY Declaration* Form*
- Sequentially evaluate the Forms in a lexical environment where the
- the Declarations have effect. If LOCALLY is a top level form, then
- the Forms are also processed as top level forms."
+ "LOCALLY declaration* form*
+
+Sequentially evaluate the FORMS in a lexical environment where the
+DECLARATIONS have effect. If LOCALLY is a top level form, then the FORMS are
+also processed as top level forms."
(ir1-translate-locally body start next result))
\f
;;;; FLET and LABELS
(declaim (ftype (function (list symbol) (values list list)) extract-flet-vars))
(defun extract-flet-vars (definitions context)
(collect ((names)
- (defs))
+ (defs))
(dolist (def definitions)
(when (or (atom def) (< (length def) 2))
- (compiler-error "The ~S definition spec ~S is malformed." context def))
+ (compiler-error "The ~S definition spec ~S is malformed." context def))
(let ((name (first def)))
- (check-fun-name name)
- (when (fboundp name)
- (compiler-assert-symbol-home-package-unlocked
- name "binding ~A as a local function"))
- (names name)
- (multiple-value-bind (forms decls) (parse-body (cddr def))
- (defs `(lambda ,(second def)
- ,@decls
- (block ,(fun-name-block-name name)
- . ,forms))))))
+ (check-fun-name name)
+ (when (fboundp name)
+ (program-assert-symbol-home-package-unlocked
+ :compile name "binding ~A as a local function"))
+ (names name)
+ (multiple-value-bind (forms decls doc) (parse-body (cddr def))
+ (defs `(lambda ,(second def)
+ ,@(when doc (list doc))
+ ,@decls
+ (block ,(fun-name-block-name name)
+ . ,forms))))))
(values (names) (defs))))
(defun ir1-convert-fbindings (start next result funs body)
(t (ir1-convert-progn-body ctran next result body)))))
(def-ir1-translator flet ((definitions &body body)
- start next result)
+ start next result)
#!+sb-doc
- "FLET ({(Name Lambda-List Declaration* Form*)}*) Declaration* Body-Form*
- Evaluate the Body-Forms with some local function definitions. The bindings
- do not enclose the definitions; any use of Name in the Forms will refer to
- the lexically apparent function definition in the enclosing environment."
+ "FLET ({(name lambda-list declaration* form*)}*) declaration* body-form*
+
+Evaluate the BODY-FORMS with local function definitions. The bindings do
+not enclose the definitions; any use of NAME in the FORMS will refer to the
+lexically apparent function definition in the enclosing environment."
(multiple-value-bind (forms decls)
(parse-body body :doc-string-allowed nil)
(multiple-value-bind (names defs)
(extract-flet-vars definitions 'flet)
(let ((fvars (mapcar (lambda (n d)
- (ir1-convert-lambda d
- :source-name n
- :debug-name (debug-name 'flet n)))
+ (ir1-convert-lambda
+ d :source-name n
+ :maybe-add-debug-catch t
+ :debug-name
+ (debug-name 'flet n t)))
names defs)))
(processing-decls (decls nil fvars next result)
(let ((*lexenv* (make-lexenv :funs (pairlis names fvars))))
(def-ir1-translator labels ((definitions &body body) start next result)
#!+sb-doc
- "LABELS ({(Name Lambda-List Declaration* Form*)}*) Declaration* Body-Form*
- Evaluate the Body-Forms with some local function definitions. The bindings
- enclose the new definitions, so the defined functions can call themselves or
- each other."
+ "LABELS ({(name lambda-list declaration* form*)}*) declaration* body-form*
+
+Evaluate the BODY-FORMS with local function definitions. The bindings enclose
+the new definitions, so the defined functions can call themselves or each
+other."
(multiple-value-bind (forms decls) (parse-body body :doc-string-allowed nil)
(multiple-value-bind (names defs)
(extract-flet-vars definitions 'labels)
(placeholder-funs (mapcar (lambda (name)
(make-functional
:%source-name name
- :%debug-name (debug-name
- 'labels-placeholder
+ :%debug-name (debug-name
+ 'labels-placeholder
name)))
names))
;; (like PAIRLIS but guaranteed to preserve ordering:)
(mapcar (lambda (name def)
(ir1-convert-lambda def
:source-name name
- :debug-name (debug-name 'labels name)))
+ :maybe-add-debug-catch t
+ :debug-name (debug-name 'labels name t)))
names defs))))
;; Modify all the references to the dummy function leaves so
(values-subtypep (make-single-value-type (leaf-type value))
type))
(and (sb!xc:constantp value)
+ (or (not (values-type-p type))
+ (values-type-may-be-single-value-p type))
(ctypep (constant-form-value value)
(single-value-type type))))
(ir1-convert start next result value))
;;; Assert that FORM evaluates to the specified type (which may be a
;;; VALUES type). TYPE may be a type specifier or (as a hack) a CTYPE.
-(def-ir1-translator the ((type value) start next result)
- (the-in-policy type value (lexenv-policy *lexenv*) start next result))
+(def-ir1-translator the ((value-type form) start next result)
+ #!+sb-doc
+ "Specifies that the values returned by FORM conform to the VALUE-TYPE.
+
+CLHS specifies that the consequences are undefined if any result is
+not of the declared type, but SBCL treats declarations as assertions
+as long as SAFETY is at least 2, in which case incorrect type
+information will result in a runtime type-error instead of leading to
+eg. heap corruption. This is however expressly non-portable: use
+CHECK-TYPE instead of THE to catch type-errors at runtime. THE is best
+considered an optimization tool to inform the compiler about types it
+is unable to derive from other declared types."
+ (the-in-policy value-type form (lexenv-policy *lexenv*) start next result))
;;; This is like the THE special form, except that it believes
;;; whatever you tell it. It will never generate a type check, but
;;; will cause a warning if the compiler can prove the assertion is
;;; wrong.
-(def-ir1-translator truly-the ((type value) start next result)
+;;;
+;;; For the benefit of code-walkers we also add a macro-expansion. (Using INFO
+;;; directly to get around safeguards for adding a macro-expansion for special
+;;; operator.) Because :FUNCTION :KIND remains :SPECIAL-FORM, the compiler
+;;; never uses the macro -- but manually calling its MACRO-FUNCTION or
+;;; MACROEXPANDing TRULY-THE forms does.
+(def-ir1-translator truly-the ((value-type form) start next result)
#!+sb-doc
- ""
- #-nil
- (let ((type (coerce-to-values (compiler-values-specifier-type type)))
- (old (when result (find-uses result))))
- (ir1-convert start next result value)
- (when result
- (do-uses (use result)
- (unless (memq use old)
- (derive-node-type use type)))))
- #+nil
- (the-in-policy type value '((type-check . 0)) start cont))
+ "Specifies that the values returned by FORM conform to the
+VALUE-TYPE, and causes the compiler to trust this information
+unconditionally.
+
+Consequences are undefined if any result is not of the declared type
+-- typical symptoms including memory corruptions. Use with great
+care."
+ (the-in-policy value-type form '((type-check . 0)) start next result))
+
+#-sb-xc-host
+(setf (info :function :macro-function 'truly-the)
+ (lambda (whole env)
+ (declare (ignore env))
+ `(the ,@(cdr whole))))
\f
;;;; SETQ
(when (oddp len)
(compiler-error "odd number of args to SETQ: ~S" source))
(if (= len 2)
- (let* ((name (first things))
- (leaf (or (lexenv-find name vars)
- (find-free-var name))))
- (etypecase leaf
- (leaf
- (when (constant-p leaf)
- (compiler-error "~S is a constant and thus can't be set." name))
- (when (lambda-var-p leaf)
- (let ((home-lambda (ctran-home-lambda-or-null start)))
- (when home-lambda
- (pushnew leaf (lambda-calls-or-closes home-lambda))))
- (when (lambda-var-ignorep leaf)
- ;; ANSI's definition of "Declaration IGNORE, IGNORABLE"
- ;; requires that this be a STYLE-WARNING, not a full warning.
- (compiler-style-warn
- "~S is being set even though it was declared to be ignored."
- name)))
- (setq-var start next result leaf (second things)))
- (cons
- (aver (eq (car leaf) 'macro))
+ (let* ((name (first things))
+ (value-form (second things))
+ (leaf (or (lexenv-find name vars) (find-free-var name))))
+ (etypecase leaf
+ (leaf
+ (when (constant-p leaf)
+ (compiler-error "~S is a constant and thus can't be set." name))
+ (when (lambda-var-p leaf)
+ (let ((home-lambda (ctran-home-lambda-or-null start)))
+ (when home-lambda
+ (sset-adjoin leaf (lambda-calls-or-closes home-lambda))))
+ (when (lambda-var-ignorep leaf)
+ ;; ANSI's definition of "Declaration IGNORE, IGNORABLE"
+ ;; requires that this be a STYLE-WARNING, not a full warning.
+ (compiler-style-warn
+ "~S is being set even though it was declared to be ignored."
+ name)))
+ (if (and (global-var-p leaf) (eq :unknown (global-var-kind leaf)))
+ ;; For undefined variables go through SET, so that we can catch
+ ;; constant modifications.
+ (ir1-convert start next result `(set ',name ,value-form))
+ (setq-var start next result leaf value-form)))
+ (cons
+ (aver (eq (car leaf) 'macro))
;; FIXME: [Free] type declaration. -- APD, 2002-01-26
- (ir1-convert start next result
+ (ir1-convert start next result
`(setf ,(cdr leaf) ,(second things))))
- (heap-alien-info
- (ir1-convert start next result
- `(%set-heap-alien ',leaf ,(second things))))))
- (collect ((sets))
- (do ((thing things (cddr thing)))
- ((endp thing)
- (ir1-convert-progn-body start next result (sets)))
- (sets `(setq ,(first thing) ,(second thing))))))))
+ (heap-alien-info
+ (ir1-convert start next result
+ `(%set-heap-alien ',leaf ,(second things))))))
+ (collect ((sets))
+ (do ((thing things (cddr thing)))
+ ((endp thing)
+ (ir1-convert-progn-body start next result (sets)))
+ (sets `(setq ,(first thing) ,(second thing))))))))
;;; This is kind of like REFERENCE-LEAF, but we generate a SET node.
;;; This should only need to be called in SETQ.
(dest-lvar (make-lvar))
(type (or (lexenv-find var type-restrictions)
(leaf-type var))))
- (ir1-convert start dest-ctran dest-lvar `(the ,type ,value))
+ (ir1-convert start dest-ctran dest-lvar `(the ,(type-specifier type)
+ ,value))
(let ((res (make-set :var var :value dest-lvar)))
(setf (lvar-dest dest-lvar) res)
(setf (leaf-ever-used var) t)
;;; properties other than receiving multiple-values.
(def-ir1-translator throw ((tag result) start next result-lvar)
#!+sb-doc
- "Throw Tag Form
- Do a non-local exit, return the values of Form from the CATCH whose tag
- evaluates to the same thing as Tag."
+ "THROW tag form
+
+Do a non-local exit, return the values of FORM from the CATCH whose tag is EQ
+to TAG."
(ir1-convert start next result-lvar
- `(multiple-value-call #'%throw ,tag ,result)))
+ `(multiple-value-call #'%throw ,tag ,result)))
;;; This is a special special form used to instantiate a cleanup as
;;; the current cleanup within the body. KIND is the kind of cleanup
(def-ir1-translator %within-cleanup
((kind mess-up &body body) start next result)
(let ((dummy (make-ctran))
- (dummy2 (make-ctran)))
+ (dummy2 (make-ctran)))
(ir1-convert start dummy nil mess-up)
(let* ((mess-node (ctran-use dummy))
- (cleanup (make-cleanup :kind kind
- :mess-up mess-node))
- (old-cup (lexenv-cleanup *lexenv*))
- (*lexenv* (make-lexenv :cleanup cleanup)))
+ (cleanup (make-cleanup :kind kind
+ :mess-up mess-node))
+ (old-cup (lexenv-cleanup *lexenv*))
+ (*lexenv* (make-lexenv :cleanup cleanup)))
(setf (entry-cleanup (cleanup-mess-up old-cup)) cleanup)
(ir1-convert dummy dummy2 nil '(%cleanup-point))
(ir1-convert-progn-body dummy2 next result body))))
;;; function and smashes it to a :CLEANUP function, as well as
;;; referencing it.
(def-ir1-translator %cleanup-fun ((name) start next result)
+ ;; FIXME: Should this not be :TEST #'EQUAL? What happens to
+ ;; (SETF FOO) here?
(let ((fun (lexenv-find name funs)))
(aver (lambda-p fun))
(setf (functional-kind fun) :cleanup)
(def-ir1-translator catch ((tag &body body) start next result)
#!+sb-doc
- "Catch Tag Form*
- Evaluate TAG and instantiate it as a catcher while the body forms are
- evaluated in an implicit PROGN. If a THROW is done to TAG within the dynamic
- scope of the body, then control will be transferred to the end of the body
- and the thrown values will be returned."
+ "CATCH tag form*
+
+Evaluate TAG and instantiate it as a catcher while the body forms are
+evaluated in an implicit PROGN. If a THROW is done to TAG within the dynamic
+scope of the body, then control will be transferred to the end of the body and
+the thrown values will be returned."
;; We represent the possibility of the control transfer by making an
;; "escape function" that does a lexical exit, and instantiate the
;; cleanup using %WITHIN-CLEANUP.
start next result
(with-unique-names (exit-block)
`(block ,exit-block
- (%within-cleanup
- :catch (%catch (%escape-fun ,exit-block) ,tag)
- ,@body)))))
+ (%within-cleanup
+ :catch (%catch (%escape-fun ,exit-block) ,tag)
+ ,@body)))))
(def-ir1-translator unwind-protect
((protected &body cleanup) start next result)
#!+sb-doc
- "Unwind-Protect Protected Cleanup*
- Evaluate the form PROTECTED, returning its values. The CLEANUP forms are
- evaluated whenever the dynamic scope of the PROTECTED form is exited (either
- due to normal completion or a non-local exit such as THROW)."
+ "UNWIND-PROTECT protected cleanup*
+
+Evaluate the form PROTECTED, returning its values. The CLEANUP forms are
+evaluated whenever the dynamic scope of the PROTECTED form is exited (either
+due to normal completion or a non-local exit such as THROW)."
;; UNWIND-PROTECT is similar to CATCH, but hairier. We make the
;; cleanup forms into a local function so that they can be referenced
;; both in the case where we are unwound and in any local exits. We
(ir1-convert
start next result
(with-unique-names (cleanup-fun drop-thru-tag exit-tag next start count)
- `(flet ((,cleanup-fun () ,@cleanup nil))
- ;; FIXME: If we ever get DYNAMIC-EXTENT working, then
- ;; ,CLEANUP-FUN should probably be declared DYNAMIC-EXTENT,
- ;; and something can be done to make %ESCAPE-FUN have
- ;; dynamic extent too.
- (block ,drop-thru-tag
- (multiple-value-bind (,next ,start ,count)
- (block ,exit-tag
- (%within-cleanup
- :unwind-protect
- (%unwind-protect (%escape-fun ,exit-tag)
- (%cleanup-fun ,cleanup-fun))
- (return-from ,drop-thru-tag ,protected)))
- (,cleanup-fun)
- (%continue-unwind ,next ,start ,count)))))))
+ `(flet ((,cleanup-fun ()
+ ,@cleanup
+ nil))
+ ;; FIXME: If we ever get DYNAMIC-EXTENT working, then
+ ;; ,CLEANUP-FUN should probably be declared DYNAMIC-EXTENT,
+ ;; and something can be done to make %ESCAPE-FUN have
+ ;; dynamic extent too.
+ (declare (dynamic-extent #',cleanup-fun))
+ (block ,drop-thru-tag
+ (multiple-value-bind (,next ,start ,count)
+ (block ,exit-tag
+ (%within-cleanup
+ :unwind-protect
+ (%unwind-protect (%escape-fun ,exit-tag)
+ (%cleanup-fun ,cleanup-fun))
+ (return-from ,drop-thru-tag ,protected)))
+ (declare (optimize (insert-debug-catch 0)))
+ (,cleanup-fun)
+ (%continue-unwind ,next ,start ,count)))))))
\f
;;;; multiple-value stuff
(def-ir1-translator multiple-value-call ((fun &rest args) start next result)
#!+sb-doc
- "MULTIPLE-VALUE-CALL Function Values-Form*
- Call FUNCTION, passing all the values of each VALUES-FORM as arguments,
- values from the first VALUES-FORM making up the first argument, etc."
+ "MULTIPLE-VALUE-CALL function values-form*
+
+Call FUNCTION, passing all the values of each VALUES-FORM as arguments,
+values from the first VALUES-FORM making up the first argument, etc."
(let* ((ctran (make-ctran))
(fun-lvar (make-lvar))
- (node (if args
- ;; If there are arguments, MULTIPLE-VALUE-CALL
- ;; turns into an MV-COMBINATION.
- (make-mv-combination fun-lvar)
- ;; If there are no arguments, then we convert to a
- ;; normal combination, ensuring that a MV-COMBINATION
- ;; always has at least one argument. This can be
- ;; regarded as an optimization, but it is more
- ;; important for simplifying compilation of
- ;; MV-COMBINATIONS.
- (make-combination fun-lvar))))
- (ir1-convert start ctran fun-lvar
- (if (and (consp fun) (eq (car fun) 'function))
- fun
- `(%coerce-callable-to-fun ,fun)))
+ (node (if args
+ ;; If there are arguments, MULTIPLE-VALUE-CALL
+ ;; turns into an MV-COMBINATION.
+ (make-mv-combination fun-lvar)
+ ;; If there are no arguments, then we convert to a
+ ;; normal combination, ensuring that a MV-COMBINATION
+ ;; always has at least one argument. This can be
+ ;; regarded as an optimization, but it is more
+ ;; important for simplifying compilation of
+ ;; MV-COMBINATIONS.
+ (make-combination fun-lvar))))
+ (ir1-convert start ctran fun-lvar (ensure-source-fun-form fun))
(setf (lvar-dest fun-lvar) node)
(collect ((arg-lvars))
(let ((this-start ctran))
- (dolist (arg args)
- (let ((this-ctran (make-ctran))
+ (dolist (arg args)
+ (let ((this-ctran (make-ctran))
(this-lvar (make-lvar node)))
- (ir1-convert this-start this-ctran this-lvar arg)
- (setq this-start this-ctran)
- (arg-lvars this-lvar)))
- (link-node-to-previous-ctran node this-start)
- (use-continuation node next result)
- (setf (basic-combination-args node) (arg-lvars))))))
+ (ir1-convert this-start this-ctran this-lvar arg)
+ (setq this-start this-ctran)
+ (arg-lvars this-lvar)))
+ (link-node-to-previous-ctran node this-start)
+ (use-continuation node next result)
+ (setf (basic-combination-args node) (arg-lvars))))))
(def-ir1-translator multiple-value-prog1
((values-form &rest forms) start next result)
#!+sb-doc
- "MULTIPLE-VALUE-PROG1 Values-Form Form*
- Evaluate Values-Form and then the Forms, but return all the values of
- Values-Form."
+ "MULTIPLE-VALUE-PROG1 values-form form*
+
+Evaluate VALUES-FORM and then the FORMS, but return all the values of
+VALUES-FORM."
(let ((dummy (make-ctran)))
(ctran-starts-block dummy)
(ir1-convert start dummy result values-form)
((null path) *current-path*)
(let ((first (first path)))
(when (or (eq first name)
- (eq first 'original-source-start))
- (return path)))))
+ (eq first 'original-source-start))
+ (return path)))))
projects / sbcl.git / blobdiff