(in-package "SB!C")
\f
-;;;; control special forms
+;;;; special forms for control
(def-ir1-translator progn ((&rest forms) start cont)
#!+sb-doc
:alternative else-block)))
(setf (continuation-dest pred) node)
(ir1-convert start pred test)
- (prev-link node pred)
+ (link-node-to-previous-continuation node pred)
(use-continuation node dummy-cont)
(let ((start-block (continuation-block pred)))
(continuation-starts-block cont)
(link-blocks start-block then-block)
- (link-blocks start-block else-block)
+ (link-blocks start-block else-block))
- (ir1-convert then-cont cont then)
- (ir1-convert else-cont cont else))))
+ (ir1-convert then-cont cont then)
+ (ir1-convert else-cont cont else)))
\f
;;;; BLOCK and TAGBODY
-;;;; We make an Entry node to mark the start and a :Entry cleanup to
-;;;; mark its extent. When doing GO or RETURN-FROM, we emit an Exit
+;;;; We make an ENTRY node to mark the start and a :ENTRY cleanup to
+;;;; mark its extent. When doing GO or RETURN-FROM, we emit an EXIT
;;;; node.
;;; Make a :ENTRY cleanup and emit an ENTRY node, then convert the
:mess-up entry)))
(push entry (lambda-entries (lexenv-lambda *lexenv*)))
(setf (entry-cleanup entry) cleanup)
- (prev-link entry start)
+ (link-node-to-previous-continuation entry start)
(use-continuation entry dummy)
(let* ((env-entry (list entry cont))
(push env-entry (continuation-lexenv-uses cont))
(ir1-convert-progn-body dummy cont forms))))
-
-;;; We make CONT start a block just so that it will have a block
-;;; assigned. People assume that when they pass a continuation into
-;;; IR1-CONVERT as CONT, it will have a block when it is done.
-(def-ir1-translator return-from ((name &optional value)
- start cont)
+(def-ir1-translator return-from ((name &optional value) start cont)
#!+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."
+ ;; CMU CL comment:
+ ;; We make CONT start a block just so that it will have a block
+ ;; assigned. People assume that when they pass a continuation into
+ ;; IR1-CONVERT as CONT, it will have a block when it is done.
+ ;; KLUDGE: Note that this block is basically fictitious. In the code
+ ;; (BLOCK B (RETURN-FROM B) (SETQ X 3))
+ ;; it's the block which answers the question "which block is
+ ;; the (SETQ X 3) in?" when the right answer is that (SETQ X 3) is
+ ;; dead code and so doesn't really have a block at all. The existence
+ ;; of this block, and that way that it doesn't explicitly say
+ ;; "I'm actually nowhere at all" makes some logic (e.g.
+ ;; BLOCK-HOME-LAMBDA-OR-NULL) more obscure, and it might be better
+ ;; to get rid of it, perhaps using a special placeholder value
+ ;; to indicate the orphanedness of the code.
(continuation-starts-block cont)
(let* ((found (or (lexenv-find name blocks)
(compiler-error "return for unknown block: ~S" name)))
(push exit (entry-exits entry))
(setf (continuation-dest value-cont) exit)
(ir1-convert start value-cont value)
- (prev-link exit value-cont)
+ (link-node-to-previous-continuation exit value-cont)
+ (let ((home-lambda (continuation-home-lambda-or-null start)))
+ (when home-lambda
+ (push entry (lambda-calls-or-closes home-lambda))))
(use-continuation exit (second found))))
;;; Return a list of the segments of a TAGBODY. Each segment looks
:mess-up entry)))
(push entry (lambda-entries (lexenv-lambda *lexenv*)))
(setf (entry-cleanup entry) cleanup)
- (prev-link entry start)
+ (link-node-to-previous-continuation entry start)
(use-continuation entry dummy)
(collect ((tags)
is constrained to be used only within the dynamic extent of the TAGBODY."
(continuation-starts-block cont)
(let* ((found (or (lexenv-find tag tags :test #'eql)
- (compiler-error "Go to nonexistent tag: ~S." tag)))
+ (compiler-error "attempt to GO to nonexistent tag: ~S"
+ tag)))
(entry (first found))
(exit (make-exit :entry entry)))
(push exit (entry-exits entry))
- (prev-link exit start)
+ (link-node-to-previous-continuation exit start)
+ (let ((home-lambda (continuation-home-lambda-or-null start)))
+ (when home-lambda
+ (push entry (lambda-calls-or-closes home-lambda))))
(use-continuation exit (second found))))
\f
;;;; translators for compiler-magic special forms
-;;; This handles EVAL-WHEN in non-top-level forms. (EVAL-WHENs in
-;;; top-level forms are picked off and handled by PROCESS-TOP-LEVEL-FORM,
+;;; This handles EVAL-WHEN in non-top-level forms. (EVAL-WHENs in top
+;;; level forms are picked off and handled by PROCESS-TOPLEVEL-FORM,
;;; so that they're never seen at this level.)
;;;
;;; ANSI "3.2.3.1 Processing of Top Level Forms" says that processing
definitions
fun)
(declare (type function definitionize-fun fun))
- (declare (type (member :variables :functions) definitionize-keyword))
+ (declare (type (member :vars :funs) definitionize-keyword))
(declare (type list definitions))
(unless (= (length definitions)
(length (remove-duplicates definitions :key #'first)))
- (compiler-style-warning "duplicate definitions in ~S" definitions))
+ (compiler-style-warn "duplicate definitions in ~S" definitions))
(let* ((processed-definitions (mapcar definitionize-fun definitions))
(*lexenv* (make-lexenv definitionize-keyword processed-definitions)))
(funcall fun)))
;;; call FUN (with no arguments).
;;;
;;; This is split off from the IR1 convert method so that it can be
-;;; shared by the special-case top-level MACROLET processing code.
+;;; shared by the special-case top level MACROLET processing code.
(defun funcall-in-macrolet-lexenv (definitions fun)
(%funcall-in-foomacrolet-lexenv
(lambda (definition)
`(lambda (,whole ,environment)
,@local-decls
(block ,name ,body))))))))
- :functions
+ :funs
definitions
fun))
(compiler-error
"The local symbol macro name ~S is not a symbol."
name))
+ (let ((kind (info :variable :kind name)))
+ (when (member kind '(:special :constant))
+ (compiler-error "Attempt to bind a ~(~A~) variable with SYMBOL-MACROLET: ~S" kind name)))
`(,name . (MACRO . ,expansion))))
- :variables
+ :vars
definitions
fun))
(compiler-error "Lisp error during evaluation of info args:~%~A"
condition))))
-;;; If there is a primitive translator, then we expand the call.
-;;; Otherwise, we convert to the %%PRIMITIVE funny function. The first
-;;; argument is the template, the second is a list of the results of
-;;; any codegen-info args, and the remaining arguments are the runtime
+;;; Convert to the %%PRIMITIVE funny function. The first argument is
+;;; the template, the second is a list of the results of any
+;;; codegen-info args, and the remaining arguments are the runtime
;;; arguments.
;;;
-;;; We do a bunch of error checking now so that we don't bomb out with
+;;; We do various error checking now so that we don't bomb out with
;;; a fatal error during IR2 conversion.
;;;
;;; KLUDGE: It's confusing having multiple names floating around for
;;; VOP or %VOP.. -- WHN 2001-06-11
;;; FIXME: Look at doing this ^, it doesn't look too hard actually.
(def-ir1-translator %primitive ((name &rest args) start cont)
- (unless (symbolp name)
- (compiler-error "The primitive name ~S is not a symbol." name))
-
+ (declare (type symbol name))
(let* ((template (or (gethash name *backend-template-names*)
- (compiler-error
- "The primitive name ~A is not defined."
- name)))
+ (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)
- (compiler-error "Primitive ~A was called with ~R argument~:P, ~
- but wants at least ~R."
- name
- nargs
- min))
+ (bug "Primitive ~A was called with ~R argument~:P, ~
+ but wants at least ~R."
+ name
+ nargs
+ min))
(unless (= nargs min)
- (compiler-error "Primitive ~A was called with ~R argument~:P, ~
- but wants exactly ~R."
- name
- nargs
- min)))
+ (bug "Primitive ~A was called with ~R argument~:P, ~
+ but wants exactly ~R."
+ name
+ nargs
+ min)))
(when (eq (template-result-types template) :conditional)
- (compiler-error
- "%PRIMITIVE was used with a conditional template."))
+ (bug "%PRIMITIVE was used with a conditional template."))
(when (template-more-results-type template)
- (compiler-error
- "%PRIMITIVE was used with an unknown values template."))
+ (bug "%PRIMITIVE was used with an unknown values template."))
(ir1-convert start
cont
,@(subseq args 0 required)
,@(subseq args min)))))
\f
-;;;; QUOTE and FUNCTION
+;;;; QUOTE
(def-ir1-translator quote ((thing) start cont)
#!+sb-doc
"QUOTE Value
Return Value without evaluating it."
(reference-constant start cont thing))
+\f
+;;;; FUNCTION and NAMED-LAMBDA
(def-ir1-translator function ((thing) start cont)
#!+sb-doc
"FUNCTION Name
Return the lexically apparent definition of the function Name. Name may also
- be a lambda."
+ be a lambda expression."
(if (consp thing)
(case (car thing)
((lambda)
- (reference-leaf start cont (ir1-convert-lambda thing)))
+ (reference-leaf start
+ cont
+ (ir1-convert-lambda thing
+ :debug-name (debug-namify
+ "#'~S" thing))))
((setf)
- (let ((var (find-lexically-apparent-function
+ (let ((var (find-lexically-apparent-fun
thing "as the argument to FUNCTION")))
(reference-leaf start cont var)))
((instance-lambda)
- (let ((res (ir1-convert-lambda `(lambda ,@(cdr thing)))))
+ (let ((res (ir1-convert-lambda `(lambda ,@(cdr thing))
+ :debug-name (debug-namify "#'~S"
+ thing))))
(setf (getf (functional-plist res) :fin-function) t)
(reference-leaf start cont res)))
(t
(compiler-error "~S is not a legal function name." thing)))
- (let ((var (find-lexically-apparent-function
+ (let ((var (find-lexically-apparent-fun
thing "as the argument to FUNCTION")))
(reference-leaf start cont var))))
+
+;;; `(NAMED-LAMBDA ,NAME ,@REST) is like `(FUNCTION (LAMBDA ,@REST)),
+;;; except that the value of NAME is passed to the compiler for use in
+;;; creation of debug information for the resulting function.
+;;;
+;;; NAME can be a legal function name or some arbitrary other thing.
+;;;
+;;; If NAME is a legal function name, then the caller should be
+;;; planning to set (FDEFINITION NAME) to the created function.
+;;; (Otherwise the debug names will be inconsistent and thus
+;;; unnecessarily confusing.)
+;;;
+;;; Arbitrary other things are appropriate for naming things which are
+;;; not the FDEFINITION of NAME. E.g.
+;;; NAME = (:FLET FOO BAR)
+;;; for the FLET function in
+;;; (DEFUN BAR (X)
+;;; (FLET ((FOO (Y) (+ X Y)))
+;;; FOO))
+;;; or
+;;; NAME = (:METHOD PRINT-OBJECT :AROUND (STARSHIP T))
+;;; for the function used to implement
+;;; (DEFMETHOD PRINT-OBJECT :AROUND ((SS STARSHIP) STREAM) ...).
+(def-ir1-translator named-lambda ((name &rest rest) start cont)
+ (reference-leaf start
+ cont
+ (if (legal-fun-name-p name)
+ (ir1-convert-lambda `(lambda ,@rest)
+ :source-name name)
+ (ir1-convert-lambda `(lambda ,@rest)
+ :debug-name name))))
\f
;;;; FUNCALL
;;; FUNCALL is implemented on %FUNCALL, which can only call functions
;;; (not symbols). %FUNCALL is used directly in some places where the
;;; call should always be open-coded even if FUNCALL is :NOTINLINE.
-(deftransform funcall ((function &rest args) * * :when :both)
+(deftransform funcall ((function &rest args) * *)
(let ((arg-names (make-gensym-list (length args))))
`(lambda (function ,@arg-names)
(%funcall ,(if (csubtypep (continuation-type function)
(specifier-type 'function))
'function
- '(%coerce-callable-to-function function))
+ '(%coerce-callable-to-fun function))
,@arg-names))))
(def-ir1-translator %funcall ((function &rest args) start cont)
;;; compiler. If the called function is a FUNCTION form, then convert
;;; directly to %FUNCALL, instead of waiting around for type
;;; inference.
-(def-source-transform funcall (function &rest args)
+(define-source-transform funcall (function &rest args)
(if (and (consp function) (eq (car function) 'function))
`(%funcall ,function ,@args)
(values nil t)))
-(deftransform %coerce-callable-to-function ((thing) (function) *
- :when :both
- :important t)
+(deftransform %coerce-callable-to-fun ((thing) (function) *
+ :important t)
"optimize away possible call to FDEFINITION at runtime"
'thing)
\f
;;;; any pervasive declarations also affect the evaluation of the
;;;; arguments.)
-;;; Given a list of binding specifiers in the style of Let, return:
+;;; Given a list of binding specifiers in the style of LET, return:
;;; 1. The list of var structures for the variables bound.
;;; 2. The initial value form for each variable.
;;;
;;; The variable names are checked for legality and globally special
;;; variables are marked as such. Context is the name of the form, for
;;; error reporting purposes.
-(declaim (ftype (function (list symbol) (values list list list))
- extract-let-variables))
-(defun extract-let-variables (bindings context)
+(declaim (ftype (function (list symbol) (values list list))
+ extract-let-vars))
+(defun extract-let-vars (bindings context)
(collect ((vars)
(vals)
(names))
(cond ((atom spec)
(let ((var (get-var spec)))
(vars var)
- (names (cons spec var))
+ (names spec)
(vals nil)))
(t
(unless (proper-list-of-length-p spec 1 2)
(names name)
(vals (second spec)))))))
- (values (vars) (vals) (names))))
+ (values (vars) (vals))))
(def-ir1-translator let ((bindings &body body)
start cont)
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."
- (multiple-value-bind (forms decls) (sb!sys:parse-body body nil)
- (multiple-value-bind (vars values) (extract-let-variables bindings 'let)
- (let* ((*lexenv* (process-decls decls vars nil cont))
- (fun-cont (make-continuation))
- (fun (ir1-convert-lambda-body forms vars)))
- (reference-leaf start fun-cont fun)
- (ir1-convert-combination-args fun-cont cont values)))))
+ (multiple-value-bind (forms decls) (parse-body body nil)
+ (multiple-value-bind (vars values) (extract-let-vars bindings 'let)
+ (let ((fun-cont (make-continuation)))
+ (let* ((*lexenv* (process-decls decls vars nil cont))
+ (fun (ir1-convert-lambda-body
+ forms vars
+ :debug-name (debug-namify "LET ~S" bindings))))
+ (reference-leaf start fun-cont fun))
+ (ir1-convert-combination-args fun-cont cont values)))))
(def-ir1-translator let* ((bindings &body body)
start cont)
"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."
- (multiple-value-bind (forms decls) (sb!sys:parse-body body nil)
- (multiple-value-bind (vars values) (extract-let-variables bindings 'let*)
+ (multiple-value-bind (forms decls) (parse-body body nil)
+ (multiple-value-bind (vars values) (extract-let-vars bindings 'let*)
(let ((*lexenv* (process-decls decls vars nil cont)))
(ir1-convert-aux-bindings start cont forms vars values)))))
;;; logic shared between IR1 translators for LOCALLY, MACROLET,
;;; and SYMBOL-MACROLET
;;;
-;;; Note that all these things need to preserve top-level-formness,
+;;; Note that all these things need to preserve toplevel-formness,
;;; but we don't need to worry about that within an IR1 translator,
-;;; since top-level-formness is picked off by PROCESS-TOP-LEVEL-FOO
+;;; since toplevel-formness is picked off by PROCESS-TOPLEVEL-FOO
;;; forms before we hit the IR1 transform level.
(defun ir1-translate-locally (body start cont)
(declare (type list body) (type continuation start cont))
- (multiple-value-bind (forms decls) (sb!sys:parse-body body nil)
+ (multiple-value-bind (forms decls) (parse-body body nil)
(let ((*lexenv* (process-decls decls nil nil cont)))
(ir1-convert-aux-bindings start cont forms nil nil))))
#!+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."
+ 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 cont))
\f
;;;; FLET and LABELS
;;;
;;; The function names are checked for legality. CONTEXT is the name
;;; of the form, for error reporting.
-(declaim (ftype (function (list symbol) (values list list))
- extract-flet-variables))
-(defun extract-flet-variables (definitions context)
+(declaim (ftype (function (list symbol) (values list list)) extract-flet-vars))
+(defun extract-flet-vars (definitions context)
(collect ((names)
(defs))
(dolist (def definitions)
(when (or (atom def) (< (length def) 2))
(compiler-error "The ~S definition spec ~S is malformed." context def))
- (let ((name (check-function-name (first def))))
+ (let ((name (first def)))
+ (check-fun-name name)
(names name)
- (multiple-value-bind (forms decls) (sb!sys:parse-body (cddr def))
+ (multiple-value-bind (forms decls) (parse-body (cddr def))
(defs `(lambda ,(second def)
,@decls
- (block ,(function-name-block-name name)
+ (block ,(fun-name-block-name name)
. ,forms))))))
(values (names) (defs))))
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."
- (multiple-value-bind (forms decls) (sb!sys:parse-body body nil)
+ (multiple-value-bind (forms decls) (parse-body body nil)
(multiple-value-bind (names defs)
- (extract-flet-variables definitions 'flet)
+ (extract-flet-vars definitions 'flet)
(let* ((fvars (mapcar (lambda (n d)
- (ir1-convert-lambda d n))
+ (ir1-convert-lambda d
+ :source-name n
+ :debug-name (debug-namify
+ "FLET ~S" n)))
names defs))
(*lexenv* (make-lexenv
:default (process-decls decls nil fvars cont)
- :functions (pairlis names fvars))))
+ :funs (pairlis names fvars))))
(ir1-convert-progn-body start cont forms)))))
-;;; For LABELS, we have to create dummy function vars and add them to
-;;; the function namespace while converting the functions. We then
-;;; modify all the references to these leaves so that they point to
-;;; the real functional leaves. We also backpatch the FENV so that if
-;;; the lexical environment is used for inline expansion we will get
-;;; the right functions.
(def-ir1-translator labels ((definitions &body body) start cont)
#!+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."
- (multiple-value-bind (forms decls) (sb!sys:parse-body body nil)
+ (multiple-value-bind (forms decls) (parse-body body nil)
(multiple-value-bind (names defs)
- (extract-flet-variables definitions 'labels)
- (let* ((new-fenv (loop for name in names
- collect (cons name (make-functional :name name))))
+ (extract-flet-vars definitions 'labels)
+ (let* (;; dummy LABELS functions, to be used as placeholders
+ ;; during construction of real LABELS functions
+ (placeholder-funs (mapcar (lambda (name)
+ (make-functional
+ :%source-name name
+ :%debug-name (debug-namify
+ "LABELS placeholder ~S"
+ name)))
+ names))
+ ;; (like PAIRLIS but guaranteed to preserve ordering:)
+ (placeholder-fenv (mapcar #'cons names placeholder-funs))
+ ;; the real LABELS functions, compiled in a LEXENV which
+ ;; includes the dummy LABELS functions
(real-funs
- (let ((*lexenv* (make-lexenv :functions new-fenv)))
- (mapcar (lambda (n d)
- (ir1-convert-lambda d n))
+ (let ((*lexenv* (make-lexenv :funs placeholder-fenv)))
+ (mapcar (lambda (name def)
+ (ir1-convert-lambda def
+ :source-name name
+ :debug-name (debug-namify
+ "LABELS ~S" name)))
names defs))))
- (loop for real in real-funs and env in new-fenv do
- (let ((dum (cdr env)))
- (substitute-leaf real dum)
- (setf (cdr env) real)))
+ ;; Modify all the references to the dummy function leaves so
+ ;; that they point to the real function leaves.
+ (loop for real-fun in real-funs and
+ placeholder-cons in placeholder-fenv do
+ (substitute-leaf real-fun (cdr placeholder-cons))
+ (setf (cdr placeholder-cons) real-fun))
+ ;; Voila.
(let ((*lexenv* (make-lexenv
:default (process-decls decls nil real-funs cont)
- :functions (pairlis names real-funs))))
+ ;; Use a proper FENV here (not the
+ ;; placeholder used earlier) so that if the
+ ;; lexical environment is used for inline
+ ;; expansion we'll get the right functions.
+ :funs (pairlis names real-funs))))
(ir1-convert-progn-body start cont forms))))))
\f
-;;;; THE
+;;;; the THE special operator, and friends
;;; Do stuff to recognize a THE or VALUES declaration. CONT is the
;;; continuation that the assertion applies to, TYPE is the type
-;;; specifier and Lexenv is the current lexical environment. NAME is
+;;; specifier and LEXENV is the current lexical environment. NAME is
;;; the name of the declaration we are doing, for use in error
;;; messages.
;;;
;;; This is somewhat involved, since a type assertion may only be made
;;; on a continuation, not on a node. We can't just set the
;;; continuation asserted type and let it go at that, since there may
-;;; be parallel THE's for the same continuation, i.e.:
+;;; be parallel THE's for the same continuation, i.e.
;;; (if ...
;;; (the foo ...)
;;; (the bar ...))
;;; We make this work by getting USE-CONTINUATION to do the unioning
;;; across COND branches. We can't do it here, since we don't know how
;;; many branches there are going to be.
-(defun do-the-stuff (type cont lexenv name)
+(defun ir1ize-the-or-values (type cont lexenv place)
(declare (type continuation cont) (type lexenv lexenv))
- (let* ((ctype (values-specifier-type type))
+ (let* ((ctype (if (typep type 'ctype) type (values-specifier-type type)))
(old-type (or (lexenv-find cont type-restrictions)
*wild-type*))
(intersects (values-types-equal-or-intersect old-type ctype))
(when (null (find-uses cont))
(setf (continuation-asserted-type cont) new))
(when (and (not intersects)
+ ;; FIXME: Is it really right to look at *LEXENV* here,
+ ;; instead of looking at the LEXENV argument? Why?
(not (policy *lexenv*
(= inhibit-warnings 3)))) ;FIXME: really OK to suppress?
- (compiler-warning
- "The type ~S in ~S declaration conflicts with an enclosing assertion:~% ~S"
+ (compiler-warn
+ "The type ~S ~A conflicts with an ~
+ enclosing assertion:~% ~S"
(type-specifier ctype)
- name
+ place
(type-specifier old-type)))
(make-lexenv :type-restrictions `((,cont . ,new))
:default lexenv)))
;;; this didn't seem to expand into an assertion, at least for ALIEN
;;; values. Check that SBCL doesn't have this problem.
(def-ir1-translator the ((type value) start cont)
- (let ((*lexenv* (do-the-stuff type cont *lexenv* 'the)))
+ (with-continuation-type-assertion (cont (values-specifier-type type)
+ "in THE declaration")
(ir1-convert start cont value)))
;;; This is like the THE special form, except that it believes
\f
;;;; SETQ
-;;; If there is a definition in LEXENV-VARIABLES, just set that,
-;;; otherwise look at the global information. If the name is for a
-;;; constant, then error out.
+;;; If there is a definition in LEXENV-VARS, just set that, otherwise
+;;; look at the global information. If the name is for a constant,
+;;; then error out.
(def-ir1-translator setq ((&whole source &rest things) start cont)
(let ((len (length things)))
(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 variables)
- (find-free-variable name))))
+ (leaf (or (lexenv-find name vars)
+ (find-free-var name))))
(etypecase leaf
(leaf
- (when (or (constant-p leaf)
- (and (global-var-p leaf)
- (eq (global-var-kind leaf) :constant)))
+ (when (constant-p leaf)
(compiler-error "~S is a constant and thus can't be set." name))
- (when (and (lambda-var-p leaf)
- (lambda-var-ignorep leaf))
- ;; ANSI's definition of "Declaration IGNORE, IGNORABLE"
- ;; requires that this be a STYLE-WARNING, not a full warning.
- (compiler-style-warning
- "~S is being set even though it was declared to be ignored."
- name))
- (set-variable start cont leaf (second things)))
+ (when (lambda-var-p leaf)
+ (let ((home-lambda (continuation-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 cont leaf (second things)))
(cons
(aver (eq (car leaf) 'MACRO))
(ir1-convert start cont `(setf ,(cdr leaf) ,(second things))))
;;; This is kind of like REFERENCE-LEAF, but we generate a SET node.
;;; This should only need to be called in SETQ.
-(defun set-variable (start cont var value)
+(defun setq-var (start cont var value)
(declare (type continuation start cont) (type basic-var var))
(let ((dest (make-continuation)))
(setf (continuation-asserted-type dest) (leaf-type var))
(setf (continuation-dest dest) res)
(setf (leaf-ever-used var) t)
(push res (basic-var-sets var))
- (prev-link res dest)
+ (link-node-to-previous-continuation res dest)
(use-continuation res cont))))
\f
;;;; CATCH, THROW and UNWIND-PROTECT
`(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 a the kind of cleanup
+;;; the current cleanup within the body. KIND is the kind of cleanup
;;; to make, and MESS-UP is a form that does the mess-up action. We
;;; make the MESS-UP be the USE of the MESS-UP form's continuation,
;;; and introduce the cleanup into the lexical environment. We
;;; This is a special special form that makes an "escape function"
;;; which returns unknown values from named block. We convert the
;;; function, set its kind to :ESCAPE, and then reference it. The
-;;; :Escape kind indicates that this function's purpose is to
+;;; :ESCAPE kind indicates that this function's purpose is to
;;; represent a non-local control transfer, and that it might not
;;; actually have to be compiled.
;;;
;;; Note that environment analysis replaces references to escape
;;; functions with references to the corresponding NLX-INFO structure.
-(def-ir1-translator %escape-function ((tag) start cont)
+(def-ir1-translator %escape-fun ((tag) start cont)
(let ((fun (ir1-convert-lambda
`(lambda ()
- (return-from ,tag (%unknown-values))))))
+ (return-from ,tag (%unknown-values)))
+ :debug-name (debug-namify "escape function for ~S" tag))))
(setf (functional-kind fun) :escape)
(reference-leaf start cont fun)))
;;; Yet another special special form. This one looks up a local
;;; function and smashes it to a :CLEANUP function, as well as
;;; referencing it.
-(def-ir1-translator %cleanup-function ((name) start cont)
- (let ((fun (lexenv-find name functions)))
+(def-ir1-translator %cleanup-fun ((name) start cont)
+ (let ((fun (lexenv-find name funs)))
(aver (lambda-p fun))
(setf (functional-kind fun) :cleanup)
(reference-leaf start cont fun)))
`(block ,exit-block
(%within-cleanup
:catch
- (%catch (%escape-function ,exit-block) ,tag)
+ (%catch (%escape-fun ,exit-block) ,tag)
,@body)))))
-;;; UNWIND-PROTECT is similar to CATCH, but more hairy. We make the
+;;; 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
-;;; use %CLEANUP-FUNCTION on this to indicate that reference by
-;;; %UNWIND-PROTECT ISN'T "real", and thus doesn't cause creation of
+;;; use %CLEANUP-FUN on this to indicate that reference by
+;;; %UNWIND-PROTECT isn't "real", and thus doesn't cause creation of
;;; an XEP.
(def-ir1-translator unwind-protect ((protected &body cleanup) start cont)
#!+sb-doc
`(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-FUNCTION have
+ ;; 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-function ,exit-tag)
- (%cleanup-function ,cleanup-fun))
+ (%unwind-protect (%escape-fun ,exit-tag)
+ (%cleanup-fun ,cleanup-fun))
(return-from ,drop-thru-tag ,protected)))
(,cleanup-fun)
(%continue-unwind ,next ,start ,count)))))))
(ir1-convert start fun-cont
(if (and (consp fun) (eq (car fun) 'function))
fun
- `(%coerce-callable-to-function ,fun)))
+ `(%coerce-callable-to-fun ,fun)))
(setf (continuation-dest fun-cont) node)
(assert-continuation-type fun-cont
(specifier-type '(or function symbol)))
(ir1-convert this-start this-cont arg)
(setq this-start this-cont)
(arg-conts this-cont)))
- (prev-link node this-start)
+ (link-node-to-previous-continuation node this-start)
(use-continuation node cont)
(setf (basic-combination-args node) (arg-conts))))))
(continuation-starts-block dummy-start)
(ir1-convert start dummy-start result)
- (substitute-continuation-uses cont dummy-start)
+ (with-continuation-type-assertion
+ (cont (continuation-asserted-type dummy-start)
+ "of the first form")
+ (substitute-continuation-uses cont dummy-start))
(continuation-starts-block dummy-result)
(ir1-convert-progn-body dummy-start dummy-result forms)
(ecase (info :function :kind name)
((nil))
(:function
- (remhash name *free-functions*)
- (undefine-function-name name)
- (compiler-warning
+ (remhash name *free-funs*)
+ (undefine-fun-name name)
+ (compiler-warn
"~S is being redefined as a macro when it was ~
previously ~(~A~) to be a function."
name
(info :function :macro-function name) (coerce def 'function))
(let* ((*current-path* (revert-source-path 'defmacro))
- (fun (ir1-convert-lambda def name)))
- (setf (leaf-name fun)
- (concatenate 'string "DEFMACRO " (symbol-name name)))
+ (fun (ir1-convert-lambda def
+ :debug-name (debug-namify "DEFMACRO ~S"
+ name))))
(setf (functional-arg-documentation fun) (eval lambda-list))
(ir1-convert start cont `(%%defmacro ',name ,fun ,doc)))
(coerce def 'function))
(let* ((*current-path* (revert-source-path 'define-compiler-macro))
- (fun (ir1-convert-lambda def name)))
- (setf (leaf-name fun)
- (let ((*print-case* :upcase))
- (format nil "DEFINE-COMPILER-MACRO ~S" name)))
+ (fun (ir1-convert-lambda def
+ :debug-name (debug-namify
+ "DEFINE-COMPILER-MACRO ~S"
+ name))))
(setf (functional-arg-documentation fun) (eval lambda-list))
(ir1-convert start cont `(%%define-compiler-macro ',name ,fun ,doc)))
projects / sbcl.git / blobdiff