;;; 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)
: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)
+(defun process-inline-decl (spec res fvars)
(let ((sense (cdr (assoc (first spec) *inlinep-translations* :test #'eq)))
(new-fenv ()))
(dolist (name (rest spec))
;;; 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)
+(defun process-1-decl (raw-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
- :policy (process-optimize-declaration spec (lexenv-policy res))))
- (optimize-interface
- (make-lexenv
- :default res
- :interface-policy (process-optimize-declaration
- spec
- (lexenv-interface-policy res))))
- (type
- (process-type-declaration (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
- "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)))))
- (process-type-declaration spec res vars))
- ((info :declaration :recognized what)
- res)
- (t
- (compiler-warning "unrecognized declaration ~S" spec)
- res))))))
+ (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
(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.
;;; 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
+;;; 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)
(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))
;;; 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
projects / sbcl.git / blobdiff