(in-package "SB!C")
\f
-;;;; control special forms
+;;;; special forms for control
(def-ir1-translator progn ((&rest forms) start cont)
#!+sb-doc
(node (make-if :test pred
:consequent then-block
:alternative else-block)))
+ ;; IR1-CONVERT-MAYBE-PREDICATE requires DEST to be CIF, so the
+ ;; order of the following two forms is important
(setf (continuation-dest pred) node)
(ir1-convert start pred test)
(link-node-to-previous-continuation node pred)
(setf (entry-cleanup entry) cleanup)
(link-node-to-previous-continuation entry start)
(use-continuation entry dummy)
-
+
(let* ((env-entry (list entry cont))
(*lexenv* (make-lexenv :blocks (list (cons name env-entry))
:cleanup cleanup)))
(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
(starts dummy)
(dolist (segment (rest segments))
(let* ((tag-cont (make-continuation))
- (tag (list (car segment) entry tag-cont)))
+ (tag (list (car segment) entry tag-cont)))
(conts tag-cont)
(starts tag-cont)
(continuation-starts-block tag-cont)
;;; are ignored for non-top-level forms. For non-top-level forms, an
;;; eval-when specifying the :EXECUTE situation is treated as an
;;; implicit PROGN including the forms in the body of the EVAL-WHEN
-;;; form; otherwise, the forms in the body are ignored.
+;;; form; otherwise, the forms in the body are ignored.
(def-ir1-translator eval-when ((situations &rest forms) start cont)
#!+sb-doc
"EVAL-WHEN (Situation*) Form*
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-warn "duplicate definitions in ~S" definitions))
(let* ((processed-definitions (mapcar definitionize-fun definitions))
(*lexenv* (make-lexenv definitionize-keyword processed-definitions)))
- (funcall fun)))
+ (funcall fun definitionize-keyword processed-definitions)))
-;;; Tweak *LEXENV* to include the DEFINITIONS from a MACROLET, then
+;;; Tweak LEXENV to include the DEFINITIONS from a MACROLET, then
;;; 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.
-(defun funcall-in-macrolet-lexenv (definitions fun)
+;;; shared by the special-case top level MACROLET processing code, and
+;;; further split so that the special-case MACROLET processing code in
+;;; EVAL can likewise make use of it.
+(defun macrolet-definitionize-fun (context lexenv)
+ (flet ((fail (control &rest args)
+ (ecase context
+ (:compile (apply #'compiler-error control args))
+ (:eval (error 'simple-program-error
+ :format-control control
+ :format-arguments args)))))
+ (lambda (definition)
+ (unless (list-of-length-at-least-p definition 2)
+ (fail "The list ~S is too short to be a legal local macro definition."
+ definition))
+ (destructuring-bind (name arglist &body body) definition
+ (unless (symbolp name)
+ (fail "The local macro name ~S is not a symbol." name))
+ (unless (listp arglist)
+ (fail "The local macro argument list ~S is not a list."
+ arglist))
+ (with-unique-names (whole environment)
+ (multiple-value-bind (body local-decls)
+ (parse-defmacro arglist whole body name 'macrolet
+ :environment environment)
+ `(,name macro .
+ ,(compile-in-lexenv
+ nil
+ `(lambda (,whole ,environment)
+ ,@local-decls
+ ,body)
+ lexenv))))))))
+
+(defun funcall-in-macrolet-lexenv (definitions fun context)
(%funcall-in-foomacrolet-lexenv
- (lambda (definition)
- (unless (list-of-length-at-least-p definition 2)
- (compiler-error
- "The list ~S is too short to be a legal local macro definition."
- definition))
- (destructuring-bind (name arglist &body body) definition
- (unless (symbolp name)
- (compiler-error "The local macro name ~S is not a symbol." name))
- (let ((whole (gensym "WHOLE"))
- (environment (gensym "ENVIRONMENT")))
- (multiple-value-bind (body local-decls)
- (parse-defmacro arglist whole body name 'macrolet
- :environment environment)
- `(,name macro .
- ,(compile nil
- `(lambda (,whole ,environment)
- ,@local-decls
- (block ,name ,body))))))))
- :functions
+ (macrolet-definitionize-fun context (make-restricted-lexenv *lexenv*))
+ :funs
definitions
fun))
"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. The
- Forms are evaluated in the null environment."
- (funcall-in-macrolet-lexenv definitions
- (lambda ()
- (ir1-translate-locally body start cont))))
-
-(defun funcall-in-symbol-macrolet-lexenv (definitions fun)
+ destructuring lambda list, and the Forms evaluate to the expansion.."
+ (funcall-in-macrolet-lexenv
+ definitions
+ (lambda (&key funs)
+ (declare (ignore funs))
+ (ir1-translate-locally body start cont))
+ :compile))
+
+(defun symbol-macrolet-definitionize-fun (context)
+ (flet ((fail (control &rest args)
+ (ecase context
+ (:compile (apply #'compiler-error control args))
+ (:eval (error 'simple-program-error
+ :format-control control
+ :format-arguments args)))))
+ (lambda (definition)
+ (unless (proper-list-of-length-p definition 2)
+ (fail "malformed symbol/expansion pair: ~S" definition))
+ (destructuring-bind (name expansion) definition
+ (unless (symbolp name)
+ (fail "The local symbol macro name ~S is not a symbol." name))
+ (let ((kind (info :variable :kind name)))
+ (when (member kind '(:special :constant))
+ (fail "Attempt to bind a ~(~A~) variable with SYMBOL-MACROLET: ~S"
+ kind name)))
+ `(,name . (MACRO . ,expansion))))))
+
+(defun funcall-in-symbol-macrolet-lexenv (definitions fun context)
(%funcall-in-foomacrolet-lexenv
- (lambda (definition)
- (unless (proper-list-of-length-p definition 2)
- (compiler-error "malformed symbol/expansion pair: ~S" definition))
- (destructuring-bind (name expansion) definition
- (unless (symbolp name)
- (compiler-error
- "The local symbol macro name ~S is not a symbol."
- name))
- `(,name . (MACRO . ,expansion))))
- :variables
+ (symbol-macrolet-definitionize-fun context)
+ :vars
definitions
fun))
-
+
(def-ir1-translator symbol-macrolet ((macrobindings &body body) start cont)
#!+sb-doc
"SYMBOL-MACROLET ({(Name Expansion)}*) Decl* Form*
body, references to a Name will effectively be replaced with the Expansion."
(funcall-in-symbol-macrolet-lexenv
macrobindings
- (lambda ()
- (ir1-translate-locally body start cont))))
-
-;;; not really a special form, but..
-(def-ir1-translator declare ((&rest stuff) start cont)
- (declare (ignore stuff))
- ;; We ignore START and CONT too, but we can't use DECLARE IGNORE to
- ;; tell the compiler about it here, because the DEF-IR1-TRANSLATOR
- ;; macro would put the DECLARE in the wrong place, so..
- start cont
- (compiler-error "misplaced declaration"))
+ (lambda (&key vars)
+ (ir1-translate-locally body start cont :vars vars))
+ :compile))
\f
;;;; %PRIMITIVE
;;;;
;;; 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
(reference-constant start cont thing))
\f
;;;; FUNCTION and NAMED-LAMBDA
+(defun fun-name-leaf (thing)
+ (if (consp thing)
+ (cond
+ ((member (car thing)
+ '(lambda named-lambda instance-lambda lambda-with-lexenv))
+ (ir1-convert-lambdalike
+ thing
+ :debug-name (debug-namify "#'~S" thing)
+ :allow-debug-catch-tag t))
+ ((legal-fun-name-p thing)
+ (find-lexically-apparent-fun
+ thing "as the argument to FUNCTION"))
+ (t
+ (compiler-error "~S is not a legal function name." thing)))
+ (find-lexically-apparent-fun
+ thing "as the argument to FUNCTION")))
(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 expression."
- (if (consp thing)
- (case (car thing)
- ((lambda)
- (reference-leaf start
- cont
- (ir1-convert-lambda thing
- :debug-name (debug-namify
- "#'~S" thing))))
- ((setf)
- (let ((var (find-lexically-apparent-function
- thing "as the argument to FUNCTION")))
- (reference-leaf start cont var)))
- ((instance-lambda)
- (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
- 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.
-;;;
-;;; Eventually we might use this for NAME values other than legal
-;;; function names, 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))
-;;; 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.)
-(def-ir1-translator named-lambda ((name &rest rest) start cont)
- (reference-leaf start
- cont
- (ir1-convert-lambda `(lambda ,@rest)
- :source-name name)))
+ (reference-leaf start cont (fun-name-leaf thing)))
\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)
,@arg-names))))
(def-ir1-translator %funcall ((function &rest args) start cont)
- (let ((fun-cont (make-continuation)))
- (ir1-convert start fun-cont function)
- (assert-continuation-type fun-cont (specifier-type 'function))
- (ir1-convert-combination-args fun-cont cont args)))
+ (if (and (consp function) (eq (car function) 'function))
+ (ir1-convert start cont `(,(fun-name-leaf (second function)) ,@args))
+ (let ((fun-cont (make-continuation)))
+ (ir1-convert start fun-cont `(the function ,function))
+ (ir1-convert-combination-args fun-cont cont args))))
;;; This source transform exists to reduce the amount of work for the
;;; compiler. If the called function is a FUNCTION form, then convert
(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)
+(def-ir1-translator let ((bindings &body body) start cont)
#!+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."
- (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)))))
+ (if (null bindings)
+ (ir1-translate-locally body start cont)
+ (multiple-value-bind (forms decls)
+ (parse-body body :doc-string-allowed nil)
+ (multiple-value-bind (vars values) (extract-let-vars bindings 'let)
+ (let* ((fun-cont (make-continuation))
+ (cont (processing-decls (decls vars nil cont)
+ (let ((fun (ir1-convert-lambda-body
+ forms vars
+ :debug-name (debug-namify "LET ~S"
+ bindings))))
+ (reference-leaf start fun-cont fun))
+ cont)))
+ (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*)
- (let ((*lexenv* (process-decls decls vars nil cont)))
- (ir1-convert-aux-bindings start cont forms vars values)))))
+ (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 cont)
+ (ir1-convert-aux-bindings start cont forms vars values)))))
;;; logic shared between IR1 translators for LOCALLY, MACROLET,
;;; and SYMBOL-MACROLET
;;; but we don't need to worry about that within an IR1 translator,
;;; 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)
+(defun ir1-translate-locally (body start cont &key vars funs)
(declare (type list body) (type continuation start cont))
- (multiple-value-bind (forms decls) (sb!sys:parse-body body nil)
- (let ((*lexenv* (process-decls decls nil nil cont)))
- (ir1-convert-aux-bindings start cont forms nil nil))))
+ (multiple-value-bind (forms decls) (parse-body body :doc-string-allowed nil)
+ (processing-decls (decls vars funs cont)
+ (ir1-convert-progn-body start cont forms))))
(def-ir1-translator locally ((&body body) start cont)
#!+sb-doc
;;;
;;; 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 :doc-string-allowed nil)
(multiple-value-bind (names defs)
- (extract-flet-variables definitions 'flet)
- (let* ((fvars (mapcar (lambda (n d)
- (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))))
- (ir1-convert-progn-body start cont forms)))))
+ (extract-flet-vars definitions 'flet)
+ (let ((fvars (mapcar (lambda (n d)
+ (ir1-convert-lambda d
+ :source-name n
+ :debug-name (debug-namify
+ "FLET ~S" n)
+ :allow-debug-catch-tag t))
+ names defs)))
+ (processing-decls (decls nil fvars cont)
+ (let ((*lexenv* (make-lexenv :funs (pairlis names fvars))))
+ (ir1-convert-progn-body start cont forms)))))))
(def-ir1-translator labels ((definitions &body body) start cont)
#!+sb-doc
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 :doc-string-allowed nil)
(multiple-value-bind (names defs)
- (extract-flet-variables definitions 'labels)
- (let* (;; dummy LABELS functions, to be used as placeholders
+ (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
;; 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
:debug-name (debug-namify
- "LABELS ~S" name)))
+ "LABELS ~S" name)
+ :allow-debug-catch-tag t))
names defs))))
;; Modify all the references to the dummy function leaves so
(setf (cdr placeholder-cons) real-fun))
;; Voila.
- (let ((*lexenv* (make-lexenv
- :default (process-decls decls nil real-funs cont)
- ;; 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.
- :functions (pairlis names real-funs))))
- (ir1-convert-progn-body start cont forms))))))
+ (processing-decls (decls nil real-funs cont)
+ (let ((*lexenv* (make-lexenv
+ ;; 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 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
-;;; 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.
-;;; (if ...
-;;; (the foo ...)
-;;; (the bar ...))
-;;;
-;;; In this case, our representation can do no better than the union
-;;; of these assertions. And if there is a branch with no assertion,
-;;; we have nothing at all. We really need to recognize scoping, since
-;;; we need to be able to discern between parallel assertions (which
-;;; we union) and nested ones (which we intersect).
-;;;
-;;; We represent the scoping by throwing our innermost (intersected)
-;;; assertion on CONT into the TYPE-RESTRICTIONS. As we go down, we
-;;; intersect our assertions together. If CONT has no uses yet, we
-;;; have not yet bottomed out on the first COND branch; in this case
-;;; we optimistically assume that this type will be the one we end up
-;;; with, and set the ASSERTED-TYPE to it. We can never get better
-;;; than the type that we have the first time we bottom out. Later
-;;; THE's (or the absence thereof) can only weaken this result.
-;;;
-;;; 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)
- (declare (type continuation cont) (type lexenv lexenv))
- (let* ((ctype (values-specifier-type type))
- (old-type (or (lexenv-find cont type-restrictions)
- *wild-type*))
- (intersects (values-types-equal-or-intersect old-type ctype))
- (int (values-type-intersection old-type ctype))
- (new (if intersects int old-type)))
- (when (null (find-uses cont))
- (setf (continuation-asserted-type cont) new))
- (when (and (not intersects)
- (not (policy *lexenv*
- (= inhibit-warnings 3)))) ;FIXME: really OK to suppress?
- (compiler-warn
- "The type ~S in ~S declaration conflicts with an ~
- enclosing assertion:~% ~S"
- (type-specifier ctype)
- name
- (type-specifier old-type)))
- (make-lexenv :type-restrictions `((,cont . ,new))
- :default lexenv)))
+;;; A logic shared among THE and TRULY-THE.
+(defun the-in-policy (type value policy start cont)
+ (let ((type (if (ctype-p type) type
+ (compiler-values-specifier-type type))))
+ (cond ((or (eq type *wild-type*)
+ (eq type *universal-type*)
+ (and (leaf-p value)
+ (values-subtypep (make-single-value-type (leaf-type value))
+ type))
+ (and (sb!xc:constantp value)
+ (ctypep (constant-form-value value)
+ (single-value-type type))))
+ (ir1-convert start cont value))
+ (t (let ((value-cont (make-continuation)))
+ (ir1-convert start value-cont value)
+ (let ((cast (make-cast value-cont type policy)))
+ (link-node-to-previous-continuation cast value-cont)
+ (setf (continuation-dest value-cont) cast)
+ (use-continuation cast cont)))))))
;;; Assert that FORM evaluates to the specified type (which may be a
-;;; VALUES type).
-;;;
-;;; FIXME: In a version of CMU CL that I used at Cadabra ca. 20000101,
-;;; this didn't seem to expand into an assertion, at least for ALIEN
-;;; values. Check that SBCL doesn't have this problem.
+;;; VALUES type). TYPE may be a type specifier or (as a hack) a CTYPE.
(def-ir1-translator the ((type value) start cont)
- (let ((*lexenv* (do-the-stuff type cont *lexenv* 'the)))
- (ir1-convert start cont value)))
+ (the-in-policy type value (lexenv-policy *lexenv*) start cont))
;;; This is like the THE special form, except that it believes
;;; whatever you tell it. It will never generate a type check, but
;;; will cause a warning if the compiler can prove the assertion is
;;; wrong.
-;;;
-;;; Since the CONTINUATION-DERIVED-TYPE is computed as the union of
-;;; its uses's types, setting it won't work. Instead we must intersect
-;;; the type with the uses's DERIVED-TYPE.
(def-ir1-translator truly-the ((type value) start cont)
#!+sb-doc
+ ""
(declare (inline member))
- (let ((type (values-specifier-type type))
+ #-nil
+ (let ((type (coerce-to-values (compiler-values-specifier-type type)))
(old (find-uses cont)))
(ir1-convert start cont value)
(do-uses (use cont)
(unless (member use old :test #'eq)
- (derive-node-type use type)))))
+ (derive-node-type use type))))
+ #+nil
+ (the-in-policy type value '((type-check . 0)) start cont))
\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-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))
+ ;; FIXME: [Free] type declaration. -- APD, 2002-01-26
(ir1-convert start cont `(setf ,(cdr leaf) ,(second things))))
(heap-alien-info
(ir1-convert start cont
;;; 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))
- (ir1-convert start dest value)
+ (let ((dest (make-continuation))
+ (type (or (lexenv-find var type-restrictions)
+ (leaf-type var))))
+ (ir1-convert start dest `(the ,type ,value))
(let ((res (make-set :var var :value dest)))
(setf (continuation-dest dest) res)
(setf (leaf-ever-used var) t)
\f
;;;; CATCH, THROW and UNWIND-PROTECT
-;;; We turn THROW into a multiple-value-call of a magical function,
+;;; We turn THROW into a MULTIPLE-VALUE-CALL of a magical function,
;;; since as as far as IR1 is concerned, it has no interesting
;;; properties other than receiving multiple-values.
(def-ir1-translator throw ((tag result) start cont)
;;;
;;; 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)))
-;;; 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 catch ((tag &body body) start cont)
#!+sb-doc
"Catch Tag Form*
- Evaluates Tag and instantiates it as a catcher while the body forms are
- evaluated in an implicit PROGN. If a THROW is done to Tag within the dynamic
+ 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.
(ir1-convert
start cont
- (let ((exit-block (gensym "EXIT-BLOCK-")))
+ (with-unique-names (exit-block)
`(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
-;;; %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
"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
+ 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
+ ;; use %CLEANUP-FUN on this to indicate that reference by
+ ;; %UNWIND-PROTECT isn't "real", and thus doesn't cause creation of
+ ;; an XEP.
(ir1-convert
start cont
- (let ((cleanup-fun (gensym "CLEANUP-FUN-"))
- (drop-thru-tag (gensym "DROP-THRU-TAG-"))
- (exit-tag (gensym "EXIT-TAG-"))
- (next (gensym "NEXT"))
- (start (gensym "START"))
- (count (gensym "COUNT")))
+ (with-unique-names (cleanup-fun drop-thru-tag exit-tag next start count)
`(flet ((,cleanup-fun () ,@cleanup nil))
;; FIXME: If we ever get DYNAMIC-EXTENT working, then
;; ,CLEANUP-FUN should probably be declared DYNAMIC-EXTENT,
- ;; and something can be done to make %ESCAPE-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)))))))
\f
;;;; multiple-value stuff
-;;; If there are arguments, MULTIPLE-VALUE-CALL turns into an
-;;; MV-COMBINATION.
-;;;
-;;; If there are no arguments, then we convert to a normal
-;;; combination, ensuring that a MV-COMBINATION always has at least
-;;; one argument. This can be regarded as an optimization, but it is
-;;; more important for simplifying compilation of MV-COMBINATIONS.
(def-ir1-translator multiple-value-call ((fun &rest args) start cont)
#!+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."
+ 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* ((fun-cont (make-continuation))
(node (if args
+ ;; If there are arguments, MULTIPLE-VALUE-CALL
+ ;; turns into an MV-COMBINATION.
(make-mv-combination fun-cont)
+ ;; If there are no arguments, then we convert to a
+ ;; normal combination, ensuring that a MV-COMBINATION
+ ;; always has at least one argument. This can be
+ ;; regarded as an optimization, but it is more
+ ;; important for simplifying compilation of
+ ;; MV-COMBINATIONS.
(make-combination fun-cont))))
(ir1-convert start fun-cont
(if (and (consp fun) (eq (car fun) 'function))
fun
`(%coerce-callable-to-fun ,fun)))
(setf (continuation-dest fun-cont) node)
- (assert-continuation-type fun-cont
- (specifier-type '(or function symbol)))
(collect ((arg-conts))
(let ((this-start fun-cont))
(dolist (arg args)
\f
;;;; interface to defining macros
-;;;; FIXME:
-;;;; classic CMU CL comment:
-;;;; DEFMACRO and DEFUN expand into calls to %DEFxxx functions
-;;;; so that we get a chance to see what is going on. We define
-;;;; IR1 translators for these functions which look at the
-;;;; definition and then generate a call to the %%DEFxxx function.
-;;;; Alas, this implementation doesn't do the right thing for
-;;;; non-toplevel uses of these forms, so this should probably
-;;;; be changed to use EVAL-WHEN instead.
-
-;;; Return a new source path with any stuff intervening between the
-;;; current path and the first form beginning with NAME stripped off.
-;;; This is used to hide the guts of DEFmumble macros to prevent
-;;; annoying error messages.
+;;; Old CMUCL comment:
+;;;
+;;; Return a new source path with any stuff intervening between the
+;;; current path and the first form beginning with NAME stripped
+;;; off. This is used to hide the guts of DEFmumble macros to
+;;; prevent annoying error messages.
+;;;
+;;; Now that we have implementations of DEFmumble macros in terms of
+;;; EVAL-WHEN, this function is no longer used. However, it might be
+;;; worth figuring out why it was used, and maybe doing analogous
+;;; munging to the functions created in the expanders for the macros.
(defun revert-source-path (name)
(do ((path *current-path* (cdr path)))
((null path) *current-path*)
(when (or (eq first name)
(eq first 'original-source-start))
(return path)))))
-
-;;; Warn about incompatible or illegal definitions and add the macro
-;;; to the compiler environment.
-;;;
-;;; Someday we could check for macro arguments being incompatibly
-;;; redefined. Doing this right will involve finding the old macro
-;;; lambda-list and comparing it with the new one.
-(def-ir1-translator %defmacro ((qname qdef lambda-list doc) start cont
- :kind :function)
- (let (;; QNAME is typically a quoted name. I think the idea is to
- ;; let %DEFMACRO work as an ordinary function when
- ;; interpreting. Whatever the reason the quote is there, we
- ;; don't want it any more. -- WHN 19990603
- (name (eval qname))
- ;; QDEF should be a sharp-quoted definition. We don't want to
- ;; make a function of it just yet, so we just drop the
- ;; sharp-quote.
- (def (progn
- (aver (eq 'function (first qdef)))
- (aver (proper-list-of-length-p qdef 2))
- (second qdef))))
-
- (/show "doing IR1 translator for %DEFMACRO" name)
-
- (unless (symbolp name)
- (compiler-error "The macro name ~S is not a symbol." name))
-
- (ecase (info :function :kind name)
- ((nil))
- (:function
- (remhash name *free-functions*)
- (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 :where-from name)))
- (:macro)
- (:special-form
- (compiler-error "The special form ~S can't be redefined as a macro."
- name)))
-
- (setf (info :function :kind name) :macro
- (info :function :where-from name) :defined
- (info :function :macro-function name) (coerce def 'function))
-
- (let* ((*current-path* (revert-source-path 'defmacro))
- (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)))
-
- (when sb!xc:*compile-print*
- ;; FIXME: It would be nice to convert this, and the other places
- ;; which create compiler diagnostic output prefixed by
- ;; semicolons, to use some common utility which automatically
- ;; prefixes all its output with semicolons. (The addition of
- ;; semicolon prefixes was introduced ca. sbcl-0.6.8.10 as the
- ;; "MNA compiler message patch", and implemented by modifying a
- ;; bunch of output statements on a case-by-case basis, which
- ;; seems unnecessarily error-prone and unclear, scattering
- ;; implicit information about output style throughout the
- ;; system.) Starting by rewriting COMPILER-MUMBLE to add
- ;; semicolon prefixes would be a good start, and perhaps also:
- ;; * Add semicolon prefixes for "FOO assembled" messages emitted
- ;; when e.g. src/assembly/x86/assem-rtns.lisp is processed.
- ;; * At least some debugger output messages deserve semicolon
- ;; prefixes too:
- ;; ** restarts table
- ;; ** "Within the debugger, you can type HELP for help."
- (compiler-mumble "~&; converted ~S~%" name))))
-
-(def-ir1-translator %define-compiler-macro ((name def lambda-list doc)
- start cont
- :kind :function)
- (let ((name (eval name))
- (def (second def))) ; We don't want to make a function just yet...
-
- (when (eq (info :function :kind name) :special-form)
- (compiler-error "attempt to define a compiler-macro for special form ~S"
- name))
-
- (setf (info :function :compiler-macro-function name)
- (coerce def 'function))
-
- (let* ((*current-path* (revert-source-path 'define-compiler-macro))
- (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)))
-
- (when sb!xc:*compile-print*
- (compiler-mumble "~&; converted ~S~%" name))))
projects / sbcl.git / blobdiff