(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
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)))
`(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))
;;; 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 "internal error: Primitive name ~S is not a symbol." name))
+ (declare (type symbol name))
(let* ((template (or (gethash name *backend-template-names*)
- (compiler-error
- "internal error: 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 "internal 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 "internal 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)
: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)
(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)
;;; 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-fun ((thing) (function) *
- :when :both
:important t)
"optimize away possible call to FDEFINITION at runtime"
'thing)
;;;; 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 :debug-name (debug-namify "LET ~S" bindings))))
- (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)))))
;;; 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))))
;;;
;;; 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)
(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 ,(fun-name-block-name name)
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
:source-name 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)))))
(def-ir1-translator labels ((definitions &body body) start cont)
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* (;; dummy LABELS function vars, to be used during
- ;; conversion of real LABELS functions
+ (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
"LABELS placeholder ~S"
name)))
names))
- (placeholder-fenv (pairlis names placeholder-funs))
+ ;; (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 placeholder-fenv)))
- (mapcar (lambda (n d)
- (ir1-convert-lambda d
- :source-name 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" n)))
+ "LABELS ~S" name)))
names defs))))
;; 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 envpair in placeholder-fenv do
- (let ((placeholder-fun (cdr envpair)))
- (substitute-leaf real-fun placeholder-fun)
- (setf (cdr envpair) real-fun)))
+ (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
;; placeholder used earlier) so that if the
;; lexical environment is used for inline
;; expansion we'll get the right functions.
- :functions (pairlis names real-funs))))
+ :funs (pairlis names real-funs))))
(ir1-convert-progn-body start cont forms))))))
\f
;;;; the THE special operator, and friends
;;; 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 (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
;;;
;;; 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)))
;;; 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 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*)
+ (remhash name *free-funs*)
(undefine-fun-name name)
- (compiler-warning
+ (compiler-warn
"~S is being redefined as a macro when it was ~
previously ~(~A~) to be a function."
name
projects / sbcl.git / blobdiff