(defvar *converting-for-interpreter* nil)
;;; FIXME: Rename to *IR1-FOR-INTERPRETER-NOT-COMPILER-P*.
-;;; *COMPILE-TIME-DEFINE-MACROS* is true when we want DEFMACRO
-;;; definitions to be installed in the compilation environment as
-;;; interpreted functions. We set this to false when compiling some
-;;; parts of the system.
-(defvar *compile-time-define-macros* t)
-;;; FIXME: I think this can go away with the new system.
-
;;; 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
;;; processed with MAKE-LOAD-FORM. We have to be careful, because
;;; CONSTANT might be circular. We also check that the constant (and
;;; any subparts) are dumpable at all.
-(defconstant list-to-hash-table-threshold 32)
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ ;; The EVAL-WHEN is necessary for #.(1+ LIST-TO-HASH-TABLE-THRESHOLD)
+ ;; below. -- AL 20010227
+ (defconstant list-to-hash-table-threshold 32))
(defun maybe-emit-make-load-forms (constant)
(let ((things-processed nil)
(count 0))
;;; If a lambda-var being bound, we intersect the type with the vars
;;; type, otherwise we add a type-restriction on the var. If a symbol
;;; macro, we just wrap a THE around the expansion.
-(defun process-type-declaration (decl res vars)
+(defun process-type-decl (decl res vars)
(declare (list decl vars) (type lexenv res))
(let ((type (specifier-type (first decl))))
(collect ((restr nil cons)
(int (if (or (function-type-p type)
(function-type-p old-type))
type
- (type-intersection old-type type))))
+ (type-approx-intersection2 old-type type))))
(cond ((eq int *empty-type*)
- (unless (policy nil (= brevity 3))
+ (unless (policy nil (= inhibit-warnings 3))
(compiler-warning
"The type declarations ~S and ~S for ~S conflict."
(type-specifier old-type) (type-specifier type)
:variables (new-vars))
res))))
-;;; Somewhat similar to Process-Type-Declaration, but handles
+;;; This is somewhat similar to PROCESS-TYPE-DECL, but handles
;;; declarations for function variables. In addition to allowing
;;; declarations for functions being bound, we must also deal with
;;; declarations that constrain the type of lexically apparent
;;; functions.
-(defun process-ftype-declaration (spec res names fvars)
+(defun process-ftype-decl (spec res names fvars)
(declare (list spec names fvars) (type lexenv res))
(let ((type (specifier-type spec)))
(collect ((res nil cons))
;;; Process a special declaration, returning a new LEXENV. A non-bound
;;; special declaration is instantiated by throwing a special variable
;;; into the variables.
-(defun process-special-declaration (spec res vars)
+(defun process-special-decl (spec res vars)
(declare (list spec vars) (type lexenv res))
(collect ((new-venv nil cons))
(dolist (name (cdr spec))
;;; Parse an inline/notinline declaration. If it's a local function we're
;;; defining, set its INLINEP. If a global function, add a new FENV entry.
-(defun process-inline-declaration (spec res fvars)
- (let ((sense (cdr (assoc (first spec) inlinep-translations :test #'eq)))
+(defun process-inline-decl (spec res fvars)
+ (let ((sense (cdr (assoc (first spec) *inlinep-translations* :test #'eq)))
(new-fenv ()))
(dolist (name (rest spec))
(let ((fvar (find name fvars :key #'leaf-name :test #'equal)))
name "in an inline or notinline declaration")))
(etypecase found
(functional
- (when (policy nil (>= speed brevity))
+ (when (policy nil (>= speed inhibit-warnings))
(compiler-note "ignoring ~A declaration not at ~
definition of local function:~% ~S"
sense name)))
;;; Process an ignore/ignorable declaration, checking for various losing
;;; conditions.
-(defun process-ignore-declaration (spec vars fvars)
+(defun process-ignore-decl (spec vars fvars)
(declare (list spec vars fvars))
(dolist (name (rest spec))
(let ((var (find-in-bindings-or-fbindings name vars fvars)))
#!+sb-doc
"If true, processing of the VALUES declaration is inhibited.")
-;;; Process a single declaration spec, agumenting the specified LEXENV
-;;; Res and returning it as a result. Vars and Fvars are as described in
+;;; Process a single declaration spec, augmenting the specified LEXENV
+;;; RES and returning it as a result. VARS and FVARS are as described in
;;; PROCESS-DECLS.
-(defun process-1-declaration (spec res vars fvars cont)
- (declare (list spec vars fvars) (type lexenv res) (type continuation cont))
- (case (first spec)
- (special (process-special-declaration spec res vars))
- (ftype
- (unless (cdr spec)
- (compiler-error "No type specified in FTYPE declaration: ~S." spec))
- (process-ftype-declaration (second spec) res (cddr spec) fvars))
- (function
- ;; Handle old style FUNCTION declaration, which is an abbreviation for
- ;; FTYPE. Args are name, arglist, result type.
- (cond ((and (proper-list-of-length-p spec 3 4)
- (listp (third spec)))
- (process-ftype-declaration `(function ,@(cddr spec)) res
- (list (second spec))
- fvars))
- (t
- (process-type-declaration spec res vars))))
- ((inline notinline maybe-inline)
- (process-inline-declaration spec res fvars))
- ((ignore ignorable)
- (process-ignore-declaration spec vars fvars)
- res)
- (optimize
- (make-lexenv
- :default res
- :cookie (process-optimize-declaration spec (lexenv-cookie res))))
- (optimize-interface
- (make-lexenv
- :default res
- :interface-cookie (process-optimize-declaration
- spec
- (lexenv-interface-cookie res))))
- (type
- (process-type-declaration (cdr spec) res vars))
- (sb!pcl::class
- (process-type-declaration (list (third spec) (second spec)) res vars))
- (values
- (if *suppress-values-declaration*
- res
- (let ((types (cdr spec)))
- (do-the-stuff (if (eql (length types) 1)
- (car types)
- `(values ,@types))
- cont res 'values))))
- (dynamic-extent
- (when (policy nil (> speed brevity))
- (compiler-note
- "The DYNAMIC-EXTENT declaration is not implemented (ignored)."))
- res)
- (t
- (let ((what (first spec)))
- (cond ((member what *standard-type-names*)
- (process-type-declaration spec res vars))
- ((and (not (and (symbolp what)
- (string= (symbol-name what) "CLASS"))) ; pcl hack
- (or (info :type :kind what)
- (and (consp what) (info :type :translator (car what)))))
-;;; MNA - abbreviated declaration bug
-;; (unless (policy nil (= brevity 3))
- ;; FIXME: Is it ANSI to warn about this? I think not.
-;; (compiler-note "abbreviated type declaration: ~S." spec))
- (process-type-declaration spec res vars))
- ((info :declaration :recognized what)
- res)
- (t
- (compiler-warning "unrecognized declaration ~S" spec)
- res))))))
-
-;;; Use a list of DECLARE forms to annotate the lists of LAMBDA-VAR and
-;;; Functional structures which are being bound. In addition to filling in
-;;; slots in the leaf structures, we return a new LEXENV which reflects
-;;; pervasive special and function type declarations, (NOT)INLINE declarations
-;;; and OPTIMIZE declarations. CONT is the continuation affected by VALUES
-;;; declarations.
+(defun process-1-decl (raw-spec res vars fvars cont)
+ (declare (type list raw-spec vars fvars))
+ (declare (type lexenv res))
+ (declare (type continuation cont))
+ (let ((spec (canonized-decl-spec raw-spec)))
+ (case (first spec)
+ (special (process-special-decl spec res vars))
+ (ftype
+ (unless (cdr spec)
+ (compiler-error "No type specified in FTYPE declaration: ~S" spec))
+ (process-ftype-decl (second spec) res (cddr spec) fvars))
+ ((inline notinline maybe-inline)
+ (process-inline-decl spec res fvars))
+ ((ignore ignorable)
+ (process-ignore-decl spec vars fvars)
+ res)
+ (optimize
+ (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
+ (if *suppress-values-declaration*
+ res
+ (let ((types (cdr spec)))
+ (do-the-stuff (if (eql (length types) 1)
+ (car types)
+ `(values ,@types))
+ cont res 'values))))
+ (dynamic-extent
+ (when (policy nil (> speed inhibit-warnings))
+ (compiler-note
+ "compiler limitation:~
+ ~% There's no special support for DYNAMIC-EXTENT (so it's ignored)."))
+ res)
+ (t
+ (unless (info :declaration :recognized (first spec))
+ (compiler-warning "unrecognized declaration ~S" raw-spec))
+ res))))
+
+;;; Use a list of DECLARE forms to annotate the lists of LAMBDA-VAR
+;;; and FUNCTIONAL structures which are being bound. In addition to
+;;; filling in slots in the leaf structures, we return a new LEXENV
+;;; which reflects pervasive special and function type declarations,
+;;; (NOT)INLINE declarations and OPTIMIZE declarations. CONT is the
+;;; continuation affected by VALUES declarations.
;;;
-;;; This is also called in main.lisp when PROCESS-FORM handles a use of
-;;; LOCALLY.
+;;; This is also called in main.lisp when PROCESS-FORM handles a use
+;;; of LOCALLY.
(defun process-decls (decls vars fvars cont &optional (env *lexenv*))
(declare (list decls vars fvars) (type continuation cont))
(dolist (decl decls)
(compiler-error "malformed declaration specifier ~S in ~S"
spec
decl))
- (setq env (process-1-declaration spec env vars fvars cont))))
+ (setq env (process-1-decl spec env vars fvars cont))))
env)
-;;; Return the Specvar for Name to use when we see a local SPECIAL
+;;; Return the SPECVAR for NAME to use when we see a local SPECIAL
;;; declaration. If there is a global variable of that name, then
;;; check that it isn't a constant and return it. Otherwise, create an
;;; anonymous GLOBAL-VAR.
(note-lexical-binding name)
(make-lambda-var :name name)))))
-;;; Make the keyword for a keyword arg, checking that the keyword
-;;; isn't already used by one of the Vars. We also check that the
-;;; keyword isn't the magical :allow-other-keys.
+;;; Make the default keyword for a &KEY arg, checking that the keyword
+;;; isn't already used by one of the VARS. We also check that the
+;;; keyword isn't the magical :ALLOW-OTHER-KEYS.
(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")
symbol)))
(when (eq key :allow-other-keys)
- (compiler-error "No keyword arg can be called :ALLOW-OTHER-KEYS."))
+ (compiler-error "No &KEY arg can be called :ALLOW-OTHER-KEYS."))
(dolist (var vars)
(let ((info (lambda-var-arg-info var)))
(when (and info
(eq (arg-info-kind info) :keyword)
- (eq (arg-info-keyword info) key))
+ (eq (arg-info-key info) key))
(compiler-error
"The keyword ~S appears more than once in the lambda-list."
key))))
key))
-;;; Parse a lambda-list into a list of Var structures, stripping off
+;;; Parse a lambda-list into a list of VAR structures, stripping off
;;; any aux bindings. Each arg name is checked for legality, and
;;; duplicate names are checked for. If an arg is globally special,
-;;; the var is marked as :special instead of :lexical. Keyword,
-;;; optional and rest args are annotated with an arg-info structure
+;;; the var is marked as :SPECIAL instead of :LEXICAL. &KEY,
+;;; &OPTIONAL and &REST args are annotated with an ARG-INFO structure
;;; which contains the extra information. If we hit something losing,
-;;; we bug out with Compiler-Error. These values are returned:
-;;; 1. A list of the var structures for each top-level argument.
-;;; 2. A flag indicating whether &key was specified.
-;;; 3. A flag indicating whether other keyword args are allowed.
-;;; 4. A list of the &aux variables.
-;;; 5. A list of the &aux values.
+;;; we bug out with COMPILER-ERROR. These values are returned:
+;;; 1. a list of the var structures for each top-level argument;
+;;; 2. a flag indicating whether &KEY was specified;
+;;; 3. a flag indicating whether other &KEY args are allowed;
+;;; 4. a list of the &AUX variables; and
+;;; 5. a list of the &AUX values.
(declaim (ftype (function (list) (values list boolean boolean list list))
find-lambda-vars))
(defun find-lambda-vars (list)
(names-so-far)
(aux-vars)
(aux-vals))
- ;; Parse-Default deals with defaults and supplied-p args for optionals
- ;; and keywords args.
- (flet ((parse-default (spec info)
+ (flet (;; PARSE-DEFAULT deals with defaults and supplied-p args
+ ;; for optionals and keywords args.
+ (parse-default (spec info)
(when (consp (cdr spec))
(setf (arg-info-default info) (second spec))
(when (consp (cddr spec))
(let ((var (varify-lambda-arg spec (names-so-far))))
(setf (lambda-var-arg-info var)
(make-arg-info :kind :keyword
- :keyword (make-keyword-for-arg spec
- (vars)
- t)))
+ :key (make-keyword-for-arg spec
+ (vars)
+ t)))
(vars var)
(names-so-far spec)))
((atom (first spec))
(var (varify-lambda-arg name (names-so-far)))
(info (make-arg-info
:kind :keyword
- :keyword (make-keyword-for-arg name (vars) t))))
+ :key (make-keyword-for-arg name (vars) t))))
(setf (lambda-var-arg-info var) info)
(vars var)
(names-so-far name)
(t
(let ((head (first spec)))
(unless (proper-list-of-length-p head 2)
- (error "malformed keyword arg specifier: ~S" spec))
+ (error "malformed &KEY argument specifier: ~S" spec))
(let* ((name (second head))
(var (varify-lambda-arg name (names-so-far)))
(info (make-arg-info
:kind :keyword
- :keyword (make-keyword-for-arg (first head)
- (vars)
- nil))))
+ :key (make-keyword-for-arg (first head)
+ (vars)
+ nil))))
(setf (lambda-var-arg-info var) info)
(vars var)
(names-so-far name)
(values (vars) keyp allowp (aux-vars) (aux-vals))))))
-;;; Similar to IR1-Convert-Progn-Body except that we 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.
+;;; This is similar to IR1-CONVERT-PROGN-BODY except that we
+;;; 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 implicit aux bindings introduced by
-;;; keyword bindings, this is always true. It is only false when LET* directly
-;;; calls this function.
+;;; 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)
(declare (type continuation start cont) (list body aux-vars aux-vals))
(if (null aux-vars)
(reference-leaf start fun-cont fun)
(let ((*lexenv* (if interface
(make-lexenv
- :cookie (make-interface-cookie *lexenv*))
+ :policy (make-interface-policy *lexenv*))
*lexenv*)))
(ir1-convert-combination-args fun-cont cont
(list (first aux-vals))))))
(values))
-;;; Similar to IR1-Convert-Progn-Body except that code to bind the Specvar
-;;; for each Svar to the value of the variable is wrapped around the body. If
-;;; there are no special bindings, we just convert the body, otherwise we do
-;;; one special binding and recurse on the rest.
+;;; This is similar to IR1-CONVERT-PROGN-BODY except that code to bind
+;;; the SPECVAR for each SVAR to the value of the variable is wrapped
+;;; around the body. If there are no special bindings, we just convert
+;;; the body, otherwise we do one special binding and recurse on the
+;;; rest.
;;;
-;;; We make a cleanup and introduce it into the lexical environment. If
-;;; there are multiple special bindings, the cleanup for the blocks 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.
+;;; We make a cleanup and introduce it into the lexical environment.
+;;; If there are multiple special bindings, the cleanup for the blocks
+;;; 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)
(declare (type continuation start cont)
(values))
;;; Create a lambda node out of some code, returning the result. The
-;;; bindings are specified by the list of var structures Vars. We deal
-;;; with adding the names to the Lexenv-Variables for the conversion.
-;;; The result is added to the New-Functions in the
-;;; *Current-Component* and linked to the component head and tail.
+;;; bindings are specified by the list of VAR structures VARS. We deal
+;;; with adding the names to the LEXENV-VARIABLES for the conversion.
+;;; The result is added to the NEW-FUNCTIONS in the
+;;; *CURRENT-COMPONENT* and linked to the component head and tail.
;;;
-;;; We detect special bindings here, replacing the original Var in the
+;;; We detect special bindings here, replacing the original VAR in the
;;; lambda list with a temporary variable. We then pass a list of the
-;;; special vars to IR1-Convert-Special-Bindings, which actually emits
+;;; special vars to IR1-CONVERT-SPECIAL-BINDINGS, which actually emits
;;; the special binding code.
;;;
-;;; We ignore any Arg-Info in the Vars, trusting that someone else is
+;;; We ignore any ARG-INFO in the VARS, trusting that someone else is
;;; dealing with &nonsense.
;;;
-;;; 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.)
+;;; 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)
(declare (list body vars aux-vars aux-vals)
lambda))
;;; Create the actual entry-point function for an optional entry
-;;; point. The lambda binds copies of each of the Vars, then calls Fun
-;;; with the argument Vals and the Defaults. Presumably the Vals refer
-;;; to the Vars by name. The Vals are passed in in reverse order.
+;;; point. The lambda binds copies of each of the VARS, then calls FUN
+;;; with the argument VALS and the DEFAULTS. Presumably the VALS refer
+;;; to the VARS by name. The VALS are passed in in reverse order.
;;;
;;; If any of the copies of the vars are referenced more than once,
-;;; then we mark the corresponding var as Ever-Used to inhibit
+;;; 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.
;;;
:where-from (leaf-where-from var)
:specvar (lambda-var-specvar var)))
fvars))
- (*lexenv* (make-lexenv :cookie (make-interface-cookie *lexenv*)))
+ (*lexenv* (make-lexenv :policy (make-interface-policy *lexenv*)))
(fun
(ir1-convert-lambda-body
`((%funcall ,fun ,@(reverse vals) ,@defaults))
;;; This function deals with supplied-p vars in optional arguments. If
;;; the there is no supplied-p arg, then we just call
-;;; IR1-Convert-Hairy-Args on the remaining arguments, and generate a
+;;; IR1-CONVERT-HAIRY-ARGS on the remaining arguments, and generate a
;;; optional entry that calls the result. If there is a supplied-p
;;; var, then we add it into the default vars and throw a T into the
;;; entry values. The resulting entry point function is returned.
(list (arg-info-default info) nil)
(list (arg-info-default info))))))
-;;; Create the More-Entry function for the Optional-Dispatch Res.
-;;; Entry-Vars and Entry-Vals describe the fixed arguments. Rest is the var
-;;; for any Rest arg. Keys is a list of the keyword arg vars.
+;;; Create the MORE-ENTRY function for the OPTIONAL-DISPATCH RES.
+;;; ENTRY-VARS and ENTRY-VALS describe the fixed arguments. REST is
+;;; the var for any &REST arg. KEYS is a list of the &KEY arg vars.
;;;
-;;; The most interesting thing that we do is parse keywords. We create a
-;;; bunch of temporary variables to hold the result of the parse, and then loop
-;;; over the supplied arguments, setting the appropriate temps for the supplied
-;;; keyword. Note that it is significant that we iterate over the keywords in
-;;; reverse order --- this implements the CL requirement that (when a keyword
-;;; appears more than once) the first value is used.
+;;; The most interesting thing that we do is parse keywords. We create
+;;; a bunch of temporary variables to hold the result of the parse,
+;;; and then loop over the supplied arguments, setting the appropriate
+;;; temps for the supplied keyword. Note that it is significant that
+;;; we iterate over the keywords in reverse order --- this implements
+;;; the CL requirement that (when a keyword appears more than once)
+;;; the first value is used.
;;;
;;; If there is no supplied-p var, then we initialize the temp to the
-;;; default and just pass the temp into the main entry. Since non-constant
-;;; keyword args are forcibly given a supplied-p var, we know that the default
-;;; is constant, and thus safe to evaluate out of order.
+;;; default and just pass the temp into the main entry. Since
+;;; non-constant &KEY args are forcibly given a supplied-p var, we
+;;; know that the default is constant, and thus safe to evaluate out
+;;; of order.
;;;
-;;; If there is a supplied-p var, then we create temps for both the value
-;;; and the supplied-p, and pass them into the main entry, letting it worry
-;;; about defaulting.
+;;; If there is a supplied-p var, then we create temps for both the
+;;; value and the supplied-p, and pass them into the main entry,
+;;; letting it worry about defaulting.
;;;
-;;; We deal with :allow-other-keys by delaying unknown keyword errors until
-;;; we have scanned all the keywords.
+;;; 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
(n-count (gensym "N-COUNT-"))
(count-temp (make-lambda-var :name n-count
:type (specifier-type 'index)))
- (*lexenv* (make-lexenv :cookie (make-interface-cookie *lexenv*))))
+ (*lexenv* (make-lexenv :policy (make-interface-policy *lexenv*))))
(arg-vars context-temp count-temp)
(dolist (key keys)
(let* ((info (lambda-var-arg-info key))
(default (arg-info-default info))
- (keyword (arg-info-keyword info))
+ (keyword (arg-info-key info))
(supplied-p (arg-info-supplied-p info))
(n-value (gensym "N-VALUE-")))
(temps `(,n-value ,default))
(let ((n-supplied (gensym "N-SUPPLIED-")))
(temps n-supplied)
(arg-vals n-value n-supplied)
- ;; MNA: non-self-eval-keyword patch
(tests `((eq ,n-key ',keyword)
(setq ,n-supplied t)
(setq ,n-value ,n-value-temp)))))
(t
(arg-vals n-value)
- ;; MNA: non-self-eval-keyword patch
(tests `((eq ,n-key ',keyword)
(setq ,n-value ,n-value-temp)))))))
(body
`(when (oddp ,n-count)
- (%odd-keyword-arguments-error)))
+ (%odd-key-arguments-error)))
(body
`(locally
(unless allowp
(body `(when (and ,n-losep (not ,n-allowp))
- (%unknown-keyword-argument-error ,n-losep)))))))
+ (%unknown-key-argument-error ,n-losep)))))))
(let ((ep (ir1-convert-lambda-body
`((let ,(temps)
(values))
-;;; Called by IR1-Convert-Hairy-Args when we run into a rest or
-;;; keyword 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 the
-;;; keyword argument vars.
+;;; 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
+;;; the &KEY argument vars.
;;;
-;;; When there are keyword arguments, we introduce temporary gensym
+;;; When there are &KEY arguments, we introduce temporary gensym
;;; variables to hold the values while keyword defaulting is in
;;; progress to get the required sequential binding semantics.
;;;
-;;; This gets interesting mainly when there are keyword arguments with
+;;; This gets interesting mainly when there are &KEY arguments with
;;; supplied-p vars or non-constant defaults. In either case, pass in
;;; a supplied-p var. If the default is non-constant, we introduce an
;;; IF in the main entry that tests the supplied-p var and decides
;;; 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 keyword arg, we punt out to
-;;; IR1-Convert-More, which finishes for us in this case.
+;;; When we run into a &REST or &KEY arg, we punt out to
+;;; IR1-CONVERT-MORE, which finishes for us in this case.
(defun ir1-convert-hairy-args (res default-vars default-vals
entry-vars entry-vals
vars supplied-p-p body aux-vars
(prev-link entry start)
(use-continuation entry dummy)
- ;; MNA - Re: two obscure bugs in CMU CL
(let* ((env-entry (list entry cont))
- (*lexenv*
- (make-lexenv :blocks (list (cons name env-entry))
- :cleanup cleanup)))
+ (*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))))
(prev-link exit value-cont)
(use-continuation exit (second found))))
-;;; Return a list of the segments of a tagbody. Each segment looks
+;;; Return a list of the segments of a TAGBODY. Each segment looks
;;; like (<tag> <form>* (go <next tag>)). That is, we break up the
;;; tagbody into segments of non-tag statements, and explicitly
;;; represent the drop-through with a GO. The first segment has a
(collect ((segments))
(let ((current (cons nil body)))
(loop
- (let ((tag-pos (position-if-not #'listp current :start 1)))
+ (let ((tag-pos (position-if (complement #'listp) current :start 1)))
(unless tag-pos
(segments `(,@current nil))
(return))
(conts))
(starts dummy)
(dolist (segment (rest segments))
- ;; MNA - Re: two obscure bugs
(let* ((tag-cont (make-continuation))
(tag (list (car segment) entry tag-cont)))
(conts tag-cont)
(starts tag-cont)
(continuation-starts-block tag-cont)
(tags tag)
- (push (cdr tag) (continuation-lexenv-uses tag-cont))
- ))
+ (push (cdr tag) (continuation-lexenv-uses tag-cont))))
(conts cont)
(let ((*lexenv* (make-lexenv :cleanup cleanup :tags (tags))))
;;; 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.
+;;; not* EVAL since some enclosing EVAL-WHEN already did.
;;;
;;; 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
(not sb!eval::*already-evaled-this*)))
(sb!eval::*already-evaled-this* t))
(when do-eval
- (eval `(progn ,@body)))
+
+ ;; 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)))
"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."
- (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
+ ;; 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))
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)))
- ;;; MNA: locally patch - #'ir1-convert-progn-body gets called anyway!
- (ir1-convert-progn-body start cont forms))))
+ (ir1-convert-aux-bindings start cont forms nil nil nil))))
\f
;;;; FLET and LABELS
\f
;;;; THE
-;;; 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
+;;; 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.
;;;
;;; 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
+;;; 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
(when (null (find-uses cont))
(setf (continuation-asserted-type cont) new))
(when (and (not intersects)
- (not (policy nil (= brevity 3)))) ;FIXME: really OK to suppress?
+ (not (policy nil (= 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)
(make-lexenv :type-restrictions `((,cont . ,new))
:default lexenv)))
+;;; 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.
(def-ir1-translator the ((type value) start cont)
- #!+sb-doc
- "THE Type Form
- Assert that Form evaluates to the specified type (which may be a VALUES
- type.)"
(let ((*lexenv* (do-the-stuff type cont *lexenv* 'the)))
(ir1-convert start cont value)))
+;;; 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
- "Truly-The Type Value
- 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."
(declare (inline member))
(let ((type (values-specifier-type type))
(old (find-uses cont)))
;;; 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)
- #!+sb-doc
- "SETQ {Var Value}*
- Set the variables to the values. If more than one pair is supplied, the
- assignments are done sequentially. If Var names a symbol macro, SETF the
- expansion."
(let ((len (length things)))
(when (oddp len)
(compiler-error "odd number of args to SETQ: ~S" source))
(ir1-convert-progn-body start cont (sets)))
(sets `(setq ,(first thing) ,(second thing))))))))
-;;; Kind of like Reference-Leaf, but we generate a Set node. This
-;;; should only need to be called in Setq.
+;;; 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)
(declare (type continuation start cont) (type basic-var var))
(let ((dest (make-continuation)))
`(multiple-value-call #'%throw ,tag ,result)))
;;; This is a special special form used to instantiate a cleanup as
-;;; the current cleanup within the body. Kind is a the kind of cleanup
-;;; to make, and Mess-Up is a form that does the mess-up action. We
-;;; make the MESS-UP be the USE of the Mess-Up form's continuation,
+;;; the current cleanup within the body. KIND is a the kind of cleanup
+;;; to make, and MESS-UP is a form that does the mess-up action. We
+;;; make the MESS-UP be the USE of the MESS-UP form's continuation,
;;; and introduce the cleanup into the lexical environment. We
-;;; back-patch the Entry-Cleanup for the current cleanup to be the new
+;;; back-patch the ENTRY-CLEANUP for the current cleanup to be the new
;;; cleanup, since this inner cleanup is the interesting one.
(def-ir1-translator %within-cleanup ((kind mess-up &body body) start cont)
(let ((dummy (make-continuation))
;;; This is a special special form that makes an "escape function"
;;; which returns unknown values from named block. We convert the
-;;; function, set its kind to :Escape, and then reference it. The
+;;; function, set its kind to :ESCAPE, and then reference it. The
;;; :Escape kind indicates that this function's purpose is to
;;; represent a non-local control transfer, and that it might not
;;; actually have to be compiled.
;;;
;;; Note that environment analysis replaces references to escape
-;;; functions with references to the corresponding NLX-Info structure.
+;;; functions with references to the corresponding NLX-INFO structure.
(def-ir1-translator %escape-function ((tag) start cont)
(let ((fun (ir1-convert-lambda
`(lambda ()
(reference-leaf start cont fun)))
;;; Yet another special special form. This one looks up a local
-;;; function and smashes it to a :Cleanup function, as well as
+;;; 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)))
;;; 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.
+;;; cleanup using %WITHIN-CLEANUP.
(def-ir1-translator catch ((tag &body body) start cont)
#!+sb-doc
"Catch Tag Form*
;;; UNWIND-PROTECT is similar to CATCH, but more hairy. We make the
;;; cleanup forms into a local function so that they can be referenced
;;; both in the case where we are unwound and in any local exits. We
-;;; use %Cleanup-Function on this to indicate that reference by
-;;; %Unwind-Protect isn't "real", and thus doesn't cause creation of
+;;; use %CLEANUP-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
;;;; multiple-value stuff
;;; If there are arguments, MULTIPLE-VALUE-CALL turns into an
-;;; MV-Combination.
+;;; MV-COMBINATION.
;;;
;;; If there are no arguments, then we convert to a normal
-;;; combination, ensuring that a MV-Combination always has at least
+;;; 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.
+;;; 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*
(use-continuation node cont)
(setf (basic-combination-args node) (arg-conts))))))
-;;; Multiple-Value-Prog1 is represented implicitly in IR1 by having a
+;;; MULTIPLE-VALUE-PROG1 is represented implicitly in IR1 by having a
;;; the result code use result continuation (CONT), but transfer
;;; control to the evaluation of the body. In other words, the result
-;;; continuation isn't Immediately-Used-P by the nodes that compute
+;;; continuation isn't IMMEDIATELY-USED-P by the nodes that compute
;;; the result.
;;;
;;; In order to get the control flow right, we convert the result with
;;; a dummy result continuation, then convert all the uses of the
-;;; dummy to be uses of CONT. If a use is an Exit, then we also
-;;; substitute CONT for the dummy in the corresponding Entry node so
+;;; dummy to be uses of CONT. If a use is an EXIT, then we also
+;;; substitute CONT for the dummy in the corresponding ENTRY node so
;;; that they are consistent. Note that this doesn't amount to
;;; changing the exit target, since the control destination of an exit
;;; is determined by the block successor; we are just indicating the
;;; Note that we both exploit and maintain the invariant that the CONT
;;; to an IR1 convert method either has no block or starts the block
;;; that control should transfer to after completion for the form.
-;;; Nested MV-Prog1's work because during conversion of the result
+;;; Nested MV-PROG1's work because during conversion of the result
;;; form, we use dummy continuation whose block is the true control
;;; destination.
(def-ir1-translator multiple-value-prog1 ((result &rest forms) start cont)
\f
;;;; interface to defining macros
-;;;; DEFMACRO, DEFUN and DEFCONSTANT 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.
+;;;; 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.
+;;; 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.
(defun revert-source-path (name)
(compiler-error "The special form ~S can't be redefined as a macro."
name)))
- (setf (info :function :kind name) :macro)
- (setf (info :function :where-from name) :defined)
-
- (when *compile-time-define-macros*
- (setf (info :function :macro-function name)
- (coerce def 'function)))
+ (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 name)))
(ir1-convert start cont `(%%defmacro ',name ,fun ,doc)))
(when sb!xc:*compile-print*
- ;; MNA compiler message patch
+ ;; 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))) ; Don't want to make a function just yet...
+ (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))
- (when *compile-time-define-macros*
- (setf (info :function :compiler-macro-function name)
- (coerce def 'function)))
+ (setf (info :function :compiler-macro-function name)
+ (coerce def 'function))
(let* ((*current-path* (revert-source-path 'define-compiler-macro))
(fun (ir1-convert-lambda def name)))
(ir1-convert start cont `(%%define-compiler-macro ',name ,fun ,doc)))
(when sb!xc:*compile-print*
- ;; MNA compiler message patch
(compiler-mumble "~&; converted ~S~%" name))))
-
-;;; Update the global environment to correspond to the new definition.
-(def-ir1-translator %defconstant ((name value doc) start cont
- :kind :function)
- (let ((name (eval name))
- (newval (eval value)))
- (unless (symbolp name)
- (compiler-error "constant name not a symbol: ~S" name))
- (when (eq name t)
- (compiler-error "The value of T can't be changed."))
- (when (eq name nil)
- (compiler-error "Nihil ex nihil. (can't change NIL)"))
- (when (keywordp name)
- (compiler-error "Keyword values can't be changed."))
-
- (let ((kind (info :variable :kind name)))
- (case kind
- (:constant
- ;; Note: This behavior (disparaging any non-EQL modification)
- ;; is unpopular, but it is specified by ANSI (i.e. ANSI says
- ;; a non-EQL change has undefined consequences). I think it's
- ;; a bad idea to encourage nonconforming programming style
- ;; even if it's convenient. If people really want things
- ;; which are constant in some sense other than EQL, I suggest
- ;; either just using DEFVAR (which is what I generally do),
- ;; or defining something like this (untested) code:
- ;; (DEFMACRO DEFCONSTANT-EQX (SYMBOL EXPR EQX &OPTIONAL DOC)
- ;; "This macro is to be used instead of DEFCONSTANT for values
- ;; which are appropriately compared using the function given by
- ;; the EQX argument instead of EQL."
- ;; (LET ((EXPR-TMP (GENSYM "EXPR-TMP-")))
- ;; `(EVAL-WHEN (:COMPILE-TOPLEVEL :LOAD-TOPLEVEL :EXECUTE)
- ;; (LET ((,EXPR-TMP ,EXPR))
- ;; (UNLESS (AND (BOUNDP ,SYMBOL)
- ;; (CONSTANTP ,SYMBOL)
- ;; (FUNCALL ,EQX
- ;; (SYMBOL-VALUE ,SYMBOL)
- ;; ,EXPR-TMP))
- ;; (DEFCONSTANT ,SYMBOL ,EXPR ,@(WHEN DOC `(,DOC))))))))
- ;; I prefer using DEFVAR, though, first because it's trivial,
- ;; and second because using DEFCONSTANT lets the compiler
- ;; optimize code by removing indirection, copying the current
- ;; value of the constant directly into the code, and for
- ;; consed data structures, this optimization can become a
- ;; pessimization. (And consed data structures are exactly
- ;; where you'd be tempted to use DEFCONSTANT-EQX.) Why is
- ;; this a pessimization? It does remove a layer of
- ;; indirection, but it makes it hard for the system's
- ;; load/dump logic to see that all references to the consed
- ;; data structure refer to the same (EQ) object. If you use
- ;; something like DEFCONSTANT-EQX, you'll tend to get one
- ;; copy of the data structure bound to the symbol, and one
- ;; more copy for each file where code refers to the constant.
- ;; If you're moderately clever with MAKE-LOAD-FORM, you might
- ;; be able to make the copy bound to the symbol at load time
- ;; be EQ to the references in code in the same file, but it
- ;; seems to be rather tricky to force code in different files
- ;; to refer the same copy without doing the DEFVAR thing of
- ;; indirection through a symbol. -- WHN 2000-11-02
- (unless (eql newval
- (info :variable :constant-value name))
- (compiler-warning "redefining constant ~S as:~% ~S" name newval)))
- (:global)
- (t
- (compiler-warning "redefining ~(~A~) ~S to be a constant"
- kind
- name))))
-
- (setf (info :variable :kind name) :constant)
- (setf (info :variable :where-from name) :defined)
- (setf (info :variable :constant-value name) newval)
- (remhash name *free-variables*))
-
- (ir1-convert start cont `(%%defconstant ,name ,value ,doc)))
\f
;;;; defining global functions
`(,(car x) .
(macro . ,(coerce (cdr x) 'function))))
macros)
- :cookie (lexenv-cookie *lexenv*)
- :interface-cookie (lexenv-interface-cookie *lexenv*))))
+ :policy (lexenv-policy *lexenv*)
+ :interface-policy (lexenv-interface-policy *lexenv*))))
(ir1-convert-lambda `(lambda ,@body) name))))
;;; Return a lambda that has been "closed" with respect to ENV,
(global-var
(when (defined-function-p what)
(push `(,(car (rassoc (defined-function-inlinep what)
- inlinep-translations))
+ *inlinep-translations*))
,name)
decls)))
(t (return t))))))
;;; Check a new global function definition for consistency with
;;; previous declaration or definition, and assert argument/result
-;;; types if appropriate. This this assertion is suppressed by the
+;;; types if appropriate. This assertion is suppressed by the
;;; EXPLICIT-CHECK attribute, which is specified on functions that
;;; check their argument types as a consequence of type dispatching.
;;; This avoids redundant checks such as NUMBERP on the args to +,
(info (info :function :info (leaf-name var))))
(assert-definition-type
fun type
- :error-function #'compiler-warning
- :warning-function (cond (info #'compiler-warning)
+ ;; KLUDGE: Common Lisp is such a dynamic language that in general
+ ;; all we can do here in general is issue a STYLE-WARNING. It
+ ;; would be nice to issue a full WARNING in the special case of
+ ;; of type mismatches within a compilation unit (as in section
+ ;; 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)
(t nil))
:really-assert
(*current-path* (revert-source-path 'defun))
(expansion (unless (eq (info :function :inlinep name) :notinline)
(inline-syntactic-closure-lambda lambda))))
- ;; If not in a simple environment or NOTINLINE, then discard any forward
- ;; references to this function.
+ ;; If not in a simple environment or NOTINLINE, then discard any
+ ;; forward references to this function.
(unless expansion (remhash name *free-functions*))
(let* ((var (get-defined-function name))
expansion)))
(setf (defined-function-inline-expansion var) expansion)
(setf (info :function :inline-expansion name) save-expansion)
- ;; If there is a type from a previous definition, blast it, since it is
- ;; obsolete.
+ ;; If there is a type from a previous definition, blast it,
+ ;; since it is obsolete.
(when (eq (leaf-where-from var) :defined)
(setf (leaf-type var) (specifier-type 'function)))
,@(when save-expansion `(',save-expansion)))))
(when sb!xc:*compile-print*
- ;; MNA compiler message patch
(compiler-mumble "~&; converted ~S~%" name))))))
projects / sbcl.git / blobdiff