(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)))
: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))))
-
(def-ir1-translator return-from ((name &optional value) start cont)
#!+sb-doc
"Return-From Block-Name Value-Form
(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))))
: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)
(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))))
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
#!+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))))
;;; except that the value of NAME is passed to the compiler for use in
;;; creation of debug information for the resulting function.
;;;
-;;; Eventually we might use this for NAME values other than legal
-;;; function names, e.g.
+;;; 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 (STARSHIP T))
+;;; NAME = (:METHOD PRINT-OBJECT :AROUND (STARSHIP T))
;;; for the function used to implement
-;;; (DEFMETHOD PRINT-OBJECT ((SS STARSHIP) STREAM) ...).
-;;; However, as of this writing (while defining/implementing it in
-;;; sbcl-0.pre7.108) NAME is always a legal function name.
-;;;
-;;; 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.)
+;;; (DEFMETHOD PRINT-OBJECT :AROUND ((SS STARSHIP) STREAM) ...).
(def-ir1-translator named-lambda ((name &rest rest) start cont)
(reference-leaf start
cont
- (ir1-convert-lambda `(lambda ,@rest)
- :source-name name)))
+ (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)
(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)
+ (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)
;; the real LABELS functions, compiled in a LEXENV which
;; includes the dummy LABELS functions
(real-funs
- (let ((*lexenv* (make-lexenv
- :functions placeholder-fenv)))
+ (let ((*lexenv* (make-lexenv :funs placeholder-fenv)))
(mapcar (lambda (name def)
(ir1-convert-lambda def
:source-name name
;; 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)
(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-warning
+ (compiler-style-warn
"~S is being set even though it was declared to be ignored."
name)))
- (set-variable start cont leaf (second things)))
+ (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
;;;
;;; 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 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
+;;; 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)
`(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