(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 false, 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))
+ (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)))
(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 (gethash form *source-paths*)
+ (and (consp form)
+ (some #'sub form)))))
+ (or (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)
(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
(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 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))
;;; 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"
(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)))
(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"))
+ (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)
(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"))
+ (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))
(fail "Attempt to bind a ~(~A~) variable with SYMBOL-MACROLET: ~S"
(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)
(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
;;;; FUNCTION and NAMED-LAMBDA
(second thing))
((lambda instance-lambda)
`(lambda ,(second thing)))
- ((lambda-with-lexenv)'
+ ((lambda-with-lexenv)
`(lambda ,(fifth thing)))))
(defun fun-name-leaf (thing)
(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)))
;;; 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))
+ (if (and (consp function) (member (car function) '(function lambda)))
`(%funcall ,function ,@args)
(let ((name (constant-global-fun-name function)))
(if name
(deftransform %coerce-callable-to-fun ((thing) (function) *)
"optimize away possible call to FDEFINITION at runtime"
'thing)
+
+(define-source-transform %coerce-callable-to-fun (thing)
+ (if (and (consp thing) (member (car thing) '(function lambda)))
+ thing
+ (values nil t)))
\f
;;;; LET and LET*
;;;;
(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)
(def-ir1-translator let* ((bindings &body body)
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
(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 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
(let ((name (first def)))
(check-fun-name name)
(when (fboundp name)
- (compiler-assert-symbol-home-package-unlocked
- name "binding ~A as a local function"))
+ (program-assert-symbol-home-package-unlocked
+ :compile name "binding ~A as a local function"))
(names name)
(multiple-value-bind (forms decls) (parse-body (cddr def))
(defs `(lambda ,(second def)
(def-ir1-translator flet ((definitions &body body)
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)
(let ((fvars (mapcar (lambda (n d)
(ir1-convert-lambda d
:source-name n
+ :maybe-add-debug-catch t
:debug-name (debug-name 'flet n)))
names defs)))
(processing-decls (decls nil fvars next result)
(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)
(mapcar (lambda (name def)
(ir1-convert-lambda def
:source-name name
+ :maybe-add-debug-catch t
:debug-name (debug-name 'labels name)))
names defs))))
(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))))
+ (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.
;;; 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)))
;;; 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.
(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))
+ `(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
(%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
(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
(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)
projects / sbcl.git / blobdiff