:format-arguments (list ,@args))))))
`(lambda (definition)
(unless (list-of-length-at-least-p definition 2)
- ,(make-error-form "The list ~S is too short to be a legal local macro definition." 'definition))
+ ,(make-error-form
+ "The list ~S is too short to be a legal local macro definition."
+ 'definition))
(destructuring-bind (name arglist &body body) definition
(unless (symbolp name)
,(make-error-form "The local macro name ~S is not a symbol." 'name))
(unless (listp arglist)
- ,(make-error-form "The local macro argument list ~S is not a list." 'arglist))
- (let ((whole (gensym "WHOLE"))
- (environment (gensym "ENVIRONMENT")))
+ ,(make-error-form
+ "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)
(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 named-lambda instance-lambda lambda-with-lexenv)
- (reference-leaf start
- cont
- (ir1-convert-lambdalike
- thing
- :debug-name (debug-namify "#'~S" thing)
- :allow-debug-catch-tag t)))
- ((setf sb!pcl::class-predicate sb!pcl::slot-accessor)
- (let ((var (find-lexically-apparent-fun
- thing "as the argument to FUNCTION")))
- (reference-leaf start cont var)))
- (t
- (compiler-error "~S is not a legal function name." thing)))
- (let ((var (find-lexically-apparent-fun
- thing "as the argument to FUNCTION")))
- (reference-leaf start cont var))))
+ (reference-leaf start cont (fun-name-leaf thing)))
\f
;;;; FUNCALL
,@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)
- (lexenv-policy *lexenv*))
- (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
(declare (type list body) (type continuation start cont))
(multiple-value-bind (forms decls) (parse-body body nil)
(let ((*lexenv* (process-decls decls vars funs cont)))
- (ir1-convert-aux-bindings start cont forms nil nil))))
+ (ir1-convert-progn-body start cont forms))))
(def-ir1-translator locally ((&body body) start cont)
#!+sb-doc
\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 ir1ize-the-or-values (type cont lexenv place)
- (declare (type continuation cont) (type lexenv lexenv))
- (let* ((atype (if (typep type 'ctype) type (compiler-values-specifier-type type)))
- (old-atype (or (lexenv-find cont type-restrictions)
- *wild-type*))
- (old-ctype (or (lexenv-find cont weakend-type-restrictions)
- *wild-type*))
- (intersects (values-types-equal-or-intersect old-atype atype))
- (new-atype (values-type-intersection old-atype atype))
- (new-ctype (values-type-intersection
- old-ctype (maybe-weaken-check atype (lexenv-policy lexenv)))))
- (when (null (find-uses cont))
- (setf (continuation-asserted-type cont) new-atype)
- (setf (continuation-type-to-check cont) new-ctype))
- (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-warn
- "The type ~S ~A conflicts with an enclosing assertion:~% ~S"
- (type-specifier atype)
- place
- (type-specifier old-atype)))
- (make-lexenv :type-restrictions `((,cont . ,new-atype))
- :weakend-type-restrictions `((,cont . ,new-ctype))
- :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).
+;;; VALUES type). TYPE may be a type specifier or (as a hack) a CTYPE.
;;;
;;; 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.
(def-ir1-translator the ((type value) start cont)
- (with-continuation-type-assertion (cont (compiler-values-specifier-type type)
- "in THE declaration")
- (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 (compiler-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
(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 should only need to be called in SETQ.
(defun setq-var (start cont var value)
(declare (type continuation start cont) (type basic-var var))
- (let ((dest (make-continuation)))
- (ir1-convert start dest value)
- (assert-continuation-type dest
- (or (lexenv-find var type-restrictions)
- (leaf-type var))
- (lexenv-policy *lexenv*))
+ (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)
(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-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-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
"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,
\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))
(continuation-starts-block dummy-start)
(ir1-convert start dummy-start result)
- (with-continuation-type-assertion
- ;; FIXME: policy
- (cont (continuation-asserted-type dummy-start)
- "of the first form")
- (substitute-continuation-uses cont dummy-start))
+ (substitute-continuation-uses cont dummy-start)
(continuation-starts-block dummy-result)
(ir1-convert-progn-body dummy-start dummy-result forms)