* 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,
(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
(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)
(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))
;;; Create a default (non-BOA) keyword constructor.
(defun create-keyword-constructor (defstruct creator)
+ (declare (type function creator))
(collect ((arglist (list '&key))
(types)
(vals))
;;; 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)
;;; 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 ~<...~:>
(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
;;; 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)
(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
;; 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))))
(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."
(weak-pointer-value (car pair))
(declare (ignore object))
(unless valid
- (funcall (cdr pair))
+ (funcall (the function (cdr pair)))
t)))
*objects-pending-finalization*))
nil)
(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.")
(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
(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)))
(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))
;;; 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))
;;; 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*))
(%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 "~@<bad DEFCONSTANT-EQX ~S ~2I~_~S: ~2I~_~A ~S~:>"
symbol
`(%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)
;;; 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 ()
(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))
(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)
(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)
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
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
;;; 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
(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
(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)
(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)
;;; 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.
;;; 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
(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
;;; 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:
;;; 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)
(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
;;; 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)
;;; (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)
;;; 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))))
(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
(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))
(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))
\f
;;;; SETF inverses
(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)))
(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)))
;;;; 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
&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
&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
(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 ..)
`(%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
(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)
;;; 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
;;; 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)))
;;; 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
projects / sbcl.git / commitdiff