were silently accepted).
* minor incompatible change: COMPILE-FILE now uses the freedom
afforded (ANSI 3.2.2.3) to use derived function types for
- functions defined in the same file. This also permits the system
- to warn on static type mismatches and function redefinition.
+ functions defined in the same file. This also permits the system
+ to warn on static type mismatches and function
+ redefinition. (Currently it does not work with high DEBUG level.)
* changes in type checking closed the following bugs:
** type checking of unused values (192b, 194d, 203);
** template selection based on unsafe type assertions (192c, 236);
** type checking in branches (194bc).
* VALUES declaration is disabled.
- * a short form of VALUES type specifier has ANSI meaning.
+ * a short form of VALUES type specifier has ANSI meaning (it has
+ increased the number of situations when SBCL cannot perform type
+ checking).
* fixed bug in DEFSTRUCT: once again, naming structure slots with
keywords or constants is permissible.
* STREAM-READ-SEQUENCE and STREAM-WRITE-SEQUENCE now have methods
(unless (or defaults boas)
(push (symbolicate "MAKE-" (dd-name defstruct)) defaults))
- (collect ((res))
+ (collect ((res) (names))
(when defaults
- (let ((cname (first defaults)))
- (setf (dd-default-constructor defstruct) cname)
- (res (create-keyword-constructor defstruct creator))
- (dolist (other-name (rest defaults))
- (res `(setf (fdefinition ',other-name) (fdefinition ',cname)))
- (res `(declaim (ftype function ',other-name))))))
+ (let ((cname (first defaults)))
+ (setf (dd-default-constructor defstruct) cname)
+ (res (create-keyword-constructor defstruct creator))
+ (names cname)
+ (dolist (other-name (rest defaults))
+ (res `(setf (fdefinition ',other-name) (fdefinition ',cname)))
+ (names other-name))))
(dolist (boa boas)
- (res (create-boa-constructor defstruct boa creator)))
+ (res (create-boa-constructor defstruct boa creator))
+ (names (first boa)))
+
+ (res `(declaim (ftype
+ (sfunction *
+ ,(if (eq (dd-type defstruct) 'structure)
+ (dd-name defstruct)
+ '*))
+ ,@(names))))
(res))))
\f
;;; The name is slightly misleading, since some cases are memoized, so
;;; we might reuse a value which was made earlier instead of creating
;;; a new one from scratch.
-(declaim (ftype (function (t) function) typespec-typecheckfun))
+(declaim (ftype (sfunction (t) function) typespec-typecheckfun))
(defun typespec-typecheckfun (typespec)
;; a general-purpose default case, hopefully overridden by the
;; DEFINE-COMPILER-MACRO implementation
(when (policy cast (>= safety inhibit-warnings))
(compiler-note
"type assertion too complex to check:~% ~S."
- (type-specifier (cast-asserted-type cast)))))
+ (type-specifier (coerce-to-values (cast-asserted-type cast))))))
(setf (cast-type-to-check cast) *wild-type*)
(setf (cast-%type-check cast) nil)))))))
(values))
;;;
;;; Due to the lack of a (LIST X) type specifier, we can't reconstruct
;;; the &REST type.
-(declaim (ftype (function (functional) fun-type) definition-type))
+(declaim (ftype (sfunction (functional) fun-type) definition-type))
(defun definition-type (functional)
(if (lambda-p functional)
(make-fun-type
(format stream "~S ~S" (type-of leaf) (functional-debug-name leaf)))))
;;; Attempt to find a block given some thing that has to do with it.
-(declaim (ftype (function (t) cblock) block-or-lose))
+(declaim (ftype (sfunction (t) cblock) block-or-lose))
(defun block-or-lose (thing)
(ctypecase thing
(cblock thing)
;;; FIXME: This function seems to have a lot in common with
;;; STRINGIFY-FORM, and perhaps there's some way to merge the two
;;; functions.
+(declaim (ftype (sfunction (string &rest t) string) debug-namify))
(defun debug-namify (format-string &rest format-arguments)
(with-standard-io-syntax
(let ((*print-readably* nil)
(append aux-vars vars)
nil result-cont))
(forms (if (and *allow-debug-catch-tag*
- (policy *lexenv* (> debug (max speed space))))
+ (policy *lexenv* (= insert-debug-catch 3)))
`((catch (make-symbol "SB-DEBUG-CATCH-TAG")
,@forms))
forms))
;;; names a macro or special form, then we error out using the
;;; supplied context which indicates what we were trying to do that
;;; demanded a function.
-(declaim (ftype (function (t string) global-var) find-free-fun))
+(declaim (ftype (sfunction (t string) global-var) find-free-fun))
(defun find-free-fun (name context)
(or (let ((old-free-fun (gethash name *free-funs*)))
(and (not (invalid-free-fun-p old-free-fun))
;;; Return the LEAF structure for the lexically apparent function
;;; definition of NAME.
-(declaim (ftype (function (t string) leaf) find-lexically-apparent-fun))
+(declaim (ftype (sfunction (t string) leaf) find-lexically-apparent-fun))
(defun find-lexically-apparent-fun (name context)
(let ((var (lexenv-find name funs :test #'equal)))
(cond (var
;;; corresponding value. Otherwise, we make a new leaf using
;;; information from the global environment and enter it in
;;; *FREE-VARS*. If the variable is unknown, then we emit a warning.
-(declaim (ftype (function (t) (or leaf cons heap-alien-info)) find-free-var))
+(declaim (ftype (sfunction (t) (or leaf cons heap-alien-info)) find-free-var))
(defun find-free-var (name)
(unless (symbolp name)
(compiler-error "Variable name is not a symbol: ~S." name))
;; the creation using backquote of forms that contain leaf
;; references, without having to introduce dummy names into the
;; namespace.
- (declaim (ftype (function (continuation continuation t) (values)) ir1-convert))
+ (declaim (ftype (sfunction (continuation continuation t) (values)) ir1-convert))
(defun ir1-convert (start cont form)
(ir1-error-bailout (start cont form)
(let ((*current-path* (or (gethash form *source-paths*)
;;; Convert a bunch of forms, discarding all the values except the
;;; last. If there aren't any forms, then translate a NIL.
-(declaim (ftype (function (continuation continuation list) (values))
+(declaim (ftype (sfunction (continuation continuation list) (values))
ir1-convert-progn-body))
(defun ir1-convert-progn-body (start cont body)
(if (endp body)
;;; Convert a function call where the function FUN is a LEAF. FORM is
;;; the source for the call. We return the COMBINATION node so that
;;; the caller can poke at it if it wants to.
-(declaim (ftype (function (continuation continuation list leaf) combination)
+(declaim (ftype (sfunction (continuation continuation list leaf) combination)
ir1-convert-combination))
(defun ir1-convert-combination (start cont form fun)
(let ((fun-cont (make-continuation)))
;;; LAMBDA-VAR for that name, or NIL if it isn't found. We return the
;;; *last* variable with that name, since LET* bindings may be
;;; duplicated, and declarations always apply to the last.
-(declaim (ftype (function (list symbol) (or lambda-var list))
+(declaim (ftype (sfunction (list symbol) (or lambda-var list))
find-in-bindings))
(defun find-in-bindings (vars name)
(let ((found nil))
;;;; continuation use hacking
;;; Return a list of all the nodes which use Cont.
-(declaim (ftype (function (continuation) list) find-uses))
+(declaim (ftype (sfunction (continuation) list) find-uses))
(defun find-uses (cont)
(ecase (continuation-kind cont)
((:block-start :deleted-block-start)
;;; Note: if you call this function, you may have to do a
;;; REOPTIMIZE-CONTINUATION to inform IR1 optimization that something
;;; has changed.
-(declaim (ftype (function (node) (values)) delete-continuation-use))
+(declaim (ftype (sfunction (node) (values)) delete-continuation-use))
(defun delete-continuation-use (node)
(let* ((cont (node-cont node))
(block (continuation-block cont)))
;;; Note: if you call this function, you may have to do a
;;; REOPTIMIZE-CONTINUATION to inform IR1 optimization that something
;;; has changed.
-(declaim (ftype (function (node continuation) (values)) add-continuation-use))
+(declaim (ftype (sfunction (node continuation) (values)) add-continuation-use))
(defun add-continuation-use (node cont)
(aver (not (node-cont node)))
(let ((block (continuation-block cont)))
(when (eq (lambda-home fun) fun)
(return fun))))
+(declaim (ftype (sfunction (node) cblock) node-block))
(defun node-block (node)
- (declare (type node node))
- (the cblock (continuation-block (node-prev node))))
+ (continuation-block (node-prev node)))
+(declaim (ftype (sfunction (node) component) node-component))
(defun node-component (node)
- (declare (type node node))
(block-component (node-block node)))
+(declaim (ftype (sfunction (node) physenv) node-physenv))
(defun node-physenv (node)
- (declare (type node node))
- (the physenv (lambda-physenv (node-home-lambda node))))
+ (lambda-physenv (node-home-lambda node)))
+(declaim (ftype (sfunction (clambda) cblock) lambda-block))
(defun lambda-block (clambda)
- (declare (type clambda clambda))
(node-block (lambda-bind clambda)))
+(declaim (ftype (sfunction (clambda) component) lambda-component))
(defun lambda-component (clambda)
(block-component (lambda-block clambda)))
nil))))
;;; Return the non-LET LAMBDA that holds BLOCK's code.
+(declaim (ftype (sfunction (cblock) clambda) block-home-lambda))
(defun block-home-lambda (block)
- (the clambda
- (block-home-lambda-or-null block)))
+ (block-home-lambda-or-null block))
;;; Return the IR1 physical environment for BLOCK.
+(declaim (ftype (sfunction (cblock) physenv) block-physenv))
(defun block-physenv (block)
- (declare (type cblock block))
(lambda-physenv (block-home-lambda block)))
;;; Return the Top Level Form number of PATH, i.e. the ordinal number
(bug "confused about home lambda for ~S"))))
;;; Return the LAMBDA that is CONT's home.
+(declaim (ftype (sfunction (continuation) clambda)
+ continuation-home-lambda))
(defun continuation-home-lambda (cont)
- (the clambda
- (continuation-home-lambda-or-null cont)))
+ (continuation-home-lambda-or-null cont))
#!-sb-fluid (declaim (inline continuation-single-value-p))
(defun continuation-single-value-p (cont)
;;; Unlink a block from the next/prev chain. We also null out the
;;; COMPONENT.
-(declaim (ftype (function (cblock) (values)) remove-from-dfo))
+(declaim (ftype (sfunction (cblock) (values)) remove-from-dfo))
(defun remove-from-dfo (block)
(let ((next (block-next block))
(prev (block-prev block)))
;;; Set the FLAG for all the blocks in COMPONENT to NIL, except for
;;; the head and tail which are set to T.
-(declaim (ftype (function (component) (values)) clear-flags))
+(declaim (ftype (sfunction (component) (values)) clear-flags))
(defun clear-flags (component)
(let ((head (component-head component))
(tail (component-tail component)))
;;; Make a component with no blocks in it. The BLOCK-FLAG is initially
;;; true in the head and tail blocks.
-(declaim (ftype (function nil component) make-empty-component))
+(declaim (ftype (sfunction () component) make-empty-component))
(defun make-empty-component ()
(let* ((head (make-block-key :start nil :component nil))
(tail (make-block-key :start nil :component nil))
\f
;;;; functional hackery
-(declaim (ftype (function (functional) clambda) main-entry))
+(declaim (ftype (sfunction (functional) clambda) main-entry))
(defun main-entry (functional)
(etypecase functional
(clambda functional)
;;; MV-BIND when it appears in an MV-CALL. All fixed arguments must be
;;; optional with null default and no SUPPLIED-P. There must be a
;;; &REST arg with no references.
-(declaim (ftype (function (functional) boolean) looks-like-an-mv-bind))
+(declaim (ftype (sfunction (functional) boolean) looks-like-an-mv-bind))
(defun looks-like-an-mv-bind (functional)
(and (optional-dispatch-p functional)
(do ((arg (optional-dispatch-arglist functional) (cdr arg)))
;;; return NIL as our second value to indicate this. NODE is used as
;;; the error context for any error message, and CONTEXT is a string
;;; that is spliced into the warning.
-(declaim (ftype (function ((or symbol function) list node function string)
+(declaim (ftype (sfunction ((or symbol function) list node function string)
(values list boolean))
careful-call))
(defun careful-call (function args node warn-fun context)
;;; list of continuations ARGS. It returns the continuation if the
;;; keyword is present, or NIL otherwise. The legality and
;;; constantness of the keywords should already have been checked.
-(declaim (ftype (function (list keyword) (or continuation null))
+(declaim (ftype (sfunction (list keyword) (or continuation null))
find-keyword-continuation))
(defun find-keyword-continuation (args key)
(do ((arg args (cddr arg)))
;;; This function is used by the result of PARSE-DEFTRANSFORM to
;;; verify that alternating continuations in ARGS are constant and
;;; that there is an even number of args.
-(declaim (ftype (function (list) boolean) check-key-args-constant))
+(declaim (ftype (sfunction (list) boolean) check-key-args-constant))
(defun check-key-args-constant (args)
(do ((arg args (cddr arg)))
((null arg) t)
;;; verify that the list of continuations ARGS is a well-formed &KEY
;;; arglist and that only keywords present in the list KEYS are
;;; supplied.
-(declaim (ftype (function (list list) boolean) check-transform-keys))
+(declaim (ftype (sfunction (list list) boolean) check-transform-keys))
(defun check-transform-keys (args keys)
(and (check-key-args-constant args)
(do ((arg args (cddr arg)))
;;;; miscellaneous
;;; Called by the expansion of the EVENT macro.
-(declaim (ftype (function (event-info (or node null)) *) %event))
+(declaim (ftype (sfunction (event-info (or node null)) *) %event))
(defun %event (info node)
(incf (event-info-count info))
(when (and (>= (event-info-level info) *event-note-threshold*)
;;; shared, we copy it. We don't have to copy the lists, since each
;;; function that has generators or transforms has already been
;;; through here.
-(declaim (ftype (function (t) fun-info) fun-info-or-lose))
+(declaim (ftype (sfunction (t) fun-info) fun-info-or-lose))
(defun fun-info-or-lose (name)
(let (;; FIXME: Do we need this rebinding here? It's a literal
;; translation of the old CMU CL rebinding to
3
0)
("no" "maybe" "yes" "yes"))
+
+(define-optimization-quality insert-debug-catch
+ (if (> debug (max speed space))
+ 3
+ 0)
+ ("no" "maybe" "yes" "yes"))
(specifier-type 'base-char))
(defoptimizer (values derive-type) ((&rest values))
- (values-specifier-type
- `(values ,@(mapcar (lambda (x)
- (type-specifier (continuation-type x)))
- values)
- &optional)))
+ (make-values-type :required (mapcar #'continuation-type values)))
\f
;;;; byte operations
;;;;
;;; Destructively add ELEMENT to SET. If ELEMENT was not in the set,
;;; then we return true, otherwise we return false.
-(declaim (ftype (function (sset-element sset) boolean) sset-adjoin))
+(declaim (ftype (sfunction (sset-element sset) boolean) sset-adjoin))
(defun sset-adjoin (element set)
(let ((number (sset-element-number element))
(elements (sset-elements set)))
;;; Destructively remove ELEMENT from SET. If element was in the set,
;;; then return true, otherwise return false.
-(declaim (ftype (function (sset-element sset) boolean) sset-delete))
+(declaim (ftype (sfunction (sset-element sset) boolean) sset-delete))
(defun sset-delete (element set)
(let ((elements (sset-elements set)))
(do ((prev elements current)
(return t)))))
;;; Return true if ELEMENT is in SET, false otherwise.
-(declaim (ftype (function (sset-element sset) boolean) sset-member))
+(declaim (ftype (sfunction (sset-element sset) boolean) sset-member))
(defun sset-member (element set)
(declare (inline member))
(not (null (member element (cdr (sset-elements set)) :test #'eq))))
-(declaim (ftype (function (sset sset) boolean) sset=))
+(declaim (ftype (sfunction (sset sset) boolean) sset=))
(defun sset= (set1 set2)
(equal (sset-elements set1) (sset-elements set2)))
;;; Return true if SET contains no elements, false otherwise.
-(declaim (ftype (function (sset) boolean) sset-empty))
+(declaim (ftype (sfunction (sset) boolean) sset-empty))
(defun sset-empty (set)
(null (cdr (sset-elements set))))
;;; Return a new copy of SET.
-(declaim (ftype (function (sset) sset) copy-sset))
+(declaim (ftype (sfunction (sset) sset) copy-sset))
(defun copy-sset (set)
(make-sset :elements (copy-list (sset-elements set))))
;;; Perform the appropriate set operation on SET1 and SET2 by
;;; destructively modifying SET1. We return true if SET1 was modified,
;;; false otherwise.
-(declaim (ftype (function (sset sset) boolean) sset-union sset-intersection
+(declaim (ftype (sfunction (sset sset) boolean) sset-union sset-intersection
sset-difference))
(defun sset-union (set1 set2)
(let* ((prev-el1 (sset-elements set1))
;;; Destructively modify SET1 to include its union with the difference
;;; of SET2 and SET3. We return true if SET1 was modified, false
;;; otherwise.
-(declaim (ftype (function (sset sset sset) boolean) sset-union-of-difference))
+(declaim (ftype (sfunction (sset sset sset) boolean) sset-union-of-difference))
(defun sset-union-of-difference (set1 set2 set3)
(let* ((prev-el1 (sset-elements set1))
(el1 (cdr prev-el1))
;;; checkins which aren't released. (And occasionally for internal
;;; versions, especially for internal versions off the main CVS
;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"0.8.0.62"
+"0.8.0.63"
projects / sbcl.git / commitdiff