(declaim (list *current-path*))
(defvar *current-path* nil)
-;;; *CONVERTING-FOR-INTERPRETER* is true when we are creating IR1 to
-;;; be interpreted rather than compiled. This inhibits source
-;;; tranformations and stuff.
-(defvar *converting-for-interpreter* nil)
-;;; FIXME: Rename to *IR1-FOR-INTERPRETER-NOT-COMPILER-P*.
-
-;;; FIXME: This nastiness was one of my original motivations to start
-;;; hacking CMU CL. The non-ANSI behavior can be useful, but it should
-;;; be made not the default, and perhaps should be controlled by
-;;; DECLAIM instead of a variable like this. And whether or not this
-;;; kind of checking is on, declarations should be assertions to the
-;;; extent practical, and code which can't be compiled efficiently
-;;; while adhering to that principle should give warnings.
-(defvar *derive-function-types* t
- #!+sb-doc
- "(Caution: Soon, this might change its semantics somewhat, or even go away.)
- If true, argument and result type information derived from compilation of
- DEFUNs is used when compiling calls to that function. If false, only
- information from FTYPE proclamations will be used.")
+(defvar *derive-function-types* nil
+ "Should the compiler assume that function types will never change,
+ so that it can use type information inferred from current definitions
+ to optimize code which uses those definitions? Setting this true
+ gives non-ANSI, early-CMU-CL behavior. It can be useful for improving
+ the efficiency of stable code.")
\f
;;;; namespace management utilities
;;; This function is called on freshly read forms to record the
;;; initial location of each form (and subform.) Form is the form to
-;;; find the paths in, and TLF-Num is the top-level form number of the
+;;; find the paths in, and TLF-NUM is the top-level form number of the
;;; truly top-level form.
;;;
;;; This gets a bit interesting when the source code is circular. This
`(block ,skip
(catch 'ir1-error-abort
(let ((*compiler-error-bailout*
- #'(lambda ()
- (throw 'ir1-error-abort nil))))
+ (lambda ()
+ (throw 'ir1-error-abort nil))))
,@body
(return-from ,skip nil)))
(ir1-convert ,start ,cont ,proxy)))))
(values))
;; Generate a reference to a manifest constant, creating a new leaf
- ;; if necessary. If we are producing a fasl-file, make sure that
+ ;; if necessary. If we are producing a fasl file, make sure that
;; MAKE-LOAD-FORM gets used on any parts of the constant that it
;; needs to be.
(defun reference-constant (start cont value)
(translator (info :function :ir1-convert fun))
(cmacro (info :function :compiler-macro-function fun)))
(cond (translator (funcall translator start cont form))
- ((and cmacro (not *converting-for-interpreter*)
- (not (eq (info :function :inlinep fun) :notinline)))
+ ((and cmacro
+ (not (eq (info :function :inlinep fun)
+ :notinline)))
(let ((res (careful-expand-macro cmacro form)))
(if (eq res form)
(ir1-convert-global-functoid-no-cmacro start cont form fun)
(muffle-warning)
(error "internal error -- no MUFFLE-WARNING restart"))
-;;; Trap errors during the macroexpansion.
+;;; Expand FORM using the macro whose MACRO-FUNCTION is FUN, trapping
+;;; errors which occur during the macroexpansion.
(defun careful-expand-macro (fun form)
(handler-bind (;; When cross-compiling, we can get style warnings
;; about e.g. undefined functions. An unhandled
;;; Convert a call to a global function. If not :NOTINLINE, then we do
;;; source transforms and try out any inline expansion. If there is no
-;;; expansion, but is :INLINE, then give an efficiency note (unless a known
-;;; function which will quite possibly be open-coded.) Next, we go to
-;;; ok-combination conversion.
+;;; expansion, but is :INLINE, then give an efficiency note (unless a
+;;; known function which will quite possibly be open-coded.) Next, we
+;;; go to ok-combination conversion.
(defun ir1-convert-srctran (start cont var form)
(declare (type continuation start cont) (type global-var var))
(let ((inlinep (when (defined-function-p var)
(defined-function-inlinep var))))
- (cond
- ((eq inlinep :notinline)
- (ir1-convert-combination start cont form var))
- (*converting-for-interpreter*
- (ir1-convert-combination-checking-type start cont form var))
- (t
- (let ((transform (info :function :source-transform (leaf-name var))))
- (cond
- (transform
- (multiple-value-bind (result pass) (funcall transform form)
- (if pass
- (ir1-convert-maybe-predicate start cont form var)
- (ir1-convert start cont result))))
- (t
- (ir1-convert-maybe-predicate start cont form var))))))))
-
-;;; If the function has the Predicate attribute, and the CONT's DEST isn't
-;;; an IF, then we convert (IF <form> T NIL), ensuring that a predicate always
-;;; appears in a conditional context.
+ (if (eq inlinep :notinline)
+ (ir1-convert-combination start cont form var)
+ (let ((transform (info :function :source-transform (leaf-name var))))
+ (if transform
+ (multiple-value-bind (result pass) (funcall transform form)
+ (if pass
+ (ir1-convert-maybe-predicate start cont form var)
+ (ir1-convert start cont result)))
+ (ir1-convert-maybe-predicate start cont form var))))))
+
+;;; If the function has the PREDICATE attribute, and the CONT's DEST
+;;; isn't an IF, then we convert (IF <form> T NIL), ensuring that a
+;;; predicate always appears in a conditional context.
;;;
;;; If the function isn't a predicate, then we call
;;; IR1-CONVERT-COMBINATION-CHECKING-TYPE.
type
(type-approx-intersection2 old-type type))))
(cond ((eq int *empty-type*)
- (unless (policy nil (= inhibit-warnings 3))
+ (unless (policy *lexenv* (= inhibit-warnings 3))
(compiler-warning
"The type declarations ~S and ~S for ~S conflict."
(type-specifier old-type) (type-specifier type)
name "in an inline or notinline declaration")))
(etypecase found
(functional
- (when (policy nil (>= speed inhibit-warnings))
+ (when (policy *lexenv* (>= speed inhibit-warnings))
(compiler-note "ignoring ~A declaration not at ~
definition of local function:~% ~S"
sense name)))
(make-lexenv
:default res
:policy (process-optimize-decl spec (lexenv-policy res))))
- (optimize-interface
- (make-lexenv
- :default res
- :interface-policy (process-optimize-decl
- spec
- (lexenv-interface-policy res))))
(type
(process-type-decl (cdr spec) res vars))
(values
`(values ,@types))
cont res 'values))))
(dynamic-extent
- (when (policy nil (> speed inhibit-warnings))
+ (when (policy *lexenv* (> speed inhibit-warnings))
(compiler-note
"compiler limitation:~
~% There's no special support for DYNAMIC-EXTENT (so it's ignored)."))
(declaim (ftype (function (symbol list t) keyword) make-keyword-for-arg))
(defun make-keyword-for-arg (symbol vars keywordify)
(let ((key (if (and keywordify (not (keywordp symbol)))
- (intern (symbol-name symbol) "KEYWORD")
+ (keywordicate symbol)
symbol)))
(when (eq key :allow-other-keys)
(compiler-error "No &KEY arg can be called :ALLOW-OTHER-KEYS."))
;;; sequentially bind each AUX-VAR to the corresponding AUX-VAL before
;;; converting the body. If there are no bindings, just convert the
;;; body, otherwise do one binding and recurse on the rest.
-;;;
-;;; If INTERFACE is true, then we convert bindings with the interface
-;;; policy. For real &AUX bindings, and for implicit aux bindings
-;;; introduced by keyword bindings, this is always true. It is only
-;;; false when LET* directly calls this function.
-(defun ir1-convert-aux-bindings (start cont body aux-vars aux-vals interface)
+(defun ir1-convert-aux-bindings (start cont body aux-vars aux-vals)
(declare (type continuation start cont) (list body aux-vars aux-vals))
(if (null aux-vars)
(ir1-convert-progn-body start cont body)
(let ((fun-cont (make-continuation))
- (fun (ir1-convert-lambda-body body (list (first aux-vars))
- (rest aux-vars) (rest aux-vals)
- interface)))
+ (fun (ir1-convert-lambda-body body
+ (list (first aux-vars))
+ :aux-vars (rest aux-vars)
+ :aux-vals (rest aux-vals))))
(reference-leaf start fun-cont fun)
- (let ((*lexenv* (if interface
- (make-lexenv
- :policy (make-interface-policy *lexenv*))
- *lexenv*)))
- (ir1-convert-combination-args fun-cont cont
- (list (first aux-vals))))))
+ (ir1-convert-combination-args fun-cont cont
+ (list (first aux-vals)))))
(values))
;;; This is similar to IR1-CONVERT-PROGN-BODY except that code to bind
;;; will end up being the innermost one. We force CONT to start a
;;; block outside of this cleanup, causing cleanup code to be emitted
;;; when the scope is exited.
-(defun ir1-convert-special-bindings (start cont body aux-vars aux-vals
- interface svars)
+(defun ir1-convert-special-bindings (start cont body aux-vars aux-vals svars)
(declare (type continuation start cont)
(list body aux-vars aux-vals svars))
(cond
((null svars)
- (ir1-convert-aux-bindings start cont body aux-vars aux-vals interface))
+ (ir1-convert-aux-bindings start cont body aux-vars aux-vals))
(t
(continuation-starts-block cont)
(let ((cleanup (make-cleanup :kind :special-bind))
(let ((*lexenv* (make-lexenv :cleanup cleanup)))
(ir1-convert next-cont nnext-cont '(%cleanup-point))
(ir1-convert-special-bindings nnext-cont cont body aux-vars aux-vals
- interface (rest svars))))))
+ (rest svars))))))
(values))
;;; Create a lambda node out of some code, returning the result. The
;;;
;;; AUX-VARS is a list of VAR structures for variables that are to be
;;; sequentially bound. Each AUX-VAL is a form that is to be evaluated
-;;; to get the initial value for the corresponding AUX-VAR. Interface
-;;; is a flag as T when there are real aux values (see LET* and
-;;; IR1-CONVERT-AUX-BINDINGS.)
-(defun ir1-convert-lambda-body (body vars &optional aux-vars aux-vals
- interface result)
+;;; to get the initial value for the corresponding AUX-VAR.
+(defun ir1-convert-lambda-body (body vars &key aux-vars aux-vals result)
(declare (list body vars aux-vars aux-vals)
(type (or continuation null) result))
(let* ((bind (make-bind))
(prev-link bind cont1)
(use-continuation bind cont2)
(ir1-convert-special-bindings cont2 result body aux-vars aux-vals
- interface (svars)))
+ (svars)))
(let ((block (continuation-block result)))
(when block
;;; then we mark the corresponding var as EVER-USED to inhibit
;;; "defined but not read" warnings for arguments that are only used
;;; by default forms.
-;;;
-;;; We bind *LEXENV* to change the policy to the interface policy.
(defun convert-optional-entry (fun vars vals defaults)
(declare (type clambda fun) (list vars vals defaults))
(let* ((fvars (reverse vars))
:where-from (leaf-where-from var)
:specvar (lambda-var-specvar var)))
fvars))
- (*lexenv* (make-lexenv :policy (make-interface-policy *lexenv*)))
(fun
- (ir1-convert-lambda-body
- `((%funcall ,fun ,@(reverse vals) ,@defaults))
- arg-vars)))
- (mapc #'(lambda (var arg-var)
- (when (cdr (leaf-refs arg-var))
- (setf (leaf-ever-used var) t)))
+ (ir1-convert-lambda-body `((%funcall ,fun
+ ,@(reverse vals)
+ ,@defaults))
+ arg-vars)))
+ (mapc (lambda (var arg-var)
+ (when (cdr (leaf-refs arg-var))
+ (setf (leaf-ever-used var) t)))
fvars arg-vars)
fun))
;;;
;;; We deal with :ALLOW-OTHER-KEYS by delaying unknown keyword errors
;;; until we have scanned all the keywords.
-;;;
-;;; When converting the function, we bind *LEXENV* to change the
-;;; compilation policy over to the interface policy, so that keyword
-;;; args will be checked even when type checking isn't on in general.
(defun convert-more-entry (res entry-vars entry-vals rest morep keys)
(declare (type optional-dispatch res) (list entry-vars entry-vals keys))
(collect ((arg-vars)
(context-temp (make-lambda-var :name n-context))
(n-count (gensym "N-COUNT-"))
(count-temp (make-lambda-var :name n-count
- :type (specifier-type 'index)))
- (*lexenv* (make-lexenv :policy (make-interface-policy *lexenv*))))
+ :type (specifier-type 'index))))
(arg-vars context-temp count-temp)
(n-allowp (gensym "N-ALLOWP-"))
(n-losep (gensym "N-LOSEP-"))
(allowp (or (optional-dispatch-allowp res)
- (policy nil (zerop safety)))))
+ (policy *lexenv* (zerop safety)))))
(temps `(,n-index (1- ,n-count)) n-key n-value-temp)
(body `(declare (fixnum ,n-index) (ignorable ,n-key ,n-value-temp)))
(values))
-;;; This is called by IR1-Convert-Hairy-Args when we run into a &REST
+;;; This is called by IR1-CONVERT-HAIRY-ARGS when we run into a &REST
;;; or &KEY arg. The arguments are similar to that function, but we
;;; split off any &REST arg and pass it in separately. REST is the
;;; &REST arg var, or NIL if there is no &REST arg. KEYS is a list of
(main-vals (arg-info-default info))
(bind-vals n-val)))))
- (let* ((main-entry (ir1-convert-lambda-body body (main-vars)
- (append (bind-vars) aux-vars)
- (append (bind-vals) aux-vals)
- t
- cont))
+ (let* ((main-entry (ir1-convert-lambda-body
+ body (main-vars)
+ :aux-vars (append (bind-vars) aux-vars)
+ :aux-vals (append (bind-vals) aux-vals)
+ :result cont))
(last-entry (convert-optional-entry main-entry default-vars
(main-vals) ())))
(setf (optional-dispatch-main-entry res) main-entry)
;;; arguments, analyzing the arglist on the way down and generating entry
;;; points on the way up.
;;;
-;;; Default-Vars is a reversed list of all the argument vars processed so
-;;; far, including supplied-p vars. Default-Vals is a list of the names of the
-;;; Default-Vars.
+;;; Default-Vars is a reversed list of all the argument vars processed
+;;; so far, including supplied-p vars. Default-Vals is a list of the
+;;; names of the Default-Vars.
;;;
-;;; Entry-Vars is a reversed list of processed argument vars, excluding
-;;; supplied-p vars. Entry-Vals is a list things that can be evaluated to get
-;;; the values for all the vars from the Entry-Vars. It has the var name for
-;;; each required or optional arg, and has T for each supplied-p arg.
+;;; Entry-Vars is a reversed list of processed argument vars,
+;;; excluding supplied-p vars. Entry-Vals is a list things that can be
+;;; evaluated to get the values for all the vars from the Entry-Vars.
+;;; It has the var name for each required or optional arg, and has T
+;;; for each supplied-p arg.
;;;
-;;; Vars is a list of the Lambda-Var structures for arguments that haven't
-;;; been processed yet. Supplied-p-p is true if a supplied-p argument has
-;;; already been processed; only in this case are the Default-XXX and Entry-XXX
-;;; different.
+;;; Vars is a list of the Lambda-Var structures for arguments that
+;;; haven't been processed yet. Supplied-p-p is true if a supplied-p
+;;; argument has already been processed; only in this case are the
+;;; Default-XXX and Entry-XXX different.
;;;
-;;; The result at each point is a lambda which should be called by the above
-;;; level to default the remaining arguments and evaluate the body. We cause
-;;; the body to be evaluated by converting it and returning it as the result
-;;; when the recursion bottoms out.
+;;; The result at each point is a lambda which should be called by the
+;;; above level to default the remaining arguments and evaluate the
+;;; body. We cause the body to be evaluated by converting it and
+;;; returning it as the result when the recursion bottoms out.
;;;
-;;; Each level in the recursion also adds its entry point function to the
-;;; result Optional-Dispatch. For most arguments, the defaulting function and
-;;; the entry point function will be the same, but when supplied-p args are
-;;; present they may be different.
+;;; Each level in the recursion also adds its entry point function to
+;;; the result Optional-Dispatch. For most arguments, the defaulting
+;;; function and the entry point function will be the same, but when
+;;; supplied-p args are present they may be different.
;;;
;;; When we run into a &REST or &KEY arg, we punt out to
;;; IR1-CONVERT-MORE, which finishes for us in this case.
nil nil nil vars supplied-p-p body aux-vars
aux-vals cont)
(let ((fun (ir1-convert-lambda-body body (reverse default-vars)
- aux-vars aux-vals t cont)))
+ :aux-vars aux-vars
+ :aux-vals aux-vals
+ :result cont)))
(setf (optional-dispatch-main-entry res) fun)
(push (if supplied-p-p
(convert-optional-entry fun entry-vars entry-vals ())
aux-vals cont)))))))
;;; This function deals with the case where we have to make an
-;;; Optional-Dispatch to represent a lambda. We cons up the result and call
-;;; IR1-Convert-Hairy-Args to do the work. When it is done, we figure out the
-;;; min-args and max-args.
+;;; Optional-Dispatch to represent a lambda. We cons up the result and
+;;; call IR1-CONVERT-HAIRY-ARGS to do the work. When it is done, we
+;;; figure out the min-args and max-args.
(defun ir1-convert-hairy-lambda (body vars keyp allowp aux-vars aux-vals cont)
(declare (list body vars aux-vars aux-vals) (type continuation cont))
(let ((res (make-optional-dispatch :arglist vars
res))
-;;; Convert a Lambda into a Lambda or Optional-Dispatch leaf.
+;;; Convert a LAMBDA form into a LAMBDA leaf or an OPTIONAL-DISPATCH leaf.
(defun ir1-convert-lambda (form &optional name)
(unless (consp form)
(compiler-error "A ~S was found when expecting a lambda expression:~% ~S"
(ir1-convert-hairy-lambda forms vars keyp
allow-other-keys
aux-vars aux-vals cont)
- (ir1-convert-lambda-body forms vars aux-vars aux-vals
- t cont))))
+ (ir1-convert-lambda-body forms vars
+ :aux-vars aux-vars
+ :aux-vals aux-vals
+ :result cont))))
(setf (functional-inline-expansion res) form)
(setf (functional-arg-documentation res) (cadr form))
(setf (leaf-name res) name)
(conts cont)
(let ((*lexenv* (make-lexenv :cleanup cleanup :tags (tags))))
- (mapc #'(lambda (segment start cont)
- (ir1-convert-progn-body start cont (rest segment)))
+ (mapc (lambda (segment start cont)
+ (ir1-convert-progn-body start cont (rest segment)))
segments (starts) (conts))))))
-;;; Emit an Exit node without any value.
+;;; Emit an EXIT node without any value.
(def-ir1-translator go ((tag) start cont)
#!+sb-doc
"Go Tag
\f
;;;; translators for compiler-magic special forms
-;;; Do stuff to do an EVAL-WHEN. This is split off from the IR1
-;;; convert method so that it can be shared by the special-case
-;;; top-level form processing code. We play with the dynamic
-;;; environment and eval stuff, then call Fun with a list of forms to
-;;; be processed at load time.
-;;;
-;;; Note: the EVAL situation is always ignored: this is conceptually a
-;;; compile-only implementation.
-;;;
-;;; We have to interact with the interpreter to ensure that the forms
-;;; get EVAL'ed exactly once. We bind *ALREADY-EVALED-THIS* to true to
-;;; inhibit evaluation of any enclosed EVAL-WHENs, either by IR1
-;;; conversion done by EVAL, or by conversion of the body for
-;;; load-time processing. If *ALREADY-EVALED-THIS* is true then we *do
-;;; not* EVAL since some enclosing EVAL-WHEN already did.
+;;; This handles EVAL-WHEN in non-top-level forms. (EVAL-WHENs in
+;;; top-level forms are picked off and handled by PROCESS-TOP-LEVEL-FORM,
+;;; so they're never seen at this level.)
;;;
-;;; We know we are EVAL'ing for LOAD since we wouldn't get called
-;;; otherwise. If LOAD is a situation we call FUN on body. If we
-;;; aren't evaluating for LOAD, then we call FUN on NIL for the result
-;;; of the EVAL-WHEN.
-(defun do-eval-when-stuff (situations body fun)
-
- (when (or (not (listp situations))
- (set-difference situations
- '(compile load eval
- :compile-toplevel :load-toplevel :execute)))
- (compiler-error "bad EVAL-WHEN situation list: ~S" situations))
-
- (let ((deprecated-names (intersection situations '(compile load eval))))
- (when deprecated-names
- (style-warn "using deprecated EVAL-WHEN situation names ~S"
- deprecated-names)))
-
- (let* ((do-eval (and (intersection '(compile :compile-toplevel) situations)
- (not sb!eval::*already-evaled-this*)))
- (sb!eval::*already-evaled-this* t))
- (when do-eval
-
- ;; This is the natural way to do it.
- #-(and sb-xc-host (or sbcl cmu))
- (eval `(progn ,@body))
-
- ;; This is a disgusting hack to work around bug IR1-3 when using
- ;; SBCL (or CMU CL, for that matter) as a cross-compilation
- ;; host. When we go from the cross-compiler (where we bound
- ;; SB!EVAL::*ALREADY-EVALED-THIS*) to the host compiler (which
- ;; has a separate SB-EVAL::*ALREADY-EVALED-THIS* variable), EVAL
- ;; would go and execute nested EVAL-WHENs even when they're not
- ;; toplevel forms. Using EVAL-WHEN instead of bare EVAL causes
- ;; the cross-compilation host to bind its own
- ;; *ALREADY-EVALED-THIS* variable, so that the problem is
- ;; suppressed.
- ;;
- ;; FIXME: Once bug IR1-3 is fixed, this hack can go away. (Or if
- ;; CMU CL doesn't fix the bug, then this hack can be made
- ;; conditional on #+CMU.)
- #+(and sb-xc-host (or sbcl cmu))
- (let (#+sbcl (sb-eval::*already-evaled-this* t)
- #+cmu (common-lisp::*already-evaled-this* t))
- (eval `(eval-when (:compile-toplevel :load-toplevel :execute)
- ,@body))))
-
- (if (or (intersection '(:load-toplevel load) situations)
- (and *converting-for-interpreter*
- (intersection '(:execute eval) situations)))
- (funcall fun body)
- (funcall fun '(nil)))))
-
-(def-ir1-translator eval-when ((situations &rest body) start cont)
+;;; ANSI "3.2.3.1 Processing of Top Level Forms" says that processing
+;;; of non-top-level EVAL-WHENs is very simple:
+;;; EVAL-WHEN forms cause compile-time evaluation only at top level.
+;;; Both :COMPILE-TOPLEVEL and :LOAD-TOPLEVEL situation specifications
+;;; 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.
+(def-ir1-translator eval-when ((situations &rest forms) start cont)
#!+sb-doc
"EVAL-WHEN (Situation*) Form*
- Evaluate the Forms in the specified Situations, any of COMPILE, LOAD, EVAL.
- This is conceptually a compile-only implementation, so EVAL is a no-op."
-
- ;; It's difficult to handle EVAL-WHENs completely correctly in the
- ;; cross-compiler. (Common Lisp is not a cross-compiler-friendly
- ;; language..) Since we, the system implementors, control not only
- ;; the cross-compiler but also the code that it processes, we can
- ;; handle this either by making the cross-compiler smarter about
- ;; handling EVAL-WHENs (hard) or by avoiding the use of difficult
- ;; EVAL-WHEN constructs (relatively easy). However, since EVAL-WHENs
- ;; can be generated by many macro expansions, it's not always easy
- ;; to detect problems by skimming the source code, so we'll try to
- ;; add some code here to help out.
- ;;
- ;; Nested EVAL-WHENs are tricky.
- #+sb-xc-host
- (labels ((contains-toplevel-eval-when-p (body-part)
- (and (consp body-part)
- (or (eq (first body-part) 'eval-when)
- (and (member (first body-part)
- '(locally macrolet progn symbol-macrolet))
- (some #'contains-toplevel-eval-when-p
- (rest body-part)))))))
- (/show "testing for nested EVAL-WHENs" body)
- (when (some #'contains-toplevel-eval-when-p body)
- (compiler-style-warning "nested EVAL-WHENs in cross-compilation")))
-
- (do-eval-when-stuff situations
- body
- (lambda (forms)
- (ir1-convert-progn-body start cont forms))))
-
-;;; Like DO-EVAL-WHEN-STUFF, only do a MACROLET. FUN is not passed any
-;;; arguments.
-(defun do-macrolet-stuff (definitions fun)
- (declare (list definitions) (type function fun))
- (let ((whole (gensym "WHOLE"))
- (environment (gensym "ENVIRONMENT")))
- (collect ((new-fenv))
- (dolist (def definitions)
- (let ((name (first def))
- (arglist (second def))
- (body (cddr def)))
- (unless (symbolp name)
- (compiler-error "The local macro name ~S is not a symbol." name))
- (when (< (length def) 2)
- (compiler-error
- "The list ~S is too short to be a legal local macro definition."
- name))
- (multiple-value-bind (body local-decs)
- (parse-defmacro arglist whole body name 'macrolet
- :environment environment)
- (new-fenv `(,(first def) macro .
- ,(coerce `(lambda (,whole ,environment)
- ,@local-decs (block ,name ,body))
- 'function))))))
-
- (let ((*lexenv* (make-lexenv :functions (new-fenv))))
- (funcall fun))))
+ Evaluate the Forms in the specified Situations (any of :COMPILE-TOPLEVEL,
+ :LOAD-TOPLEVEL, or :EXECUTE, or (deprecated) COMPILE, LOAD, or EVAL)."
+ (multiple-value-bind (ct lt e) (parse-eval-when-situations situations)
+ (declare (ignore ct lt))
+ (when e
+ (ir1-convert-progn-body start cont forms)))
+ (values))
+;;; 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)
+ (declare (type list definitions) (type function fun))
+ (let* ((whole (gensym "WHOLE"))
+ (environment (gensym "ENVIRONMENT"))
+ (processed-definitions
+ (mapcar (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))
+ (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)))))))
+ definitions))
+ (*lexenv* (make-lexenv :functions processed-definitions)))
+ (unless (= (length definitions)
+ (length (remove-duplicates definitions :key #'first)))
+ (compiler-style-warning
+ "duplicate macro names in MACROLET ~S" definitions))
+ (funcall fun))
(values))
(def-ir1-translator macrolet ((definitions &rest body) start cont)
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."
- (do-macrolet-stuff definitions
- #'(lambda ()
- (ir1-convert-progn-body start cont body))))
+ (funcall-in-macrolet-lexenv definitions
+ (lambda ()
+ (ir1-translate-locally body start cont))))
+
+;;; Tweak *LEXENV* to include the MACROBINDINGS from a SYMBOL-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 SYMBOL-MACROLET processing code.
+(defun funcall-in-symbol-macrolet-lexenv (macrobindings fun)
+ (declare (type list macrobindings) (type function fun))
+ (let ((processed-macrobindings
+ (mapcar (lambda (macrobinding)
+ (unless (proper-list-of-length-p macrobinding 2)
+ (compiler-error "malformed symbol/expansion pair: ~S"
+ macrobinding))
+ (destructuring-bind (name expansion) macrobinding
+ (unless (symbolp name)
+ (compiler-error
+ "The local symbol macro name ~S is not a symbol."
+ name))
+ `(,name . (MACRO . ,expansion))))
+ macrobindings)))
+ (unless (= (length macrobindings)
+ (length (remove-duplicates macrobindings :key #'first)))
+ (compiler-style-warning
+ "duplicate symbol macro names in SYMBOL-MACROLET ~S" macrobindings))
+ (let ((*lexenv* (make-lexenv :variables processed-macrobindings)))
+ (funcall fun)))
+ (values))
+
+(def-ir1-translator symbol-macrolet ((macrobindings &body body) start cont)
+ #!+sb-doc
+ "SYMBOL-MACROLET ({(Name Expansion)}*) Decl* Form*
+ Define the Names as symbol macros with the given Expansions. Within the
+ 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)
(compiler-error "Lisp error during evaluation of info args:~%~A"
condition))))
-;;; a hashtable that translates from primitive names to translation functions
-(defvar *primitive-translators* (make-hash-table :test 'eq))
-
;;; If there is a primitive translator, then we expand the call.
;;; Otherwise, we convert to the %%PRIMITIVE funny function. The first
;;; argument is the template, the second is a list of the results of
;;; a fatal error during IR2 conversion.
;;;
;;; KLUDGE: It's confusing having multiple names floating around for
-;;; nearly the same concept: PRIMITIVE, TEMPLATE, VOP. Might it be
-;;; possible to reimplement BYTE-BLT (the only use of
-;;; *PRIMITIVE-TRANSLATORS*) some other way, then get rid of primitive
-;;; translators altogether, so that there would be no distinction
-;;; between primitives and vops? Then we could call primitives vops,
-;;; rename TEMPLATE to VOP-TEMPLATE, rename BACKEND-TEMPLATE-NAMES to
-;;; BACKEND-VOPS, and rename %PRIMITIVE to VOP.. -- WHN 19990906
-;;; FIXME: Look at doing this ^, it doesn't look too hard actually. I
-;;; think BYTE-BLT could probably just become an inline function.
+;;; nearly the same concept: PRIMITIVE, TEMPLATE, VOP. Now that CMU
+;;; CL's *PRIMITIVE-TRANSLATORS* stuff is gone, we could call
+;;; primitives VOPs, rename TEMPLATE to VOP-TEMPLATE, rename
+;;; BACKEND-TEMPLATE-NAMES to BACKEND-VOPS, and rename %PRIMITIVE to
+;;; VOP or %VOP.. -- WHN 2001-06-11
+;;; FIXME: Look at doing this ^, it doesn't look too hard actually.
(def-ir1-translator %primitive ((&whole form name &rest args) start cont)
(unless (symbolp name)
(compiler-error "The primitive name ~S is not a symbol." name))
- (let* ((translator (gethash name *primitive-translators*)))
- (if translator
- (ir1-convert start cont (funcall translator (cdr form)))
- (let* ((template (or (gethash name *backend-template-names*)
- (compiler-error
- "The primitive name ~A is not defined."
- name)))
- (required (length (template-arg-types template)))
- (info (template-info-arg-count template))
- (min (+ required info))
- (nargs (length args)))
- (if (template-more-args-type template)
- (when (< nargs min)
- (compiler-error "Primitive ~A was called with ~R argument~:P, ~
- but wants at least ~R."
- name
- nargs
- min))
- (unless (= nargs min)
- (compiler-error "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."))
-
- (when (template-more-results-type template)
- (compiler-error
- "%PRIMITIVE was used with an unknown values template."))
-
- (ir1-convert start
- cont
- `(%%primitive ',template
- ',(eval-info-args
- (subseq args required min))
- ,@(subseq args 0 required)
- ,@(subseq args min)))))))
+ (let* ((template (or (gethash name *backend-template-names*)
+ (compiler-error
+ "The primitive name ~A is not defined."
+ name)))
+ (required (length (template-arg-types template)))
+ (info (template-info-arg-count template))
+ (min (+ required info))
+ (nargs (length args)))
+ (if (template-more-args-type template)
+ (when (< nargs min)
+ (compiler-error "Primitive ~A was called with ~R argument~:P, ~
+ but wants at least ~R."
+ name
+ nargs
+ min))
+ (unless (= nargs min)
+ (compiler-error "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."))
+
+ (when (template-more-results-type template)
+ (compiler-error
+ "%PRIMITIVE was used with an unknown values template."))
+
+ (ir1-convert start
+ cont
+ `(%%primitive ',template
+ ',(eval-info-args
+ (subseq args required min))
+ ,@(subseq args 0 required)
+ ,@(subseq args min)))))
\f
;;;; QUOTE and FUNCTION
"optimize away possible call to FDEFINITION at runtime"
'thing)
\f
-;;;; symbol macros
-
-(def-ir1-translator symbol-macrolet ((specs &body body) start cont)
- #!+sb-doc
- "SYMBOL-MACROLET ({(Name Expansion)}*) Decl* Form*
- Define the Names as symbol macros with the given Expansions. Within the
- body, references to a Name will effectively be replaced with the Expansion."
- (multiple-value-bind (forms decls) (sb!sys:parse-body body nil)
- (collect ((res))
- (dolist (spec specs)
- (unless (proper-list-of-length-p spec 2)
- (compiler-error "The symbol macro binding ~S is malformed." spec))
- (let ((name (first spec))
- (def (second spec)))
- (unless (symbolp name)
- (compiler-error "The symbol macro name ~S is not a symbol." name))
- (when (assoc name (res) :test #'eq)
- (compiler-style-warning
- "The name ~S occurs more than once in SYMBOL-MACROLET."
- name))
- (res `(,name . (MACRO . ,def)))))
-
- (let* ((*lexenv* (make-lexenv :variables (res)))
- (*lexenv* (process-decls decls (res) nil cont)))
- (ir1-convert-progn-body start cont forms)))))
-\f
;;; This is a frob that DEFSTRUCT expands into to establish the compiler
;;; semantics. The other code in the expansion and %%COMPILER-DEFSTRUCT do
;;; most of the work, we just clear all of the functions out of
(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 nil)))))
-
-;;; This is a lot like a LET* with no bindings. Unlike LET*, LOCALLY
-;;; has to preserves top-level-formness, but we don't need to worry
-;;; about that here, because special logic in the compiler main loop
-;;; grabs top-level LOCALLYs and takes care of them before this
-;;; transform ever sees them.
-(def-ir1-translator locally ((&body body)
- start cont)
+ (ir1-convert-aux-bindings start cont forms vars values)))))
+
+;;; logic shared between IR1 translators for LOCALLY, MACROLET,
+;;; and SYMBOL-MACROLET
+;;;
+;;; Note that all these things need to preserve top-level-formness,
+;;; but we don't need to worry about that within an IR1 translator,
+;;; since top-level-formness is picked off by PROCESS-TOP-LEVEL-FOO
+;;; 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)
+ (let ((*lexenv* (process-decls decls nil nil cont)))
+ (ir1-convert-aux-bindings start cont forms nil nil))))
+
+(def-ir1-translator locally ((&body body) start cont)
#!+sb-doc
"LOCALLY Declaration* Form*
Sequentially evaluate the Forms in a lexical environment where the
the Declarations have effect. If LOCALLY is a top-level form, then
the Forms are also processed as top-level forms."
- (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 nil))))
+ (ir1-translate-locally body start cont))
\f
;;;; FLET and LABELS
;;; Given a list of local function specifications in the style of
-;;; Flet, return lists of the function names and of the lambdas which
+;;; FLET, return lists of the function names and of the lambdas which
;;; are their definitions.
;;;
-;;; The function names are checked for legality. Context is the name
+;;; 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))
(let* ((ctype (values-specifier-type type))
(old-type (or (lexenv-find cont type-restrictions)
*wild-type*))
- (intersects (values-types-intersect old-type ctype))
+ (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 nil (= inhibit-warnings 3)))) ;FIXME: really OK to suppress?
+ (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"
(type-specifier ctype)
(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))
(remhash name *free-functions*)
(undefine-function-name name)
(compiler-warning
- "~S is being redefined as a macro when it was previously ~(~A~) to be a function."
+ "~S is being redefined as a macro when it was ~
+ previously ~(~A~) to be a function."
name
(info :function :where-from name)))
(:macro)
(make-null-lexenv))
:variables (copy-list symbol-macros)
:functions
- (mapcar #'(lambda (x)
- `(,(car x) .
- (macro . ,(coerce (cdr x) 'function))))
+ (mapcar (lambda (x)
+ `(,(car x) .
+ (macro . ,(coerce (cdr x) 'function))))
macros)
- :policy (lexenv-policy *lexenv*)
- :interface-policy (lexenv-interface-policy *lexenv*))))
+ :policy (lexenv-policy *lexenv*))))
(ir1-convert-lambda `(lambda ,@body) name))))
;;; Return a lambda that has been "closed" with respect to ENV,
;; 3.2.2.3 of the spec) but at least as of sbcl-0.6.11, we don't
;; keep track of whether the mismatched data came from the same
;; compilation unit, so we can't do that. -- WHN 2001-02-11
- ;;
- ;; FIXME: Actually, I think we could issue a full WARNING if the
- ;; new definition contradicts a DECLAIM FTYPE.
:error-function #'compiler-style-warning
:warning-function (cond (info #'compiler-style-warning)
(for-real #'compiler-note)