From: William Harold Newman Date: Sat, 14 Dec 2002 22:10:06 +0000 (+0000) Subject: 0.7.10.18: X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=148e3820ad314a9b59d0133c1d60eaac4af9118b;hp=0957d59ccfaf3db9aaf79a7f4909a40ea0ca0dcd;p=sbcl.git 0.7.10.18: merged Robert E. Brown shush-the-compiler patch (sbcl-devel 2002-12-13) minor changes... ...removed DECLAIM FTYPE for SLOT-ACCESSOR-INLINE-EXPANSION-DESIGNATORS on the theory that it's too fragile (since (1) S-A-I-E-D does currently return functions, but could validly return nonfunctions in some later implementation, and (2) SBCL's declarations-are-assertions still doesn't work right for DECLAIM FTYPE) ...sometimes used THE instead of DECLARE (didn't do yet, but still intend to: add some documentation related to drichards' #lisp question about :NOT-HOST) --- diff --git a/TODO b/TODO index 8736a27..ab13f0c 100644 --- a/TODO +++ b/TODO @@ -38,6 +38,10 @@ for late 0.7.x: * miscellaneous simple refactoring * belated renaming: ** renamed %PRIMITIVE to %VOP + ** A few hundred things named FN and FCN should be + named FUN (but maybe not while dan_b is + working on a threads branch and drichards is + working on a Windows port). * These days ANSI C has inline functions, so.. ** redid many cpp macros as inline functions: HeaderValue, Pointerp, CEILING, ALIGNED_SIZE, diff --git a/make-host-2.sh b/make-host-2.sh index e3c4f3f..e266d77 100644 --- a/make-host-2.sh +++ b/make-host-2.sh @@ -67,8 +67,8 @@ $SBCL_XC_HOST <<-'EOF' || exit 1 (space 1) (speed 2))))) (compile 'proclaim-target-optimization) - (defun in-target-cross-compilation-mode (fn) - "Call FN with everything set up appropriately for cross-compiling + (defun in-target-cross-compilation-mode (fun) + "Call FUN with everything set up appropriately for cross-compiling a target file." (let (;; In order to increase microefficiency of the target Lisp, ;; enable old CMU CL defined-function-types-never-change @@ -90,10 +90,10 @@ $SBCL_XC_HOST <<-'EOF' || exit 1 (proclaim-target-optimization) ;; Specify where target machinery lives. (with-additional-nickname ("SB-XC" "SB!XC") - (funcall fn)))) + (funcall fun)))) (compile 'in-target-cross-compilation-mode) - (setf *target-compile-file* 'sb-xc:compile-file) - (setf *target-assemble-file* 'sb!c:assemble-file) + (setf *target-compile-file* #'sb-xc:compile-file) + (setf *target-assemble-file* #'sb!c:assemble-file) (setf *in-target-compilation-mode-fn* #'in-target-cross-compilation-mode) diff --git a/src/code/defbangstruct.lisp b/src/code/defbangstruct.lisp index 7a8d3ae..bcde0b5 100644 --- a/src/code/defbangstruct.lisp +++ b/src/code/defbangstruct.lisp @@ -118,6 +118,7 @@ (if (consp nameoid) (values (first nameoid) (rest nameoid)) (values nameoid nil)) + (declare (type list options)) (let* ((include-clause (find :include options :key #'first)) (def!struct-supertype nil) ; may change below (mlff-clause (find :make-load-form-fun options :key #'first)) diff --git a/src/code/defstruct.lisp b/src/code/defstruct.lisp index 81af528..8a0eb70 100644 --- a/src/code/defstruct.lisp +++ b/src/code/defstruct.lisp @@ -1289,6 +1289,7 @@ ;;; Create a default (non-BOA) keyword constructor. (defun create-keyword-constructor (defstruct creator) + (declare (type function creator)) (collect ((arglist (list '&key)) (types) (vals)) @@ -1305,6 +1306,7 @@ ;;; Given a structure and a BOA constructor spec, call CREATOR with ;;; the appropriate args to make a constructor. (defun create-boa-constructor (defstruct boa creator) + (declare (type function creator)) (multiple-value-bind (req opt restp rest keyp keys allowp auxp aux) (parse-lambda-list (second boa)) (collect ((arglist) diff --git a/src/code/early-format.lisp b/src/code/early-format.lisp index 8e1bbe3..06baecd 100644 --- a/src/code/early-format.lisp +++ b/src/code/early-format.lisp @@ -31,8 +31,9 @@ ;;; non-NIL, up-up-and-out (~:^) is allowed. Otherwise, ~:^ isn't allowed. (defvar *up-up-and-out-allowed* nil) -;;; Used by the interpreter stuff. When it non-NIL, its a function that will -;;; invoke PPRINT-POP in the right lexical environemnt. +;;; Used by the interpreter stuff. When it's non-NIL, it's a function +;;; that will invoke PPRINT-POP in the right lexical environemnt. +(declaim (type (or null function) *logical-block-popper*)) (defvar *logical-block-popper* nil) ;;; Used by the expander stuff. This is bindable so that ~<...~:> diff --git a/src/code/early-setf.lisp b/src/code/early-setf.lisp index 8c5235a..b09d1f0 100644 --- a/src/code/early-setf.lisp +++ b/src/code/early-setf.lisp @@ -380,6 +380,7 @@ GET-SETF-EXPANSION directly." (error "ill-formed DEFSETF for ~S" access-fn)))) (defun %defsetf (orig-access-form num-store-vars expander) + (declare (type function expander)) (let (subforms subform-vars subform-exprs diff --git a/src/code/fdefinition.lisp b/src/code/fdefinition.lisp index 78a574a..5e1fab5 100644 --- a/src/code/fdefinition.lisp +++ b/src/code/fdefinition.lisp @@ -121,6 +121,7 @@ ;;; This is like FIND-IF, except that we do it on a compiled closure's ;;; environment. (defun find-if-in-closure (test fun) + (declare (type function test)) (dotimes (index (1- (get-closure-length fun))) (let ((elt (%closure-index-ref fun index))) (when (funcall test elt) @@ -226,8 +227,8 @@ (defvar *setf-fdefinition-hook* nil #!+sb-doc - "This holds functions that (SETF FDEFINITION) invokes before storing the - new value. These functions take the function name and the new value.") + "A list of functions that (SETF FDEFINITION) invokes before storing the + new value. The functions take the function name and the new value.") (defun %set-fdefinition (name new-value) #!+sb-doc @@ -238,6 +239,7 @@ ;; top level forms in the kernel core startup. (when (boundp '*setf-fdefinition-hook*) (dolist (f *setf-fdefinition-hook*) + (declare (type function f)) (funcall f name new-value))) (let ((encap-info (encapsulation-info (fdefn-fun fdefn)))) diff --git a/src/code/final.lisp b/src/code/final.lisp index 5b9d1ba..b4a920f 100644 --- a/src/code/final.lisp +++ b/src/code/final.lisp @@ -14,6 +14,7 @@ (defvar *objects-pending-finalization* nil) (defun finalize (object function) + (declare (type function function)) #!+sb-doc "Arrange for FUNCTION to be called when there are no more references to OBJECT." @@ -45,7 +46,7 @@ (weak-pointer-value (car pair)) (declare (ignore object)) (unless valid - (funcall (cdr pair)) + (funcall (the function (cdr pair))) t))) *objects-pending-finalization*)) nil) diff --git a/src/code/gc.lisp b/src/code/gc.lisp index 1d87564..776acdd 100644 --- a/src/code/gc.lisp +++ b/src/code/gc.lisp @@ -244,7 +244,7 @@ and submit it as a patch." (finish-output notify-stream)) (defparameter *gc-notify-before* #'default-gc-notify-before #!+sb-doc - "This function bound to this variable is invoked before GC'ing (unless + "The function bound to this variable is invoked before GC'ing (unless *GC-NOTIFY-STREAM* is NIL) with the value of *GC-NOTIFY-STREAM* and current amount of dynamic usage (in bytes). It should notify the user that the system is going to GC.") diff --git a/src/code/late-format.lisp b/src/code/late-format.lisp index a7f32f7..a0d204e 100644 --- a/src/code/late-format.lisp +++ b/src/code/late-format.lisp @@ -222,6 +222,7 @@ (char-code (format-directive-character directive)))) (*default-format-error-offset* (1- (format-directive-end directive)))) + (declare (type (or null function) expander)) (if expander (funcall expander directive more-directives) (error 'format-error diff --git a/src/code/late-type.lisp b/src/code/late-type.lisp index ff52c67..e6be620 100644 --- a/src/code/late-type.lisp +++ b/src/code/late-type.lisp @@ -836,7 +836,7 @@ (defun accumulate1-compound-type (type types %compound-type-p simplify2) (declare (type ctype type)) (declare (type (vector ctype) types)) - (declare (type function simplify2)) + (declare (type function %compound-type-p simplify2)) ;; Any input object satisfying %COMPOUND-TYPE-P should've been ;; broken into components before it reached us. (aver (not (funcall %compound-type-p type))) diff --git a/src/code/ntrace.lisp b/src/code/ntrace.lisp index d666736..c93e07f 100644 --- a/src/code/ntrace.lisp +++ b/src/code/ntrace.lisp @@ -154,6 +154,7 @@ (let ((exp (car form))) (if (sb-di:code-location-p loc) (let ((fun (sb-di:preprocess-for-eval exp loc))) + (declare (type function fun)) (cons exp (lambda (frame) (let ((*current-frame* frame)) @@ -275,6 +276,7 @@ ;;; to determine the correct indentation for output. We then check to ;;; see whether the function is still traced and that the condition ;;; succeeded before printing anything. +(declaim (ftype (function (trace-info) function) trace-end-breakpoint-fun)) (defun trace-end-breakpoint-fun (info) (lambda (frame bpt *trace-values* cookie) (declare (ignore bpt)) @@ -311,6 +313,7 @@ ;;; which we have cleverly contrived to work for our hook functions. (defun trace-call (info) (multiple-value-bind (start cookie) (trace-start-breakpoint-fun info) + (declare (type function start cookie)) (let ((frame (sb-di:frame-down (sb-di:top-frame)))) (funcall start frame nil) (let ((*traced-entries* *traced-entries*)) diff --git a/src/code/primordial-extensions.lisp b/src/code/primordial-extensions.lisp index 0f901a3..4a86b53 100644 --- a/src/code/primordial-extensions.lisp +++ b/src/code/primordial-extensions.lisp @@ -272,6 +272,7 @@ (%defconstant-eqx-value ',symbol ,expr ,eqx) ,@(when doc (list doc)))) (defun %defconstant-eqx-value (symbol expr eqx) + (declare (type function eqx)) (flet ((bummer (explanation) (error "~@" symbol diff --git a/src/code/print.lisp b/src/code/print.lisp index 04d85f4..ac90cfe 100644 --- a/src/code/print.lisp +++ b/src/code/print.lisp @@ -97,6 +97,7 @@ `(%with-standard-io-syntax (lambda () ,@body))) (defun %with-standard-io-syntax (function) + (declare (type function function)) (let ((*package* (find-package "COMMON-LISP-USER")) (*print-array* t) (*print-base* 10) @@ -240,6 +241,7 @@ ;;; guts of PRINT-UNREADABLE-OBJECT (defun %print-unreadable-object (object stream type identity body) + (declare (type (or null function) body)) (when *print-readably* (error 'print-not-readable :object object)) (flet ((print-description () diff --git a/src/code/profile.lisp b/src/code/profile.lisp index 20a3c03..1f4f793 100644 --- a/src/code/profile.lisp +++ b/src/code/profile.lisp @@ -441,6 +441,7 @@ Lisp process." (flet ((frob () (let ((start (get-internal-ticks)) (fun (symbol-function 'compute-overhead-aux))) + (declare (type function fun)) (dotimes (i *timer-overhead-iterations*) (funcall fun fun)) (/ (float (- (get-internal-ticks) start)) diff --git a/src/code/target-defstruct.lisp b/src/code/target-defstruct.lisp index 03f368a..8f35d3c 100644 --- a/src/code/target-defstruct.lisp +++ b/src/code/target-defstruct.lisp @@ -390,7 +390,7 @@ (defun %default-structure-pretty-print (structure stream) (let* ((layout (%instance-layout structure)) - (name (sb!xc:class-name (layout-class layout))) + (name (class-name (layout-class layout))) (dd (layout-info layout))) (pprint-logical-block (stream nil :prefix "#S(" :suffix ")") (prin1 name stream) @@ -416,7 +416,7 @@ (pprint-newline :linear stream)))))))) (defun %default-structure-ugly-print (structure stream) (let* ((layout (%instance-layout structure)) - (name (sb!xc:class-name (layout-class layout))) + (name (class-name (layout-class layout))) (dd (layout-info layout))) (descend-into (stream) (write-string "#S(" stream) diff --git a/src/code/target-error.lisp b/src/code/target-error.lisp index 747b54f..a206630 100644 --- a/src/code/target-error.lisp +++ b/src/code/target-error.lisp @@ -112,10 +112,12 @@ returned. It is an error to supply NIL as a name. If CONDITION is specified and not NIL, then only restarts associated with that condition (or with no condition) will be returned." - (find-if (lambda (x) - (or (eq x name) - (eq (restart-name x) name))) - (compute-restarts condition))) + (let ((restarts (compute-restarts condition))) + (declare (type list restarts)) + (find-if (lambda (x) + (or (eq x name) + (eq (restart-name x) name))) + restarts))) (defun invoke-restart (restart &rest values) #!+sb-doc diff --git a/src/code/target-type.lisp b/src/code/target-type.lisp index d024ace..e561d87 100644 --- a/src/code/target-type.lisp +++ b/src/code/target-type.lisp @@ -151,7 +151,7 @@ csubtypep-cache-clear type-intersection2-cache-clear values-type-intersection-cache-clear)) - (funcall (symbol-function sym)))) + (funcall (the function (symbol-function sym))))) (values)) ;;; This is like TYPE-OF, only we return a CTYPE structure instead of diff --git a/src/code/time.lisp b/src/code/time.lisp index 451003a..5ddfde3 100644 --- a/src/code/time.lisp +++ b/src/code/time.lisp @@ -228,6 +228,7 @@ ;;; The guts of the TIME macro. Compute overheads, run the (compiled) ;;; function, report the times. (defun %time (fun) + (declare (type function fun)) (let (old-run-utime new-run-utime old-run-stime diff --git a/src/code/toplevel.lisp b/src/code/toplevel.lisp index f4baf40..00495f5 100644 --- a/src/code/toplevel.lisp +++ b/src/code/toplevel.lisp @@ -305,6 +305,8 @@ (noprint nil) ; Has a --noprint option been seen? (options (rest *posix-argv*))) ; skipping program name + (declare (type list options)) + (/show0 "done with outer LET in TOPLEVEL-INIT") ;; FIXME: There are lots of ways for errors to happen around here @@ -394,6 +396,7 @@ (flet (;; If any of POSSIBLE-INIT-FILE-NAMES names a real file, ;; return its truename. (probe-init-files (&rest possible-init-file-names) + (declare (type list possible-init-file-names)) (/show0 "entering PROBE-INIT-FILES") (prog1 (find-if (lambda (x) diff --git a/src/code/type-class.lisp b/src/code/type-class.lisp index bf12bec..be23b94 100644 --- a/src/code/type-class.lisp +++ b/src/code/type-class.lisp @@ -241,11 +241,13 @@ (let ((class1 (type-class-info type1)) (class2 (type-class-info type2))) (if (eq class1 class2) - (funcall (funcall simple class1) type1 type2) + (funcall (the function (funcall simple class1)) type1 type2) (let ((complex2 (funcall cslot2 class2))) + (declare (type (or function null) complex2)) (if complex2 (funcall complex2 type1 type2) (let ((complex1 (funcall cslot1 class1))) + (declare (type (or function null) complex1)) (if complex1 (if complex-arg1-p (funcall complex1 type1 type2) diff --git a/src/cold/defun-load-or-cload-xcompiler.lisp b/src/cold/defun-load-or-cload-xcompiler.lisp index cadc1b9..c83c01e 100644 --- a/src/cold/defun-load-or-cload-xcompiler.lisp +++ b/src/cold/defun-load-or-cload-xcompiler.lisp @@ -13,6 +13,8 @@ ;;; cross-compilation host Common Lisp. (defun load-or-cload-xcompiler (load-or-cload-stem) + (declare (type function load-or-cload-stem)) + ;; The running-in-the-host-Lisp Python cross-compiler defines its ;; own versions of a number of functions which should not overwrite ;; host-Lisp functions. Instead we put them in a special package. diff --git a/src/cold/shared.lisp b/src/cold/shared.lisp index 985a444..653d0c4 100644 --- a/src/cold/shared.lisp +++ b/src/cold/shared.lisp @@ -59,11 +59,12 @@ ;;; a function of one functional argument, which calls its functional argument ;;; in an environment suitable for compiling the target. (This environment ;;; includes e.g. a suitable *FEATURES* value.) +(declaim (type function *in-target-compilation-mode-fn*)) (defvar *in-target-compilation-mode-fn*) -;;; designator for a function with the same calling convention as -;;; CL:COMPILE-FILE, to be used to translate ordinary Lisp source files into -;;; target object files +;;; a function with the same calling convention as CL:COMPILE-FILE, to be +;;; used to translate ordinary Lisp source files into target object files +(declaim (type function *target-compile-file*)) (defvar *target-compile-file*) ;;; designator for a function with the same calling convention as @@ -130,6 +131,8 @@ (compile-file #'compile-file) ignore-failure-p) + (declare (type function compile-file)) + (let* (;; KLUDGE: Note that this CONCATENATE 'STRING stuff is not The Common ;; Lisp Way, although it works just fine for common UNIX environments. ;; Should it come to pass that the system is ported to environments @@ -327,6 +330,7 @@ ;;; Execute function FN in an environment appropriate for compiling the ;;; cross-compiler's source code in the cross-compilation host. (defun in-host-compilation-mode (fn) + (declare (type function fn)) (let ((*features* (cons :sb-xc-host *features*)) ;; the CROSS-FLOAT-INFINITY-KLUDGE, as documented in ;; base-target-features.lisp-expr: diff --git a/src/cold/with-stuff.lisp b/src/cold/with-stuff.lisp index 47f3086..11965fb 100644 --- a/src/cold/with-stuff.lisp +++ b/src/cold/with-stuff.lisp @@ -65,13 +65,17 @@ ;;; helper functions for WITH-ADDITIONAL-NICKNAMES and WITHOUT-GIVEN-NICKNAMES (defun %with-additional-nickname (package-designator nickname body-fn) + (declare (type function body-fn)) (with-additional-nickname (package-designator nickname) (funcall body-fn))) (defun %without-given-nickname (package-designator nickname body-fn) + (declare (type function body-fn)) (without-given-nickname (package-designator nickname) (funcall body-fn))) (defun %multi-nickname-magic (nd-list single-nn-fn body-fn) + (declare (type function single-nn-fn)) (labels ((multi-nd (nd-list body-fn) ; multiple nickname descriptors + (declare (type function body-fn)) (if (null nd-list) (funcall body-fn) (single-nd (first nd-list) @@ -81,6 +85,7 @@ (destructuring-bind (package-descriptor nickname-list) nd (multi-nn package-descriptor nickname-list body-fn))) (multi-nn (nn-list package-descriptor body-fn) ; multiple nicknames + (declare (type function body-fn)) (if (null nn-list) (funcall body-fn) (funcall single-nn-fn diff --git a/src/compiler/assem.lisp b/src/compiler/assem.lisp index 575ecd8..e863633 100644 --- a/src/compiler/assem.lisp +++ b/src/compiler/assem.lisp @@ -1332,6 +1332,7 @@ p ;; the branch has two dependents and one of them dpends on ;;; calling FUNCTION once on the entire compacted segment buffer. -- ;;; WHN 19990322 (defun on-segment-contents-vectorly (segment function) + (declare (type function function)) (let ((buffer (segment-buffer segment)) (i0 0)) (flet ((frob (i0 i1) diff --git a/src/compiler/control.lisp b/src/compiler/control.lisp index 5df3e2f..c86f145 100644 --- a/src/compiler/control.lisp +++ b/src/compiler/control.lisp @@ -96,7 +96,9 @@ ;;; (end in an error, NLX or tail full call.) This is to discourage ;;; making error code the drop-through. (defun control-analyze-block (block tail block-info-constructor) - (declare (type cblock block) (type block-annotation tail)) + (declare (type cblock block) + (type block-annotation tail) + (type function block-info-constructor)) (unless (block-flag block) (let ((block (find-rotated-loop-head block))) (setf (block-flag block) t) @@ -137,7 +139,9 @@ ;;; course, it will never get a drop-through if either function has ;;; NLX code. (defun control-analyze-1-fun (fun component block-info-constructor) - (declare (type clambda fun) (type component component)) + (declare (type clambda fun) + (type component component) + (type function block-info-constructor)) (let* ((tail-block (block-info (component-tail component))) (prev-block (block-annotation-prev tail-block)) (bind-block (node-block (lambda-bind fun)))) diff --git a/src/compiler/disassem.lisp b/src/compiler/disassem.lisp index 5dbf562..3219494 100644 --- a/src/compiler/disassem.lisp +++ b/src/compiler/disassem.lisp @@ -1217,6 +1217,7 @@ (cons car cdr))) (defun sharing-mapcar (fun list) + (declare (type function fun)) #!+sb-doc "A simple (one list arg) mapcar that avoids consing up a new list as long as the results of calling FUN on the elements of LIST are diff --git a/src/compiler/fndb.lisp b/src/compiler/fndb.lisp index 604f85b..f3b1b5a 100644 --- a/src/compiler/fndb.lisp +++ b/src/compiler/fndb.lisp @@ -1302,8 +1302,8 @@ (defknown hairy-data-vector-ref (array index) t (foldable flushable explicit-check)) (defknown hairy-data-vector-set (array index t) t (unsafe explicit-check)) -(defknown sb!kernel:%caller-frame-and-pc () (values t t) (flushable)) -(defknown sb!kernel:%with-array-data (array index (or index null)) +(defknown %caller-frame-and-pc () (values t t) (flushable)) +(defknown %with-array-data (array index (or index null)) (values (simple-array * (*)) index index index) (foldable flushable)) (defknown %set-symbol-package (symbol t) t (unsafe)) @@ -1326,7 +1326,7 @@ (flushable foldable)) -(defknown sb!kernel::arg-count-error (t t t t t t) nil (unsafe)) +(defknown arg-count-error (t t t t t t) nil (unsafe)) ;;;; SETF inverses diff --git a/src/compiler/generic/genesis.lisp b/src/compiler/generic/genesis.lisp index 54c0730..10641b3 100644 --- a/src/compiler/generic/genesis.lisp +++ b/src/compiler/generic/genesis.lisp @@ -3209,6 +3209,7 @@ initially undefined function references:~2%") (let ((package (find-package (sb-cold:package-data-name pd)))) (labels (;; Call FN on every node of the TREE. (mapc-on-tree (fn tree) + (declare (type function fn)) (typecase tree (cons (mapc-on-tree fn (car tree)) (mapc-on-tree fn (cdr tree))) diff --git a/src/compiler/ir1report.lisp b/src/compiler/ir1report.lisp index d12c204..c8dced2 100644 --- a/src/compiler/ir1report.lisp +++ b/src/compiler/ir1report.lisp @@ -129,11 +129,14 @@ (defun source-form-context (form) (cond ((atom form) nil) ((>= (length form) 2) - (funcall (gethash (first form) *source-context-methods* - (lambda (x) - (declare (ignore x)) - (list (first form) (second form)))) - (rest form))) + (let* ((context-fun-default (lambda (x) + (declare (ignore x)) + (list (first form) (second form)))) + (context-fun (gethash (first form) + *source-context-methods* + context-fun-default))) + (declare (type function context-fun)) + (funcall context-fun (rest form)))) (t form))) diff --git a/src/compiler/macros.lisp b/src/compiler/macros.lisp index f8fb006..df8fb02 100644 --- a/src/compiler/macros.lisp +++ b/src/compiler/macros.lisp @@ -811,7 +811,7 @@ ;;;; functions on directly-linked lists (linked through specialized ;;;; NEXT operations) -#!-sb-fluid (declaim (inline find-in position-in map-in)) +#!-sb-fluid (declaim (inline find-in position-in)) ;;; Find Element in a null-terminated List linked by the accessor ;;; function Next. Key, Test and Test-Not are the same as for generic @@ -822,7 +822,8 @@ &key (key #'identity) (test #'eql test-p) - (test-not nil not-p)) + (test-not #'eql not-p)) + (declare (type function next key test test-not)) (when (and test-p not-p) (error "It's silly to supply both :TEST and :TEST-NOT arguments.")) (if not-p @@ -844,7 +845,8 @@ &key (key #'identity) (test #'eql test-p) - (test-not nil not-p)) + (test-not #'eql not-p)) + (declare (type function next key test test-not)) (when (and test-p not-p) (error "It's silly to supply both :TEST and :TEST-NOT arguments.")) (if not-p @@ -859,14 +861,6 @@ (when (funcall test (funcall key current) element) (return i))))) -;;; Map FUNCTION over the elements in a null-terminated LIST linked by the -;;; accessor function NEXT, returning an ordinary list of the results. -(defun map-in (next function list) - (collect ((res)) - (do ((current list (funcall next current))) - ((null current)) - (res (funcall function current))) - (res))) ;;; KLUDGE: This is expanded out twice, by cut-and-paste, in a ;;; (DEF!MACRO FOO (..) .. CL:GET-SETF-EXPANSION ..) diff --git a/src/compiler/main.lisp b/src/compiler/main.lisp index 01bca3a..6b3debf 100644 --- a/src/compiler/main.lisp +++ b/src/compiler/main.lisp @@ -121,6 +121,7 @@ `(%with-compilation-unit (lambda () ,@body) ,@options)) (defun %with-compilation-unit (fn &key override) + (declare (type function fn)) (let ((succeeded-p nil)) (if (and *in-compilation-unit* (not override)) ;; Inside another WITH-COMPILATION-UNIT, a WITH-COMPILATION-UNIT is diff --git a/src/compiler/represent.lisp b/src/compiler/represent.lisp index ad0add7..f8151f2 100644 --- a/src/compiler/represent.lisp +++ b/src/compiler/represent.lisp @@ -227,6 +227,7 @@ (defun add-representation-costs (refs scs costs ops-slot costs-slot more-costs-slot write-p) + (declare (type function ops-slot costs-slot more-costs-slot)) (do ((ref refs (tn-ref-next ref))) ((null ref)) (flet ((add-costs (cost) diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp index 487bb15..ce2374f 100644 --- a/src/compiler/srctran.lisp +++ b/src/compiler/srctran.lisp @@ -258,6 +258,7 @@ ;;; Apply the function F to a bound X. If X is an open bound, then ;;; the result will be open. IF X is NIL, the result is NIL. (defun bound-func (f x) + (declare (type function f)) (and x (with-float-traps-masked (:underflow :overflow :inexact :divide-by-zero) ;; With these traps masked, we might get things like infinity @@ -688,7 +689,8 @@ ;;; result makes sense. It will if F is monotonic increasing (or ;;; non-decreasing). (defun interval-func (f x) - (declare (type interval x)) + (declare (type function f) + (type interval x)) (let ((lo (bound-func f (interval-low x))) (hi (bound-func f (interval-high x)))) (make-interval :low lo :high hi))) @@ -1072,6 +1074,7 @@ ;;; positive. If we didn't do this, we wouldn't be able to tell. (defun two-arg-derive-type (arg1 arg2 derive-fcn fcn &optional (convert-type t)) + (declare (type function derive-fcn fcn)) #!+negative-zero-is-not-zero (declare (ignore convert-type)) (flet (#!-negative-zero-is-not-zero