protruding rusty nails and snipped off the trailing razor wire,
leaving some filing for later:-) from the monster
EVAL/EVAL-WHEN/%COMPILE/DEFUN/DEFSTRUCT cleanup:
- ** made inlining DEFUN inside MACROLET work again
- ** bug 138
* more renaming in global external names:
** reserved DO-FOO-style names for iteration macros
** finished s/FUNCTION/FUN/
** s/VARIABLE/VAR/
** perhaps s/DEF-FROB/DEF/ or s/DEF-FROB/DEFINE/
* Perhaps rename "cold" stuff (e.g. SB-COLD and src/cold/) to "boot".
-* global style systematization:
- ** s/#'(lambda/(lambda/
* pending patches and bug reports that go in (or else get handled
somehow, rejected/logged/whatever) before 0.7.0:
- ** DIRECTORY problems (bug 139, CR patch sbcl-devel 2001-12-31)
=======================================================================
for early 0.7.x:
of them. Since I have other motivations for this rearrangement
besides CLISPiosyncrasies, I'm reasonably motivated to do it.
* urgent EVAL/EVAL-WHEN/%COMPILE/DEFUN/DEFSTRUCT cleanup:
- ** fixed bug 137
+ ** made inlining DEFUN inside MACROLET work again
+ ** fixed bug 137 (more)
* faster bootstrapping (both make.sh and slam.sh)
** added mechanisms for automatically finding dead code, and
used them to remove dead code
"CALL" "CALL-LOCAL" "CALL-NAMED" "CALL-OUT" "CALL-VARIABLE"
"CALLEE-NFP-TN" "CALLEE-RETURN-PC-TN"
"CASE-BODY" "CATCH-BLOCK" "CHECK-CONS"
- "CHECK-FIXNUM" "CHECK-FUNCTION"
+ "CHECK-FIXNUM" "CHECK-FUN"
"CHECK-SIGNED-BYTE-32" "CHECK-SYMBOL" "CHECK-UNSIGNED-BYTE-32"
"CLOSURE-INIT" "CLOSURE-REF"
"CODE-CONSTANT-REF" "CODE-CONSTANT-SET"
"DEF-IR1-TRANSLATOR"
"!DEF-PRIMITIVE-TYPE" "!DEF-PRIMITIVE-TYPE-ALIAS"
"DEFINE-SOURCE-TRANSFORM" "!DEF-VM-SUPPORT-ROUTINE"
- "DEFINE-ASSEMBLY-ROUTINE" "DEFINE-MOVE-FUNCTION"
+ "DEFINE-ASSEMBLY-ROUTINE" "DEFINE-MOVE-FUN"
"DEFINE-MOVE-VOP" "DEFINE-STORAGE-BASE"
"DEFINE-STORAGE-CLASS" "DEFINE-VOP"
"DEFKNOWN" "DEFOPTIMIZER"
#s(sb-cold:package-data
:name "SB!DEBUG"
:doc
-"public: (eventually) the debugger interface (but currently) the
-debugger interface mixed with various low-level implementation stuff
-like *STACK-TOP-HINT*"
+"sorta public: Eventually this should become the debugger interface, with
+basic stuff like BACKTRACE and ARG. For now, the actual supported interface
+is still mixed indiscriminately with low-level internal implementation stuff
+like *STACK-TOP-HINT* and unsupported stuff like *TRACED-FUN-LIST*."
:use ("CL" "SB!EXT" "SB!INT" "SB!SYS")
:export ("*DEBUG-BEGINNER-HELP-P*"
"*DEBUG-CONDITION*"
"*DEBUG-READTABLE*" "*DEBUG-HELP-STRING*"
"*FLUSH-DEBUG-ERRORS*" "*IN-THE-DEBUGGER*"
"*TRACE-INDENTATION-STEP*" "*MAX-TRACE-INDENTATION*"
- "*TRACE-FRAME*" "*TRACE-PRINT-LENGTH*"
- "*TRACE-PRINT-LEVEL*" "*TRACED-FUNCTION-LIST*"
+ "*TRACE-FRAME*" "*TRACED-FUN-LIST*"
"ARG" "BACKTRACE" "INTERNAL-DEBUG" "VAR"
"*PRINT-LOCATION-KIND*"
"*ONLY-BLOCK-START-LOCATIONS*" "*STACK-TOP-HINT*"
"DEBUG-SOURCE-P")
:export ("ACTIVATE-BREAKPOINT"
"AMBIGUOUS-DEBUG-VARS" "AMBIGUOUS-VAR-NAME" "BREAKPOINT"
- "BREAKPOINT-ACTIVE-P" "BREAKPOINT-HOOK-FUNCTION" "BREAKPOINT-INFO"
+ "BREAKPOINT-ACTIVE-P" "BREAKPOINT-HOOK-FUN" "BREAKPOINT-INFO"
"BREAKPOINT-KIND" "BREAKPOINT-P" "BREAKPOINT-WHAT" "CODE-LOCATION"
"CODE-LOCATION-DEBUG-BLOCK" "CODE-LOCATION-DEBUG-FUN"
"CODE-LOCATION-DEBUG-SOURCE" "CODE-LOCATION-FORM-NUMBER"
"ADD-COMMENT-HOOK" "ADD-HOOK" "ADD-NOTE-HOOK"
"ARG-VALUE" "CREATE-DSTATE" "DISASSEM-STATE"
"DISASSEMBLE-CODE-COMPONENT"
- "DISASSEMBLE-FUNCTION" "DISASSEMBLE-MEMORY"
+ "DISASSEMBLE-FUN" "DISASSEMBLE-MEMORY"
"DISASSEMBLE-SEGMENT" "DISASSEMBLE-SEGMENTS"
"DSTATE-CODE" "DSTATE-CURPOS" "DSTATE-GET-PROP"
"DSTATE-NEXTPOS" "DSTATE-SEGMENT-LENGTH"
"DSTATE-SEGMENT-SAP" "DSTATE-SEGMENT-START"
"FIELD-TYPE" "FIND-INST" "GEN-FIELD-TYPE-DECL-FORM"
"GEN-INST-DECL-FORM" "GEN-INST-FORMAT-DECL-FORM"
- "GET-CODE-SEGMENTS" "GET-FUNCTION-SEGMENTS"
+ "GET-CODE-SEGMENTS" "GET-FUN-SEGMENTS"
"GET-INST-SPACE" "HANDLE-BREAK-ARGS"
"INST" "INST-FORMAT" "LABEL-SEGMENTS"
"MAYBE-NOTE-ASSEMBLER-ROUTINE"
"CODE-COMPONENT" "CODE-COMPONENT-P"
"CODE-DEBUG-INFO" "CODE-HEADER-REF" "CODE-HEADER-SET"
"CODE-INSTRUCTIONS"
- "COERCE-TO-BIT-VECTOR" "COERCE-TO-FUNCTION" "COERCE-TO-LEXENV"
+ "COERCE-TO-BIT-VECTOR" "COERCE-TO-FUN" "COERCE-TO-LEXENV"
"COERCE-TO-LIST" "COERCE-TO-SIMPLE-STRING"
"COERCE-TO-SIMPLE-VECTOR" "COERCE-TO-VECTOR"
"*COLD-INIT-COMPLETE-P*"
"MUTATOR-SELF"
"NAMED-TYPE" "NAMED-TYPE-NAME" "NAMED-TYPE-P"
"NATIVE-BYTE-ORDER" "NEGATE"
- "NEVER-SUBTYPEP" "NIL-FUNCTION-RETURNED-ERROR"
+ "NEVER-SUBTYPEP" "NIL-FUN-RETURNED-ERROR"
"NOT-<=-ERROR" "NOT-=-ERROR"
"NOT-DUMPED-AT-ALL"
"NUMERIC-CONTAGION" "NUMERIC-TYPE"
"NUMERIC-TYPE-HIGH" "NUMERIC-TYPE-LOW" "NUMERIC-TYPE-P"
"OBJECT-NOT-ARRAY-ERROR" "OBJECT-NOT-BASE-CHAR-ERROR"
"OBJECT-NOT-BIGNUM-ERROR" "OBJECT-NOT-BIT-VECTOR-ERROR"
- "OBJECT-NOT-COERCEABLE-TO-FUNCTION-ERROR"
+ "OBJECT-NOT-COERCEABLE-TO-FUN-ERROR"
"OBJECT-NOT-COMPLEX-ERROR"
"OBJECT-NOT-COMPLEX-FLOAT-ERROR"
"OBJECT-NOT-COMPLEX-SINGLE-FLOAT-ERROR"
"OBJECT-NOT-COMPLEX-VECTOR-ERROR"
"OBJECT-NOT-CONS-ERROR"
"OBJECT-NOT-DOUBLE-FLOAT-ERROR" "OBJECT-NOT-FIXNUM-ERROR"
- "OBJECT-NOT-FLOAT-ERROR" "OBJECT-NOT-FUNCTION-ERROR"
+ "OBJECT-NOT-FLOAT-ERROR" "OBJECT-NOT-FUN-ERROR"
"OBJECT-NOT-INSTANCE-ERROR"
"OBJECT-NOT-INTEGER-ERROR"
"OBJECT-NOT-LIST-ERROR" "OBJECT-NOT-LONG-FLOAT-ERROR"
"%SIMPLE-FUN-TYPE" "PROCLAIM-AS-FUN-NAME"
"BECOME-DEFINED-FUN-NAME"
"%NUMERATOR" "CLASS-TYPEP"
- "STRUCTURE-CLASS-PRINT-FUNCTION" "DSD-READ-ONLY"
+ "DSD-READ-ONLY"
"LAYOUT-INHERITS" "DD-LENGTH" "%CODE-ENTRY-POINTS"
"%DENOMINATOR"
"MAKE-STANDARD-CLASS"
"FUNCALLABLE-STRUCTURE-CLASS"
"%RANDOM-DOUBLE-FLOAT" "%RANDOM-LONG-FLOAT"
"%RANDOM-SINGLE-FLOAT"
- "RANDOM-PCL-CLASS" "BASIC-STRUCTURE-CLASS-PRINT-FUNCTION"
+ "RANDOM-PCL-CLASS"
"%FUNCALLABLE-INSTANCE-INFO" "RANDOM-CHUNK"
"MAKE-FUNCALLABLE-STRUCTURE-CLASS" "LAYOUT-CLOS-HASH-MAX"
"CLASS-CELL-NAME" "BUILT-IN-CLASS-DIRECT-SUPERCLASSES"
(logand x (1- (ash 1 digit-size))))
#!-32x16-divide
-;;; This takes three digits and returns the FLOOR'ed result of dividing the
-;;; first two as a 64-bit integer by the third.
+;;; This takes three digits and returns the FLOOR'ed result of
+;;; dividing the first two as a 64-bit integer by the third.
;;;
-;;; DO WEIRD let AND setq STUFF TO SLIME THE COMPILER INTO ALLOWING THE %FLOOR
-;;; TRANSFORM TO EXPAND INTO PSEUDO-ASSEMBLER FOR WHICH THE COMPILER CAN LATER
-;;; CORRECTLY ALLOCATE REGISTERS.
+;;; Do weird LET and SETQ stuff to bamboozle the compiler into allowing
+;;; the %FLOOR transform to expand into pseudo-assembler for which the
+;;; compiler can later correctly allocate registers.
(defun %floor (a b c)
(let ((a a) (b b) (c c))
(declare (type bignum-element-type a b c))
;;; DEFTRANSFORMs, though.
(declaim (inline coerce-to-list))
(declaim (inline coerce-to-simple-string coerce-to-bit-vector coerce-to-vector))
-(defun coerce-to-function (object)
+(defun coerce-to-fun (object)
;; (Unlike the other COERCE-TO-FOOs, this one isn't inline, because
;; it's so big and because optimizing away the outer ETYPECASE
;; doesn't seem to buy us that much anyway.)
((csubtypep type (specifier-type 'character))
(character object))
((csubtypep type (specifier-type 'function))
- (coerce-to-function object))
+ (coerce-to-fun object))
((numberp object)
(let ((res
(cond
(breakpoint-data-offset obj))))
(defstruct (breakpoint (:constructor %make-breakpoint
- (hook-function what kind %info))
+ (hook-fun what kind %info))
(:copier nil))
;; This is the function invoked when execution encounters the
;; breakpoint. It takes a frame, the breakpoint, and optionally a
- ;; list of values. Values are supplied for :FUN-END breakpoints
- ;; as values to return for the function containing the breakpoint.
- ;; :FUN-END breakpoint hook-functions also take a cookie
- ;; argument. See COOKIE-FUN slot.
- (hook-function nil :type function)
+ ;; list of values. Values are supplied for :FUN-END breakpoints as
+ ;; values to return for the function containing the breakpoint.
+ ;; :FUN-END breakpoint hook functions also take a cookie argument.
+ ;; See the COOKIE-FUN slot.
+ (hook-fun (required-arg) :type function)
;; CODE-LOCATION or DEBUG-FUN
(what nil :type (or code-location debug-fun))
;; :CODE-LOCATION, :FUN-START, or :FUN-END for that kind
;; for identifying :FUN-END breakpoint executions. That is, if
;; there is one :FUN-END breakpoint, but there may be multiple
;; pending calls of its function on the stack. This function takes
- ;; the cookie, and the hook-function takes the cookie too.
+ ;; the cookie, and the hook function takes the cookie too.
(cookie-fun nil :type (or null function))
;; This slot users can set with whatever information they find useful.
%info)
;;;; user-visible interface
;;; Create and return a breakpoint. When program execution encounters
-;;; the breakpoint, the system calls HOOK-FUNCTION. HOOK-FUNCTION takes the
-;;; current frame for the function in which the program is running and the
-;;; breakpoint object.
+;;; the breakpoint, the system calls HOOK-FUN. HOOK-FUN takes the
+;;; current frame for the function in which the program is running and
+;;; the breakpoint object.
;;;
;;; WHAT and KIND determine where in a function the system invokes
-;;; HOOK-FUNCTION. WHAT is either a code-location or a DEBUG-FUN.
-;;; KIND is one of :CODE-LOCATION, :FUN-START, or :FUN-END.
-;;; Since the starts and ends of functions may not have code-locations
-;;; representing them, designate these places by supplying WHAT as a
-;;; DEBUG-FUN and KIND indicating the :FUN-START or
-;;; :FUN-END. When WHAT is a DEBUG-FUN and kind is
-;;; :FUN-END, then hook-function must take two additional
-;;; arguments, a list of values returned by the function and a
-;;; FUN-END-COOKIE.
+;;; HOOK-FUN. WHAT is either a code-location or a DEBUG-FUN. KIND is
+;;; one of :CODE-LOCATION, :FUN-START, or :FUN-END. Since the starts
+;;; and ends of functions may not have code-locations representing
+;;; them, designate these places by supplying WHAT as a DEBUG-FUN and
+;;; KIND indicating the :FUN-START or :FUN-END. When WHAT is a
+;;; DEBUG-FUN and kind is :FUN-END, then HOOK-FUN must take two
+;;; additional arguments, a list of values returned by the function
+;;; and a FUN-END-COOKIE.
;;;
;;; INFO is information supplied by and used by the user.
;;;
;;; function.
;;;
;;; Signal an error if WHAT is an unknown code-location.
-(defun make-breakpoint (hook-function what
+(defun make-breakpoint (hook-fun what
&key (kind :code-location) info fun-end-cookie)
(etypecase what
(code-location
(error "cannot make a breakpoint at an unknown code location: ~S"
what))
(aver (eq kind :code-location))
- (let ((bpt (%make-breakpoint hook-function what kind info)))
+ (let ((bpt (%make-breakpoint hook-fun what kind info)))
(etypecase what
(compiled-code-location
;; This slot is filled in due to calling CODE-LOCATION-UNKNOWN-P.
(when (eq (compiled-code-location-kind what) :unknown-return)
- (let ((other-bpt (%make-breakpoint hook-function what
+ (let ((other-bpt (%make-breakpoint hook-fun what
:unknown-return-partner
info)))
(setf (breakpoint-unknown-return-partner bpt) other-bpt)
(compiled-debug-fun
(ecase kind
(:fun-start
- (%make-breakpoint hook-function what kind info))
+ (%make-breakpoint hook-fun what kind info))
(:fun-end
(unless (eq (sb!c::compiled-debug-fun-returns
(compiled-debug-fun-compiler-debug-fun what))
(error ":FUN-END breakpoints are currently unsupported ~
for the known return convention."))
- (let* ((bpt (%make-breakpoint hook-function what kind info))
+ (let* ((bpt (%make-breakpoint hook-fun what kind info))
(starter (compiled-debug-fun-end-starter what)))
(unless starter
(setf starter (%make-breakpoint #'list what :fun-start nil))
- (setf (breakpoint-hook-function starter)
+ (setf (breakpoint-hook-fun starter)
(fun-end-starter-hook starter what))
(setf (compiled-debug-fun-end-starter what) starter))
(setf (breakpoint-start-helper bpt) starter)
\f
;;;; ACTIVATE-BREAKPOINT
-;;; Cause the system to invoke the breakpoint's hook-function until
+;;; Cause the system to invoke the breakpoint's hook function until
;;; the next call to DEACTIVATE-BREAKPOINT or DELETE-BREAKPOINT. The
;;; system invokes breakpoint hook functions in the opposite order
;;; that you activate them.
\f
;;;; DEACTIVATE-BREAKPOINT
-;;; Stop the system from invoking the breakpoint's hook-function.
+;;; Stop the system from invoking the breakpoint's hook function.
(defun deactivate-breakpoint (breakpoint)
(when (eq (breakpoint-status breakpoint) :active)
(without-interrupts
(frame (do ((f (top-frame) (frame-down f)))
((eq debug-fun (frame-debug-fun f)) f))))
(dolist (bpt breakpoints)
- (funcall (breakpoint-hook-function bpt)
+ (funcall (breakpoint-hook-fun bpt)
frame
;; If this is an :UNKNOWN-RETURN-PARTNER, then pass the
;; hook function the original breakpoint, so that users
(cookie (gethash component *fun-end-cookies*)))
(remhash component *fun-end-cookies*)
(dolist (bpt breakpoints)
- (funcall (breakpoint-hook-function bpt)
+ (funcall (breakpoint-hook-fun bpt)
frame bpt
(get-fun-end-breakpoint-values scp)
cookie))))
(format t "~&~S: FUN-END in ~S" bp-number
(sb!di:debug-fun-name place))))))
\f
-;;;; MAIN-HOOK-FUNCTION for steps and breakpoints
+;;;; MAIN-HOOK-FUN for steps and breakpoints
;;; This must be passed as the hook function. It keeps track of where
;;; STEP breakpoints are.
-(defun main-hook-function (current-frame breakpoint &optional return-vals
- fun-end-cookie)
+(defun main-hook-fun (current-frame breakpoint &optional return-vals
+ fun-end-cookie)
(setf *default-breakpoint-debug-fun*
(sb!di:frame-debug-fun current-frame))
(dolist (step-info *step-breakpoints*)
(break string)
(format t "~A" string)))
(t
- (break "error in main-hook-function: unknown breakpoint"))))))
+ (break "unknown breakpoint"))))))
\f
;;; Set breakpoints at the next possible code-locations. After calling
;;; this, either (CONTINUE) if in the debugger or just let program flow
(when bp-info
(sb!di:deactivate-breakpoint (breakpoint-info-breakpoint
bp-info))))
- (let ((bp (sb!di:make-breakpoint #'main-hook-function code-location
+ (let ((bp (sb!di:make-breakpoint #'main-hook-fun code-location
:kind :code-location)))
(sb!di:activate-breakpoint bp)
(push (create-breakpoint-info code-location bp 0)
*step-breakpoints*))))
(t
(let* ((debug-fun (sb!di:frame-debug-fun *current-frame*))
- (bp (sb!di:make-breakpoint #'main-hook-function debug-fun
+ (bp (sb!di:make-breakpoint #'main-hook-fun debug-fun
:kind :fun-end)))
(sb!di:activate-breakpoint bp)
(push (create-breakpoint-info debug-fun bp 0)
*default-breakpoint-debug-fun*))))))
(setup-fun-start ()
(let ((code-loc (sb!di:debug-fun-start-location place)))
- (setf bp (sb!di:make-breakpoint #'main-hook-function
+ (setf bp (sb!di:make-breakpoint #'main-hook-fun
place
:kind :fun-start))
(setf break (sb!di:preprocess-for-eval break code-loc))
print-functions))))
(setup-fun-end ()
(setf bp
- (sb!di:make-breakpoint #'main-hook-function
+ (sb!di:make-breakpoint #'main-hook-fun
place
:kind :fun-end))
(setf break
print-functions)))
(setup-code-location ()
(setf place (nth index *possible-breakpoints*))
- (setf bp (sb!di:make-breakpoint #'main-hook-function
- place
+ (setf bp (sb!di:make-breakpoint #'main-hook-fun place
:kind :code-location))
(dolist (form print)
(push (cons
(call-next-method)
(when (and (legal-fun-name-p x)
(fboundp x))
- (%describe-function (fdefinition x) s :function x)
+ (%describe-fun (fdefinition x) s :function x)
;;was: (format s "~@:_Its FDEFINITION is ~S.~@:_" (fdefinition x))
;; TO DO: should check for SETF documentation.
;; TO DO: should make it clear whether the definition is a
;;; Describe a compiled function. The closure case calls us to print
;;; the guts.
-(defun %describe-function-compiled (x s kind name)
+(defun %describe-fun-compiled (x s kind name)
(declare (type stream s))
;; FIXME: The lowercaseness of %SIMPLE-FUN-ARGLIST results, and the
;; non-sentenceness of the "Arguments" label, makes awkward output.
;;; Describe a function with the specified kind and name. The latter
;;; arguments provide some information about where the function came
;;; from. KIND=NIL means not from a name.
-(defun %describe-function (x s &optional (kind nil) name)
+(defun %describe-fun (x s &optional (kind nil) name)
(declare (type function x))
(declare (type stream s))
(declare (type (member :macro :function nil) kind))
(%fun-name x))
(case (widetag-of x)
(#.sb-vm:closure-header-widetag
- (%describe-function-compiled (%closure-fun x) s kind name)
+ (%describe-fun-compiled (%closure-fun x) s kind name)
(format s "~@:_Its closure environment is:")
(pprint-logical-block (s nil)
(pprint-indent :current 8)
(dotimes (i (- (get-closure-length x) (1- sb-vm:closure-info-offset)))
(format s "~@:_~S: ~S" i (%closure-index-ref x i)))))
((#.sb-vm:simple-fun-header-widetag #.sb-vm:closure-fun-header-widetag)
- (%describe-function-compiled x s kind name))
+ (%describe-fun-compiled x s kind name))
(#.sb-vm:funcallable-instance-header-widetag
(typecase x
(standard-generic-function
(format s "~@:_It is an unknown type of function."))))
(defmethod describe-object ((x function) s)
- (%describe-function x s))
+ (%describe-fun x s))
(defmethod describe-object ((x symbol) s)
(declare (type stream s))
;; Describe the function cell.
(cond ((macro-function x)
- (%describe-function (macro-function x) s :macro x))
+ (%describe-fun (macro-function x) s :macro x))
((special-operator-p x)
(%describe-doc x s 'function "Special form"))
((fboundp x)
- (%describe-function (fdefinition x) s :function x)))
+ (%describe-fun (fdefinition x) s :function x)))
;; FIXME: Print out other stuff from the INFO database:
;; * Does it name a type?
("Simple type predicate" "STRUCTUREP" "LISTP" "FIXNUMP")
("Simple type check" "CHECK-LIST" "CHECK-FIXNUM" "CHECK-STRUCTURE")
("Array bounds check" "CHECK-BOUND")
- ("Complex type check" "$CHECK-" "COERCE-TO-FUNCTION")
+ ("Complex type check" "$CHECK-" "COERCE-TO-FUN")
("Special read" "SYMBOL-VALUE")
("Special bind" "BIND$")
("Tagging" "MOVE-FROM")
\f
;;;; the FOP database
-(declaim (simple-vector *fop-names* *fop-functions*))
+(declaim (simple-vector *fop-names* *fop-funs*))
;;; a vector indexed by a FaslOP that yields the FOP's name
(defvar *fop-names* (make-array 256 :initial-element nil))
;;; a vector indexed by a FaslOP that yields a function of 0 arguments
;;; which will perform the operation
-(defvar *fop-functions*
+(defvar *fop-funs*
(make-array 256
:initial-element (lambda ()
(error "corrupt fasl file: losing FOP"))))
(error "multiple codes for fop name ~S: ~D and ~D" name code ocode)))
(setf (svref *fop-names* code) name
(get name 'fop-code) code
- (svref *fop-functions* code) (symbol-function name))
+ (svref *fop-funs* code) (symbol-function name))
(values))
;;; Define a pair of fops which are identical except that one reads
(setf (code-header-ref code (clone-arg)) value)
(values)))
-(define-fop (fop-function-entry 142)
+(define-fop (fop-fun-entry 142)
#+sb-xc-host ; since xc host doesn't know how to compile %PRIMITIVE
- (error "FOP-FUNCTION-ENTRY can't be defined without %PRIMITIVE.")
+ (error "FOP-FUN-ENTRY can't be defined without %PRIMITIVE.")
#-sb-xc-host
(let ((type (pop-stack))
(arglist (pop-stack))
(deferr unknown-error (&rest args)
(error "unknown error:~{ ~S~})" args))
-(deferr object-not-function-error (object)
+(deferr object-not-fun-error (object)
(error 'type-error
:datum object
:expected-type 'function))
(symbol fdefn-or-symbol)
(fdefn (fdefn-name fdefn-or-symbol)))))
-(deferr object-not-coerceable-to-function-error (object)
+(deferr object-not-coerceable-to-fun-error (object)
(error 'type-error
:datum object
- :expected-type 'coerceable-to-function))
+ :expected-type 'coerceable-to-fun))
(deferr invalid-argument-count-error (nargs)
(error 'simple-program-error
:format-control "attempt to THROW to a tag that does not exist: ~S"
:format-arguments (list tag)))
-(deferr nil-function-returned-error (function)
+(deferr nil-fun-returned-error (function)
(error 'simple-control-error
:format-control
"A function with declared result type NIL returned:~% ~S"
(svref *fop-names* byte)
byte
(1- (file-position stream))
- (svref *fop-functions* byte))))
+ (svref *fop-funs* byte))))
;; Actually execute the fop.
(if (eql byte 3)
(setq *fop-stack-pointer* index)
(setf (svref *fop-stack* index)
(svref *current-fop-table* (read-byte stream))))
- (funcall (the function (svref *fop-functions* byte))))))))))
+ (funcall (the function (svref *fop-funs* byte))))))))))
(defun load-as-fasl (stream verbose print)
;; KLUDGE: ANSI says it's good to do something with the :PRINT
;;; a hash table that maps each traced function to the TRACE-INFO. The
;;; entry for a closure is the shared function-entry object.
-(defvar *traced-functions* (make-hash-table :test 'eq))
+(defvar *traced-funs* (make-hash-table :test 'eq))
;;; A TRACE-INFO object represents all the information we need to
;;; trace a given function.
(defun trace-redefined-update (fname new-value)
(when (fboundp fname)
(let* ((fun (trace-fdefinition fname))
- (info (gethash fun *traced-functions*)))
+ (info (gethash fun *traced-funs*)))
(when (and info (trace-info-named info))
(untrace-1 fname)
(trace-1 fname info new-value)))))
(values definition t
(nth-value 2 (trace-fdefinition definition)))
(trace-fdefinition function-or-name))
- (when (gethash fun *traced-functions*)
+ (when (gethash fun *traced-funs*)
(warn "~S is already TRACE'd, untracing it." function-or-name)
(untrace-1 fun))
(sb-di:activate-breakpoint start)
(sb-di:activate-breakpoint end)))))
- (setf (gethash fun *traced-functions*) info)))
+ (setf (gethash fun *traced-funs*) info)))
function-or-name)
\f
`(let ,(binds) (list ,@(forms)))
`(list ,@(forms)))))
-(defun %list-traced-functions ()
- (loop for x being each hash-value in *traced-functions*
+(defun %list-traced-funs ()
+ (loop for x being each hash-value in *traced-funs*
collect (trace-info-what x)))
(defmacro trace (&rest specs)
-AFTER and -ALL forms are evaluated in the null environment."
(if specs
(expand-trace specs)
- '(%list-traced-functions)))
+ '(%list-traced-funs)))
\f
;;;; untracing
;;; Untrace one function.
(defun untrace-1 (function-or-name)
(let* ((fun (trace-fdefinition function-or-name))
- (info (gethash fun *traced-functions*)))
+ (info (gethash fun *traced-funs*)))
(cond
((not info)
(warn "Function is not TRACEd: ~S" function-or-name))
(sb-di:delete-breakpoint (trace-info-start-breakpoint info))
(sb-di:delete-breakpoint (trace-info-end-breakpoint info))))
(setf (trace-info-untraced info) t)
- (remhash fun *traced-functions*)))))
+ (remhash fun *traced-funs*)))))
;;; Untrace all traced functions.
(defun untrace-all ()
- (dolist (fun (%list-traced-functions))
+ (dolist (fun (%list-traced-funs))
(untrace-1 fun))
t)
(defvar *ignorable-vars*)
(declaim (type list *ignorable-vars*))
-;;; Return, as multiple-values, a body, possibly a declare form to put where
-;;; this code is inserted, the documentation for the parsed body, and bounds
-;;; on the number of arguments.
+;;; Return, as multiple values, a body, possibly a declare form to put
+;;; where this code is inserted, the documentation for the parsed
+;;; body, and bounds on the number of arguments.
(defun parse-defmacro (lambda-list arg-list-name body name error-kind
&key
(anonymousp nil)
(pprint-fill stream (pprint-pop))
(pprint-tagbody-guts stream)))
-(defun pprint-function-call (stream list &rest noise)
+(defun pprint-fun-call (stream list &rest noise)
(declare (ignore noise))
(funcall (formatter "~:<~^~W~^ ~:_~:I~@{~W~^ ~_~}~:>")
stream
(/show0 "doing SET-PPRINT-DISPATCH for regular types")
(set-pprint-dispatch 'array #'pprint-array)
(set-pprint-dispatch '(cons (and symbol (satisfies fboundp)))
- #'pprint-function-call -1)
+ #'pprint-fun-call -1)
(set-pprint-dispatch 'cons #'pprint-fill -2)
;; cons cells with interesting things for the car
(/show0 "doing SET-PPRINT-DISPATCH for CONS with interesting CAR")
(function
(unless (and (funcallable-instance-p object)
(printed-as-funcallable-standard-class object stream))
- (output-function object stream)))
+ (output-fun object stream)))
(symbol
(output-symbol object stream))
(number
;;; This variable contains the current definition of one of three
;;; symbol printers. SETUP-PRINTER-STATE sets this variable.
-(defvar *internal-symbol-output-function* nil)
+(defvar *internal-symbol-output-fun* nil)
;;; This function sets the internal global symbol
-;;; *INTERNAL-SYMBOL-OUTPUT-FUNCTION* to the right function depending
-;;; on the value of *PRINT-CASE*. See the manual for details. The
-;;; print buffer stream is also reset.
+;;; *INTERNAL-SYMBOL-OUTPUT-FUN* to the right function depending on
+;;; the value of *PRINT-CASE*. See the manual for details. The print
+;;; buffer stream is also reset.
(defun setup-printer-state ()
(unless (and (eq *print-case* *previous-case*)
(eq (readtable-case *readtable*) *previous-readtable-case*))
(setf (readtable-case *readtable*) :upcase)
(error "invalid READTABLE-CASE value: ~S" *previous-readtable-case*))
- (setq *internal-symbol-output-function*
+ (setq *internal-symbol-output-fun*
(case *previous-readtable-case*
(:upcase
(case *print-case*
(setup-printer-state)
(if (and maybe-quote (symbol-quotep name))
(output-quoted-symbol-name name stream)
- (funcall *internal-symbol-output-function* name stream)))
+ (funcall *internal-symbol-output-fun* name stream)))
\f
;;;; escaping symbols
(when (test letter) (advance OTHER nil))
(go DIGIT))))
\f
-;;;; *INTERNAL-SYMBOL-OUTPUT-FUNCTION*
+;;;; *INTERNAL-SYMBOL-OUTPUT-FUN*
;;;;
-;;;; Case hackery. These functions are stored in
-;;;; *INTERNAL-SYMBOL-OUTPUT-FUNCTION* according to the values of
+;;;; case hackery: These functions are stored in
+;;;; *INTERNAL-SYMBOL-OUTPUT-FUN* according to the values of
;;;; *PRINT-CASE* and READTABLE-CASE.
;;; called when:
(declare (ignore object stream))
nil)
-(defun output-function (object stream)
+(defun output-fun (object stream)
(let* ((*print-length* 3) ; in case we have to..
(*print-level* 3) ; ..print an interpreted function definition
;; FIXME: This find-the-function-name idiom ought to be
;;; A symbol or (SETF FOO) list names a function, a string names all
;;; the functions named by symbols in the named package.
-(defun mapc-on-named-functions (function names)
+(defun mapc-on-named-funs (function names)
(dolist (name names)
(etypecase name
(symbol (funcall function name))
;;; Profile the named function, which should exist and not be profiled
;;; already.
-(defun profile-1-unprofiled-function (name)
+(defun profile-1-unprofiled-fun (name)
(let ((encapsulated-fun (fdefinition name)))
(multiple-value-bind (encapsulation-fun read-stats-fun clear-stats-fun)
(profile-encapsulation-lambdas encapsulated-fun)
(values))))
;;; Profile the named function. If already profiled, unprofile first.
-(defun profile-1-function (name)
+(defun profile-1-fun (name)
(cond ((fboundp name)
(when (gethash name *profiled-fun-name->info*)
(warn "~S is already profiled, so unprofiling it first." name)
- (unprofile-1-function name))
- (profile-1-unprofiled-function name))
+ (unprofile-1-fun name))
+ (profile-1-unprofiled-fun name))
(t
(warn "ignoring undefined function ~S" name)))
(values))
;;; Unprofile the named function, if it is profiled.
-(defun unprofile-1-function (name)
+(defun unprofile-1-fun (name)
(let ((pinfo (gethash name *profiled-fun-name->info*)))
(cond (pinfo
(remhash name *profiled-fun-name->info*)
(if (null names)
`(loop for k being each hash-key in *profiled-fun-name->info*
collecting k)
- `(mapc-on-named-functions #'profile-1-function ',names)))
+ `(mapc-on-named-funs #'profile-1-fun ',names)))
(defmacro unprofile (&rest names)
#+sb-doc
named package. NAMES defaults to the list of names of all currently
profiled functions."
(if names
- `(mapc-on-named-functions #'unprofile-1-function ',names)
+ `(mapc-on-named-funs #'unprofile-1-fun ',names)
`(unprofile-all)))
(defun unprofile-all ()
(dohash (name profile-info *profiled-fun-name->info*)
(declare (ignore profile-info))
- (unprofile-1-function name)))
+ (unprofile-1-fun name)))
(defun reset ()
"Reset the counters for all profiled functions."
function
report-function
interactive-function
- (test-function (lambda (cond) (declare (ignore cond)) t)))
+ (test-fun (lambda (cond) (declare (ignore cond)) t)))
(def!method print-object ((restart restart) stream)
(if *print-escape*
(print-unreadable-object (restart stream :type t :identity t)
(defun compute-restarts (&optional condition)
#!+sb-doc
"Return a list of all the currently active restarts ordered from most
- recently established to less recently established. If Condition is
- specified, then only restarts associated with Condition (or with no
+ recently established to less recently established. If CONDITION is
+ specified, then only restarts associated with CONDITION (or with no
condition) will be returned."
(let ((associated ())
(other ()))
(when (and (or (not condition)
(member restart associated)
(not (member restart other)))
- (funcall (restart-test-function restart) condition))
+ (funcall (restart-test-fun restart) condition))
(res restart))))
(res))))
:interactive-function
result)))
(when test
- (setq result (list* `#',test
- :test-function
- result)))
+ (setq result (list* `#',test :test-fun result)))
(nreverse result)))
(parse-keyword-pairs (list keys)
(do ((l list (cddr l))
#-cmu nil
#+cmu (cl::*gc-trigger*
cl::inch-ptr
- cl::*internal-symbol-output-function*
+ cl::*internal-symbol-output-fun*
cl::ouch-ptr
cl::*previous-case*
cl::read-buffer
sb!c::%odd-key-arguments-error)
(frob unknown-key-argument-error unknown-key-argument-error
sb!c::%unknown-key-argument-error key)
- (frob nil-function-returned-error nil-function-returned-error nil fun))
+ (frob nil-fun-returned-error nil-fun-returned-error nil fun))
\f
;;;; float move functions
-(define-move-function (load-fp-zero 1) (vop x y)
+(define-move-fun (load-fp-zero 1) (vop x y)
((fp-single-zero) (single-reg)
(fp-double-zero) (double-reg))
(inst fmove x y))
-(define-move-function (load-single 1) (vop x y)
+(define-move-fun (load-single 1) (vop x y)
((single-stack) (single-reg))
(inst lds y (* (tn-offset x) n-word-bytes) (current-nfp-tn vop)))
-(define-move-function (store-single 1) (vop x y)
+(define-move-fun (store-single 1) (vop x y)
((single-reg) (single-stack))
(inst sts x (* (tn-offset y) n-word-bytes) (current-nfp-tn vop)))
-
-(define-move-function (load-double 2) (vop x y)
+(define-move-fun (load-double 2) (vop x y)
((double-stack) (double-reg))
(let ((nfp (current-nfp-tn vop))
(offset (* (tn-offset x) n-word-bytes)))
(inst ldt y offset nfp)))
-(define-move-function (store-double 2) (vop x y)
+(define-move-fun (store-double 2) (vop x y)
((double-reg) (double-stack))
(let ((nfp (current-nfp-tn vop))
(offset (* (tn-offset y) n-word-bytes)))
:offset (1+ (tn-offset x))))
-(define-move-function (load-complex-single 2) (vop x y)
+(define-move-fun (load-complex-single 2) (vop x y)
((complex-single-stack) (complex-single-reg))
(let ((nfp (current-nfp-tn vop))
(offset (* (tn-offset x) n-word-bytes)))
(let ((imag-tn (complex-single-reg-imag-tn y)))
(inst lds imag-tn (+ offset n-word-bytes) nfp))))
-(define-move-function (store-complex-single 2) (vop x y)
+(define-move-fun (store-complex-single 2) (vop x y)
((complex-single-reg) (complex-single-stack))
(let ((nfp (current-nfp-tn vop))
(offset (* (tn-offset y) n-word-bytes)))
(inst sts imag-tn (+ offset n-word-bytes) nfp))))
-(define-move-function (load-complex-double 4) (vop x y)
+(define-move-fun (load-complex-double 4) (vop x y)
((complex-double-stack) (complex-double-reg))
(let ((nfp (current-nfp-tn vop))
(offset (* (tn-offset x) n-word-bytes)))
(let ((imag-tn (complex-double-reg-imag-tn y)))
(inst ldt imag-tn (+ offset (* 2 n-word-bytes)) nfp))))
-(define-move-function (store-complex-double 4) (vop x y)
+(define-move-fun (store-complex-double 4) (vop x y)
((complex-double-reg) (complex-double-stack))
(let ((nfp (current-nfp-tn vop))
(offset (* (tn-offset y) n-word-bytes)))
(in-package "SB!VM")
-(define-move-function (load-immediate 1) (vop x y)
+(define-move-fun (load-immediate 1) (vop x y)
((null zero immediate)
(any-reg descriptor-reg))
(let ((val (tn-value x)))
(inst li (logior (ash (char-code val) n-widetag-bits) base-char-widetag)
y)))))
-(define-move-function (load-number 1) (vop x y)
+(define-move-fun (load-number 1) (vop x y)
((zero immediate)
(signed-reg unsigned-reg))
(inst li (tn-value x) y))
-(define-move-function (load-base-char 1) (vop x y)
+(define-move-fun (load-base-char 1) (vop x y)
((immediate) (base-char-reg))
(inst li (char-code (tn-value x)) y))
-(define-move-function (load-system-area-pointer 1) (vop x y)
+(define-move-fun (load-system-area-pointer 1) (vop x y)
((immediate) (sap-reg))
(inst li (sap-int (tn-value x)) y))
-(define-move-function (load-constant 5) (vop x y)
+(define-move-fun (load-constant 5) (vop x y)
((constant) (descriptor-reg any-reg))
(loadw y code-tn (tn-offset x) other-pointer-lowtag))
-(define-move-function (load-stack 5) (vop x y)
+(define-move-fun (load-stack 5) (vop x y)
((control-stack) (any-reg descriptor-reg))
(load-stack-tn y x))
-(define-move-function (load-number-stack 5) (vop x y)
+(define-move-fun (load-number-stack 5) (vop x y)
((base-char-stack) (base-char-reg))
(let ((nfp (current-nfp-tn vop)))
(loadw y nfp (tn-offset x))))
-(define-move-function (load-number-stack-64 5) (vop x y)
+(define-move-fun (load-number-stack-64 5) (vop x y)
((sap-stack) (sap-reg)
(signed-stack) (signed-reg)
(unsigned-stack) (unsigned-reg))
(let ((nfp (current-nfp-tn vop)))
(loadq y nfp (tn-offset x))))
-(define-move-function (store-stack 5) (vop x y)
+(define-move-fun (store-stack 5) (vop x y)
((any-reg descriptor-reg null zero) (control-stack))
(store-stack-tn y x))
-(define-move-function (store-number-stack 5) (vop x y)
+(define-move-fun (store-number-stack 5) (vop x y)
((base-char-reg) (base-char-stack))
(let ((nfp (current-nfp-tn vop)))
(storew x nfp (tn-offset y))))
-(define-move-function (store-number-stack-64 5) (vop x y)
+(define-move-fun (store-number-stack-64 5) (vop x y)
((sap-reg) (sap-stack)
(signed-reg) (signed-stack)
(unsigned-reg) (unsigned-stack))
(let ((nfp (current-nfp-tn vop)))
(storeq x nfp (tn-offset y))))
\f
-;;;; The Move VOP
+;;;; the MOVE VOP
(define-vop (move)
(:args (x :target y
(def-type-vops fixnump check-fixnum fixnum object-not-fixnum-error
even-fixnum-lowtag odd-fixnum-lowtag)
-(def-type-vops functionp check-function function
- object-not-function-error fun-pointer-lowtag)
+(def-type-vops functionp check-fun function
+ object-not-fun-error fun-pointer-lowtag)
(def-type-vops listp check-list list object-not-list-error
list-pointer-lowtag)
;;;
;;; We special-case NULL, since it does have a source tranform and is
;;; interesting to us.
-(defun function-cost (name)
+(defun fun-guessed-cost (name)
(declare (symbol name))
(let ((info (info :function :info name))
(call-cost (template-cost (template-or-lose 'call-named))))
(let ((found (cdr (assoc type *backend-type-predicates*
:test #'type=))))
(if found
- (+ (function-cost found) (function-cost 'eq))
+ (+ (fun-guessed-cost found) (fun-guessed-cost 'eq))
nil))))
(typecase type
(compound-type
(reduce #'+ (compound-type-types type) :key 'type-test-cost))
(member-type
(* (length (member-type-members type))
- (function-cost 'eq)))
+ (fun-guessed-cost 'eq)))
(numeric-type
(* (if (numeric-type-complexp type) 2 1)
- (function-cost
+ (fun-guessed-cost
(if (csubtypep type (specifier-type 'fixnum)) 'fixnump 'numberp))
(+ 1
(if (numeric-type-low type) 1 0)
(if (numeric-type-high type) 1 0))))
(cons-type
(+ (type-test-cost (specifier-type 'cons))
- (function-cost 'car)
+ (fun-guessed-cost 'car)
(type-test-cost (cons-type-car-type type))
- (function-cost 'cdr)
+ (fun-guessed-cost 'cdr)
(type-test-cost (cons-type-cdr-type type))))
(t
- (function-cost 'typep)))))
+ (fun-guessed-cost 'typep)))))
\f
;;;; checking strategy determination
min-type
*universal-type*)))))
-;;; Like VALUES-TYPES, only mash any complex function types to FUNCTION.
-(defun no-function-values-types (type)
+;;; This is like VALUES-TYPES, only we mash any complex function types
+;;; to FUNCTION.
+(defun no-fun-values-types (type)
(declare (type ctype type))
(multiple-value-bind (res count) (values-types type)
(values (mapcar (lambda (type)
(defun maybe-negate-check (cont types force-hairy)
(declare (type continuation cont) (list types))
(multiple-value-bind (ptypes count)
- (no-function-values-types (continuation-proven-type cont))
+ (no-fun-values-types (continuation-proven-type cont))
(if (eq count :unknown)
(if (and (every #'type-check-template types) (not force-hairy))
(values :simple types)
(let ((type (continuation-asserted-type cont))
(dest (continuation-dest cont)))
(aver (not (eq type *wild-type*)))
- (multiple-value-bind (types count) (no-function-values-types type)
+ (multiple-value-bind (types count) (no-fun-values-types type)
(cond ((not (eq count :unknown))
(if (or (exit-p dest)
(and (return-p dest)
pos)))))))
(cond ((eq dtype *empty-type*))
((and (ref-p node) (constant-p (ref-leaf node)))
- (compiler-warning "~:[This~;~:*~A~] is not a ~<~%~9T~:;~S:~>~% ~S"
- what atype-spec (constant-value (ref-leaf node))))
+ (compiler-warn "~:[This~;~:*~A~] is not a ~<~%~9T~:;~S:~>~% ~S"
+ what atype-spec (constant-value (ref-leaf node))))
(t
- (compiler-warning
+ (compiler-warn
"~:[Result~;~:*~A~] is a ~S, ~<~%~9T~:;not a ~S.~>"
what (type-specifier dtype) atype-spec))))
(values))
;; FIXME: It might be nice to define a BUG or OOPS function for "shouldn't
;; happen" cases like this.
(error "internal error, control returned from *COMPILER-ERROR-BAILOUT*"))
-(defun compiler-warning (format-string &rest format-args)
+(defun compiler-warn (format-string &rest format-args)
(apply #'warn format-string format-args)
(values))
-(defun compiler-style-warning (format-string &rest format-args)
+(defun compiler-style-warn (format-string &rest format-args)
(apply #'style-warn format-string format-args)
(values))
res))
(t
(let ((*compiler-error-context* (block-last block)))
- (compiler-warning
+ (compiler-warn
"unreachable code in constraint ~
propagation -- apparent compiler bug"))
(make-sset))))
(in-package "SB!C")
+(declaim (type (or function null) *lossage-fun* *unwinnage-fun* *ctype-test-fun*))
+
;;; These are the functions that are to be called when a problem is
;;; detected. They are passed format arguments. If null, we don't do
-;;; anything. The error function is called when something is
-;;; definitely incorrect. The warning function is called when it is
-;;; somehow impossible to tell whether the call is correct.
-;;;
-;;; FIXME: *ERROR-FUNCTION* and *WARNING-FUNCTION* are now misnomers.
-;;; As per the KLUDGE note below, what the Python compiler
-;;; considered a "definite incompatibility" could easily be conforming
-;;; ANSI Common Lisp (if the incompatibility is across a compilation
-;;; unit boundary, and we don't keep track of whether it is..), so we
-;;; have to just report STYLE-WARNINGs instead of ERRORs or full
-;;; WARNINGs; and unlike CMU CL, we don't use the condition system
-;;; at all when we're reporting notes.
-(defvar *error-function*)
-(defvar *warning-function*)
-
-;;; The function that we use for type checking. The derived type is
-;;; the first argument and the type we are testing against is the
+;;; anything. The LOSSAGE function is called when something is
+;;; definitely incorrect. The UNWINNAGE function is called when it is
+;;; somehow impossible to tell whether the call is correct. (Thus,
+;;; they should correspond fairly closely to the FAILURE-P and WARNINGS-P
+;;; return values of CL:COMPILE and CL:COMPILE-FILE. However, see the
+;;; KLUDGE note below for *LOSSAGE-DETECTED*.)
+(defvar *lossage-fun*)
+(defvar *unwinnage-fun*)
+
+;;; the function that we use for type checking. The derived type is
+;;; its first argument and the type we are testing against is its
;;; second argument. The function should return values like CSUBTYPEP.
-(defvar *test-function*)
+(defvar *ctype-test-fun*)
;;; FIXME: Why is this a variable? Explain.
-(declaim (type (or function null) *error-function* *warning-function
- *test-function*))
-
;;; *LOSSAGE-DETECTED* is set when a "definite incompatibility" is
-;;; detected. *SLIME-DETECTED* is set when we can't tell whether the
-;;; call is compatible or not.
+;;; detected. *UNWINNAGE-DETECTED* is set when we can't tell whether the
+;;; call is compatible or not. Thus, they should correspond very closely
+;;; to the FAILURE-P and WARNINGS-P return values of CL:COMPILE and
+;;; CL:COMPILE-FILE.) However...
;;;
;;; KLUDGE: Common Lisp is a dynamic language, even if CMU CL was not.
;;; As far as I can see, none of the "definite incompatibilities"
;;; upgrade the code to keep track of that, we have to handle all
;;; these as STYLE-WARNINGs. -- WHN 2001-02-10
(defvar *lossage-detected*)
-(defvar *slime-detected*)
-;;; FIXME: "SLIME" is vivid and concise, but "DEFINITE-CALL-LOSSAGE" and
-;;; "POSSIBLE-CALL-LOSSAGE" would be more mnemonic.
+(defvar *unwinnage-detected*)
-;;; Signal a warning if appropriate and set *LOSSAGE-DETECTED*.
-(declaim (ftype (function (string &rest t) (values)) note-lossage note-slime))
+;;; Signal a warning if appropriate and set *FOO-DETECTED*.
+(declaim (ftype (function (string &rest t) (values)) note-lossage note-unwinnage))
(defun note-lossage (format-string &rest format-args)
(setq *lossage-detected* t)
- (when *error-function*
- (apply *error-function* format-string format-args))
+ (when *lossage-fun*
+ (apply *lossage-fun* format-string format-args))
(values))
-(defun note-slime (format-string &rest format-args)
- (setq *slime-detected* t)
- (when *warning-function*
- (apply *warning-function* format-string format-args))
+(defun note-unwinnage (format-string &rest format-args)
+ (setq *unwinnage-detected* t)
+ (when *unwinnage-fun*
+ (apply *unwinnage-fun* format-string format-args))
(values))
(declaim (special *compiler-error-context*))
;;; combination node so that COMPILER-WARNING and related functions
;;; will do the right thing if they are supplied.
(defun valid-function-use (call type &key
- ((:argument-test *test-function*) #'csubtypep)
+ ((:argument-test *ctype-test-fun*) #'csubtypep)
(result-test #'values-subtypep)
(strict-result nil)
- ((:error-function *error-function*))
- ((:warning-function *warning-function*)))
+ ((:lossage-fun *lossage-fun*))
+ ((:unwinnage-fun *unwinnage-fun*)))
(declare (type function result-test) (type combination call)
(type fun-type type))
(let* ((*lossage-detected* nil)
- (*slime-detected* nil)
+ (*unwinnage-detected* nil)
(*compiler-error-context* call)
(args (combination-args call))
(nargs (length args))
dtype))))
(multiple-value-bind (int win) (funcall result-test out-type return-type)
(cond ((not win)
- (note-slime "can't tell whether the result is a ~S"
- (type-specifier return-type)))
+ (note-unwinnage "can't tell whether the result is a ~S"
+ (type-specifier return-type)))
((not int)
(note-lossage "The result is a ~S, not a ~S."
(type-specifier out-type)
(type-specifier return-type))))))
(cond (*lossage-detected* (values nil t))
- (*slime-detected* (values nil nil))
+ (*unwinnage-detected* (values nil nil))
(t (values t t)))))
;;; Check that the derived type of the continuation CONT is compatible
(cond
((not (constant-type-p type))
(let ((ctype (continuation-type cont)))
- (multiple-value-bind (int win) (funcall *test-function* ctype type)
+ (multiple-value-bind (int win) (funcall *ctype-test-fun* ctype type)
(cond ((not win)
- (note-slime "can't tell whether the ~:R argument is a ~S"
- n (type-specifier type))
+ (note-unwinnage "can't tell whether the ~:R argument is a ~S"
+ n (type-specifier type))
nil)
((not int)
(note-lossage "The ~:R argument is a ~S, not a ~S."
n (type-specifier ctype) (type-specifier type))
nil)
((eq ctype *empty-type*)
- (note-slime "The ~:R argument never returns a value." n)
+ (note-unwinnage "The ~:R argument never returns a value." n)
nil)
(t t)))))
((not (constant-continuation-p cont))
- (note-slime "The ~:R argument is not a constant." n)
+ (note-unwinnage "The ~:R argument is not a constant." n)
nil)
(t
(let ((val (continuation-value cont))
(type (constant-type-type type)))
(multiple-value-bind (res win) (ctypep val type)
(cond ((not win)
- (note-slime "can't tell whether the ~:R argument is a ~
- constant ~S:~% ~S"
- n (type-specifier type) val)
+ (note-unwinnage "can't tell whether the ~:R argument is a ~
+ constant ~S:~% ~S"
+ n (type-specifier type) val)
nil)
((not res)
(note-lossage "The ~:R argument is not a constant ~S:~% ~S"
;;; Check that each of the type of each supplied argument intersects
;;; with the type specified for that argument. If we can't tell, then
-;;; we complain about the slime.
+;;; we can complain about the absence of manifest winnage.
(declaim (ftype (function (list list (or ctype null)) (values)) check-fixed-and-rest))
(defun check-fixed-and-rest (args types rest)
(do ((arg args (cdr arg))
;;; Check that the &KEY args are of the correct type. Each key should
;;; be known and the corresponding argument should be of the correct
-;;; type. If the key isn't a constant, then we can't tell, so we note
-;;; slime.
+;;; type. If the key isn't a constant, then we can't tell, so we can
+;;; complain about absence of manifest winnage.
(declaim (ftype (function (list fixnum fun-type) (values)) check-key-args))
(defun check-key-args (args pre-key type)
(do ((key (nthcdr pre-key args) (cddr key))
(cond
((not (check-arg-type k (specifier-type 'symbol) n)))
((not (constant-continuation-p k))
- (note-slime "The ~:R argument (in keyword position) is not a constant."
- n))
+ (note-unwinnage "The ~:R argument (in keyword position) is not a ~
+ constant."
+ n))
(t
(let* ((name (continuation-value k))
(info (find name (fun-type-keywords type)
(declaim (ftype (function (combination
&optional (or approximate-fun-type null))
approximate-fun-type)
- note-function-use))
-(defun note-function-use (call &optional type)
+ note-fun-use))
+(defun note-fun-use (call &optional type)
(let* ((type (or type (make-approximate-fun-type)))
(types (approximate-fun-type-types type))
(args (combination-args call))
(values boolean boolean))
valid-approximate-type))
(defun valid-approximate-type (call-type type &optional
- (*test-function*
+ (*ctype-test-fun*
#'types-equal-or-intersect)
- (*error-function*
- #'compiler-style-warning)
- (*warning-function* #'compiler-note))
+ (*lossage-fun*
+ #'compiler-style-warn)
+ (*unwinnage-fun* #'compiler-note))
(let* ((*lossage-detected* nil)
- (*slime-detected* nil)
+ (*unwinnage-detected* nil)
(required (fun-type-required type))
(min-args (length required))
(optional (fun-type-optional type))
rest)
(cond (*lossage-detected* (values nil t))
- (*slime-detected* (values nil nil))
+ (*unwinnage-detected* (values nil nil))
(t (values t t)))))
;;; Check that each of the types used at each arg position is
(defun check-approximate-arg-type (call-types decl-type context &rest args)
(let ((losers *empty-type*))
(dolist (ctype call-types)
- (multiple-value-bind (int win) (funcall *test-function* ctype decl-type)
+ (multiple-value-bind (int win) (funcall *ctype-test-fun* ctype decl-type)
(cond
((not win)
- (note-slime "can't tell whether previous ~? argument type ~S is a ~S"
- context args (type-specifier ctype) (type-specifier decl-type)))
+ (note-unwinnage "can't tell whether previous ~? ~
+ argument type ~S is a ~S"
+ context
+ args
+ (type-specifier ctype)
+ (type-specifier decl-type)))
((not int)
(setq losers (type-union ctype losers))))))
;;; from the FUN-TYPE.
;;;
;;; If there is a syntactic or type problem, then we call
-;;; ERROR-FUNCTION with an error message using WHERE as context
+;;; LOSSAGE-FUN with an error message using WHERE as context
;;; describing where FUN-TYPE came from.
;;;
;;; If there is no problem, we return T (even if REALLY-ASSERT was
;;; false). If there was a problem, we return NIL.
(defun assert-definition-type
(functional type &key (really-assert t)
- ((:error-function *error-function*)
- #'compiler-style-warning)
- warning-function
+ ((:lossage-fun *lossage-fun*)
+ #'compiler-style-warn)
+ unwinnage-fun
(where "previous declaration"))
(declare (type functional functional)
- (type function *error-function*)
+ (type function *lossage-fun*)
(string where))
(unless (fun-type-p type)
(return-from assert-definition-type t))
(assert-continuation-type (return-result return) atype))
(loop for var in vars and type in types do
(cond ((basic-var-sets var)
- (when (and warning-function
+ (when (and unwinnage-fun
(not (csubtypep (leaf-type var) type)))
- (funcall warning-function
+ (funcall unwinnage-fun
"Assignment to argument: ~S~% ~
prevents use of assertion from function ~
type ~A:~% ~S~%"
|#
))
- (check-function-consistency components)
+ (check-fun-consistency components)
(dolist (c components)
(do ((block (block-next (component-head c)) (block-next block)))
(setf (gethash x *seen-functions*) t)))
;;; Check that the specified function has been seen.
-(defun check-function-reached (fun where)
+(defun check-fun-reached (fun where)
(declare (type functional fun))
(unless (gethash fun *seen-functions*)
(barf "unseen function ~S in ~S" fun where)))
;;; In a CLAMBDA, check that the associated nodes are in seen blocks.
;;; In an OPTIONAL-DISPATCH, check that the entry points were seen. If
;;; the function is deleted, ignore it.
-(defun check-function-stuff (functional)
+(defun check-fun-stuff (functional)
(ecase (functional-kind functional)
(:external
(let ((fun (functional-entry-fun functional)))
- (check-function-reached fun functional)
+ (check-fun-reached fun functional)
(when (functional-kind fun)
(barf "The function for XEP ~S has kind." functional))
(unless (eq (functional-entry-fun fun) functional)
(barf "bad back-pointer in function for XEP ~S" functional))))
((:let :mv-let :assignment)
- (check-function-reached (lambda-home functional) functional)
+ (check-fun-reached (lambda-home functional) functional)
(when (functional-entry-fun functional)
(barf "The LET ~S has entry function." functional))
(unless (member functional (lambda-lets (lambda-home functional)))
(when (functional-entry-fun functional)
(barf ":OPTIONAL ~S has an ENTRY-FUN." functional))
(let ((ef (lambda-optional-dispatch functional)))
- (check-function-reached ef functional)
+ (check-fun-reached ef functional)
(unless (or (member functional (optional-dispatch-entry-points ef))
(eq functional (optional-dispatch-more-entry ef))
(eq functional (optional-dispatch-main-entry ef)))
((nil :escape :cleanup)
(let ((ef (functional-entry-fun functional)))
(when ef
- (check-function-reached ef functional)
+ (check-fun-reached ef functional)
(unless (eq (functional-kind ef) :external)
(barf "The ENTRY-FUN in ~S isn't an XEP: ~S." functional ef)))))
(:deleted
- (return-from check-function-stuff)))
+ (return-from check-fun-stuff)))
(case (functional-kind functional)
((nil :optional :external :toplevel :escape :cleanup)
(dolist (fun (lambda-lets functional))
(unless (eq (lambda-home fun) functional)
(barf "The home in ~S is not ~S." fun functional))
- (check-function-reached fun functional))
+ (check-fun-reached fun functional))
(unless (eq (lambda-home functional) functional)
(barf "home not self-pointer in ~S" functional)))))
(barf "HOME in ~S should be ~S." var functional))))
(optional-dispatch
(dolist (ep (optional-dispatch-entry-points functional))
- (check-function-reached ep functional))
+ (check-fun-reached ep functional))
(let ((more (optional-dispatch-more-entry functional)))
- (when more (check-function-reached more functional)))
- (check-function-reached (optional-dispatch-main-entry functional)
- functional))))
+ (when more (check-fun-reached more functional)))
+ (check-fun-reached (optional-dispatch-main-entry functional)
+ functional))))
-(defun check-function-consistency (components)
+(defun check-fun-consistency (components)
(dolist (c components)
(dolist (new-fun (component-new-funs c))
(observe-functional new-fun))
(dolist (c components)
(dolist (new-fun (component-new-funs c))
- (check-function-stuff new-fun))
+ (check-fun-stuff new-fun))
(dolist (fun (component-lambdas c))
(when (eq (functional-kind fun) :deleted)
(barf "deleted lambda ~S in Lambdas for ~S" fun c))
- (check-function-stuff fun)
+ (check-fun-stuff fun)
(dolist (let (lambda-lets fun))
- (check-function-stuff let)))))
+ (check-fun-stuff let)))))
\f
;;;; loop consistency checking
(this-cont (block-start block))
(last (block-last block)))
(unless fun-deleted
- (check-function-reached fun block))
+ (check-fun-reached fun block))
(when (not this-cont)
(barf "~S has no START." block))
(when (not last)
:toplevel)
(barf ":TOPLEVEL-XEP ref in non-top-level component: ~S"
node))
- (check-function-reached leaf node)))))
+ (check-fun-reached leaf node)))))
(basic-combination
(check-dest (basic-combination-fun node) node)
(dolist (arg (basic-combination-args node))
(cset
(check-dest (set-value node) node))
(bind
- (check-function-reached (bind-lambda node) node))
+ (check-fun-reached (bind-lambda node) node))
(creturn
- (check-function-reached (return-lambda node) node)
+ (check-fun-reached (return-lambda node) node)
(check-dest (return-result node) node)
(unless (eq (block-last (node-block node)) node)
(barf "RETURN not at block end: ~S" node)))
;; these are not in the params because they only exist at compile time
(defparameter ,(format-table-name) (make-hash-table))
(defparameter ,(arg-type-table-name) nil)
- (defparameter ,(function-cache-name) (make-function-cache)))
+ (defparameter ,(fun-cache-name) (make-fun-cache)))
(let ((params
(or sb!c:*backend-disassem-params*
(setf sb!c:*backend-disassem-params* (make-params)))))
|#
\f
;;;; cached functions
+;;;;
+;;;; FIXME: Is it important to cache these? For performance? Or why?
+;;;; If performance: *Really*? How fast does disassembly need to be??
+;;;; So: Could we just punt this?
-(defstruct (function-cache (:copier nil))
+(defstruct (fun-cache (:copier nil))
(printers nil :type list)
(labellers nil :type list)
(prefilters nil :type list))
-(defvar *disassem-function-cache* (make-function-cache))
-(declaim (type function-cache *disassem-function-cache*))
+(defvar *disassem-fun-cache* (make-fun-cache))
+(declaim (type fun-cache *disassem-fun-cache*))
\f
;;;; A DCHUNK contains the bits we look at to decode an
;;;; instruction.
(defvar *disassem-inst-formats* (make-hash-table))
(defvar *disassem-arg-types* nil)
-(defvar *disassem-function-cache* (make-function-cache))
+(defvar *disassem-fun-cache* (make-fun-cache))
(defstruct (argument (:conc-name arg-)
(:copier nil))
`(let* ((*current-instruction-flavor* ',(cons base-name format-name))
(,format-var (format-or-lose ',format-name))
(args ,(gen-args-def-form field-defs format-var evalp))
- (funcache *disassem-function-cache*))
+ (funcache *disassem-fun-cache*))
(multiple-value-bind (printer-fun printer-defun)
(find-printer-fun ',uniquified-name
',format-name
(values nil nil)
(let ((printer-source (preprocess-printer printer-source args)))
(!with-cached-function
- (name funstate cache function-cache-printers args
+ (name funstate cache fun-cache-printers args
:constraint printer-source
:stem (concatenate 'string
(string %name)
(if (null labelled-fields)
(values nil nil)
(!with-cached-function
- (name funstate cache function-cache-labellers args
+ (name funstate cache fun-cache-labellers args
:stem (concatenate 'string "LABELLER-" (string %name))
:constraint labelled-fields)
(let ((labels-form 'labels))
(if (null filtered-args)
(values nil nil)
(!with-cached-function
- (name funstate cache function-cache-prefilters args
+ (name funstate cache fun-cache-prefilters args
:stem (concatenate 'string
(string %name)
"-"
(dump-object name file)
(dump-object (sb!c::entry-info-arguments entry) file)
(dump-object (sb!c::entry-info-type entry) file)
- (dump-fop 'fop-function-entry file)
+ (dump-fop 'fop-fun-entry file)
(dump-unsigned-32 (label-position (sb!c::entry-info-offset entry)) file)
(dump-pop file)))
(debug-info () :type list))
;;; Note the existence of FUNCTION.
-(defun note-function (info function object)
+(defun note-fun (info function object)
(declare (type function function)
(type core-object object))
(let ((patch-table (core-object-patch-table object)))
;;;; general machinery for cold-loading FASL files
;;; FOP functions for cold loading
-(defvar *cold-fop-functions*
- ;; We start out with a copy of the ordinary *FOP-FUNCTIONS*. The
- ;; ones which aren't appropriate for cold load will be destructively
+(defvar *cold-fop-funs*
+ ;; We start out with a copy of the ordinary *FOP-FUNS*. The ones
+ ;; which aren't appropriate for cold load will be destructively
;; modified.
- (copy-seq *fop-functions*))
+ (copy-seq *fop-funs*))
-(defvar *normal-fop-functions*)
+(defvar *normal-fop-funs*)
;;; Cause a fop to have a special definition for cold load.
;;;
;;; This is similar to DEFINE-FOP, but unlike DEFINE-FOP, this version
;;; (1) looks up the code for this name (created by a previous
;; DEFINE-FOP) instead of creating a code, and
-;;; (2) stores its definition in the *COLD-FOP-FUNCTIONS* vector,
-;;; instead of storing in the *FOP-FUNCTIONS* vector.
+;;; (2) stores its definition in the *COLD-FOP-FUNS* vector,
+;;; instead of storing in the *FOP-FUNS* vector.
(defmacro define-cold-fop ((name &optional (pushp t)) &rest forms)
(aver (member pushp '(nil t :nope)))
(let ((code (get name 'fop-code))
,@(if (eq pushp :nope)
forms
`((with-fop-stack ,pushp ,@forms))))
- (setf (svref *cold-fop-functions* ,code) #',fname))))
+ (setf (svref *cold-fop-funs* ,code) #',fname))))
(defmacro clone-cold-fop ((name &optional (pushp t)) (small-name) &rest forms)
(aver (member pushp '(nil t :nope)))
(defun cold-load (filename)
#!+sb-doc
"Load the file named by FILENAME into the cold load image being built."
- (let* ((*normal-fop-functions* *fop-functions*)
- (*fop-functions* *cold-fop-functions*)
+ (let* ((*normal-fop-funs* *fop-funs*)
+ (*fop-funs* *cold-fop-funs*)
(*cold-load-filename* (etypecase filename
(string filename)
(pathname (namestring filename)))))
(define-cold-fop (fop-truth) (cold-intern t))
(define-cold-fop (fop-normal-load :nope)
- (setq *fop-functions* *normal-fop-functions*))
+ (setq *fop-funs* *normal-fop-funs*))
(define-fop (fop-maybe-cold-load 82 :nope)
(when *cold-load-filename*
- (setq *fop-functions* *cold-fop-functions*)))
+ (setq *fop-funs* *cold-fop-funs*)))
(define-cold-fop (fop-maybe-cold-load :nope))
(code (pop-stack)))
(write-wordindexed code slot value)))
-(define-cold-fop (fop-function-entry)
+(define-cold-fop (fop-fun-entry)
(let* ((type (pop-stack))
(arglist (pop-stack))
(name (pop-stack))
(define-internal-errors
(unknown
"unknown system lossage")
- (object-not-function
+ (object-not-fun
"Object is not of type FUNCTION.")
(object-not-list
"Object is not of type LIST.")
;; FIXME: Isn't this used for calls to unbound (SETF FOO) too? If so, revise
;; the name.
"An attempt was made to use an undefined FDEFINITION.")
- (object-not-coerceable-to-function
+ (object-not-coerceable-to-fun
"Object is not coerceable to type FUNCTION.")
(invalid-argument-count
"invalid argument count")
"Object is not a INSTANCE.")
(object-not-base-char
"Object is not of type BASE-CHAR.")
- (nil-function-returned
+ (nil-fun-returned
"A function with declared result type NIL returned.")
(layout-invalid
"Object layout is invalid. (indicates obsolete instance)")
(setf (%simple-fun-arglist res) (entry-info-arguments entry))
(setf (%simple-fun-type res) (entry-info-type entry))
- (note-function entry res object))))
+ (note-fun entry res object))))
;;; Dump a component to core. We pass in the assembler fixups, code
;;; vector and node info.
'sb!c:check-unsigned-byte-32)
(t nil)))
(fun-type
- 'sb!c:check-function)
+ 'sb!c:check-fun)
(t
nil)))
\f
(:function) ; happy case
((nil)) ; another happy case
(:macro ; maybe-not-so-good case
- (compiler-style-warning "~S was previously defined as a macro." name)
+ (compiler-style-warn "~S was previously defined as a macro." name)
(setf (info :function :where-from name) :assumed)
(clear-info :function :macro-function name))))
(when (consp name)
(when (or (info :setf :inverse name)
(info :setf :expander name))
- (compiler-style-warning
+ (compiler-style-warn
"defining as a SETF function a name that already has a SETF macro:~
~% ~S"
name)))
(declare (type list definitions))
(unless (= (length definitions)
(length (remove-duplicates definitions :key #'first)))
- (compiler-style-warning "duplicate definitions in ~S" definitions))
+ (compiler-style-warn "duplicate definitions in ~S" definitions))
(let* ((processed-definitions (mapcar definitionize-fun definitions))
(*lexenv* (make-lexenv definitionize-keyword processed-definitions)))
(funcall fun)))
(when (and (not intersects)
(not (policy *lexenv*
(= inhibit-warnings 3)))) ;FIXME: really OK to suppress?
- (compiler-warning
- "The type ~S in ~S declaration conflicts with an enclosing assertion:~% ~S"
+ (compiler-warn
+ "The type ~S in ~S declaration conflicts with an ~
+ enclosing assertion:~% ~S"
(type-specifier ctype)
name
(type-specifier old-type)))
(when (lambda-var-ignorep leaf)
;; ANSI's definition of "Declaration IGNORE, IGNORABLE"
;; requires that this be a STYLE-WARNING, not a full warning.
- (compiler-style-warning
+ (compiler-style-warn
"~S is being set even though it was declared to be ignored."
name)))
(set-variable start cont leaf (second things)))
(:function
(remhash name *free-functions*)
(undefine-fun-name name)
- (compiler-warning
+ (compiler-warn
"~S is being redefined as a macro when it was ~
previously ~(~A~) to be a function."
name
:argument-test #'types-equal-or-intersect
:result-test #'values-types-equal-or-intersect)
(collect ((messages))
- (flet ((frob (string &rest stuff)
+ (flet ((give-grief (string &rest stuff)
(messages string)
(messages stuff)))
(valid-function-use node what
- :warning-function #'frob
- :error-function #'frob))
+ :unwinnage-fun #'give-grief
+ :lossage-fun #'give-grief))
(compiler-note "~@<unable to ~
~2I~_~A ~
~I~_due to type uncertainty: ~
(when (and (eq (node-component ref) component)
(combination-p dest)
(eq (continuation-use (basic-combination-fun dest)) ref))
- (setq atype (note-function-use dest atype)))))
+ (setq atype (note-fun-use dest atype)))))
(setf (info :function :assumed-type name) atype))))
;;; Do miscellaneous things that we want to do once all optimization
(eq int *empty-type*)
(not (eq rtype *empty-type*)))
(let ((*compiler-error-context* node))
- (compiler-warning
+ (compiler-warn
"New inferred type ~S conflicts with old type:~
- ~% ~S~%*** Bug?"
+ ~% ~S~%*** possible internal error? Please report this."
(type-specifier rtype) (type-specifier node-type))))
(setf (node-derived-type node) int)
(reoptimize-continuation (node-cont node))))))
;; FIXME: Actually, I think we could
;; issue a full WARNING if the call
;; violates a DECLAIM FTYPE.
- :error-function #'compiler-style-warning
- :warning-function #'compiler-note)
+ :lossage-fun #'compiler-style-warn
+ :unwinnage-fun #'compiler-note)
(assert-call-type call type)
(maybe-terminate-block call ir1-converting-not-optimizing-p)
(recognize-known-call call ir1-converting-not-optimizing-p))
(:aborted
(setf (combination-kind node) :error)
(when args
- (apply #'compiler-warning args))
+ (apply #'compiler-warn args))
(remhash node table)
nil)
(:failure
(when total-nvals
(when (and min (< total-nvals min))
- (compiler-warning
+ (compiler-warn
"MULTIPLE-VALUE-CALL with ~R values when the function expects ~
at least ~R."
total-nvals min)
(setf (basic-combination-kind node) :error)
(return-from ir1-optimize-mv-call))
(when (and max (> total-nvals max))
- (compiler-warning
+ (compiler-warn
"MULTIPLE-VALUE-CALL with ~R values when the function expects ~
at most ~R."
total-nvals max)
(when (lambda-var-ignorep var)
;; (ANSI's specification for the IGNORE declaration requires
;; that this be a STYLE-WARNING, not a full WARNING.)
- (compiler-style-warning "reading an ignored variable: ~S" name)))
+ (compiler-style-warn "reading an ignored variable: ~S" name)))
(reference-leaf start cont var))
(cons
(aver (eq (car var) 'MACRO))
(type-approx-intersection2 old-type type))))
(cond ((eq int *empty-type*)
(unless (policy *lexenv* (= inhibit-warnings 3))
- (compiler-warning
+ (compiler-warn
"The type declarations ~S and ~S for ~S conflict."
(type-specifier old-type) (type-specifier type)
var-name)))
(found
(setf (leaf-type found) type)
(assert-definition-type found type
- :warning-function #'compiler-note
+ :unwinnage-fun #'compiler-note
:where "FTYPE declaration"))
(t
(res (cons (find-lexically-apparent-function
(when (lambda-var-ignorep var)
;; ANSI's definition for "Declaration IGNORE, IGNORABLE"
;; requires that this be a STYLE-WARNING, not a full WARNING.
- (compiler-style-warning
+ (compiler-style-warn
"The ignored variable ~S is being declared special."
name))
(setf (lambda-var-specvar var)
((not var)
;; ANSI's definition for "Declaration IGNORE, IGNORABLE"
;; requires that this be a STYLE-WARNING, not a full WARNING.
- (compiler-style-warning "declaring unknown variable ~S to be ignored"
- name))
+ (compiler-style-warn "declaring unknown variable ~S to be ignored"
+ name))
;; FIXME: This special case looks like non-ANSI weirdness.
((and (consp var) (consp (cdr var)) (eq (cadr var) 'macro))
;; Just ignore the IGNORE decl.
((lambda-var-specvar var)
;; ANSI's definition for "Declaration IGNORE, IGNORABLE"
;; requires that this be a STYLE-WARNING, not a full WARNING.
- (compiler-style-warning "declaring special variable ~S to be ignored"
- name))
+ (compiler-style-warn "declaring special variable ~S to be ignored"
+ name))
((eq (first spec) 'ignorable)
(setf (leaf-ever-used var) t))
(t
(dynamic-extent
(when (policy *lexenv* (> speed inhibit-warnings))
(compiler-note
- "compiler limitation:~
- ~% There's no special support for DYNAMIC-EXTENT (so it's ignored)."))
+ "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))
+ (compiler-warn "unrecognized declaration ~S" raw-spec))
res))))
;;; Use a list of DECLARE forms to annotate the lists of LAMBDA-VAR
;; 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
- :error-function #'compiler-style-warning
- :warning-function (cond (info #'compiler-style-warning)
- (for-real #'compiler-note)
- (t nil))
+ :lossage-fun #'compiler-style-warn
+ :unwinnage-fun (cond (info #'compiler-style-warn)
+ (for-real #'compiler-note)
+ (t nil))
:really-assert
(and for-real
(not (and info
(unless (policy *compiler-error-context* (= inhibit-warnings 3))
;; ANSI section "3.2.5 Exceptional Situations in the Compiler"
;; requires this to be no more than a STYLE-WARNING.
- (compiler-style-warning "The variable ~S is defined but never used."
- (leaf-debug-name var)))
+ (compiler-style-warn "The variable ~S is defined but never used."
+ (leaf-debug-name var)))
(setf (leaf-ever-used var) t)))) ; to avoid repeated warnings? -- WHN
(values))
(handler-case (apply function args)
(error (condition)
(let ((*compiler-error-context* node))
- (compiler-warning "Lisp error during ~A:~%~A" context condition)
+ (compiler-warn "Lisp error during ~A:~%~A" context condition)
(return-from careful-call (values nil nil))))))
t))
\f
(unless (or (node-tail-p last)
(info :function :info name)
(policy last (zerop safety)))
- (vop nil-function-returned-error last 2block
+ (vop nil-fun-returned-error last 2block
(if name
(emit-constant name)
(multiple-value-bind (tn named)
;; wrong. And we're in locall.lisp here, so it's probably
;; (haven't checked this..) a call to something in the same
;; file. So maybe it deserves a full warning anyway.
- (compiler-warning
+ (compiler-warn
"function called with ~R argument~:P, but wants exactly ~R"
call-args nargs)
(setf (basic-combination-kind call) :error)))))
(cond ((< call-args min-args)
;; FIXME: See FIXME note at the previous
;; wrong-number-of-arguments warnings in this file.
- (compiler-warning
+ (compiler-warn
"function called with ~R argument~:P, but wants at least ~R"
call-args min-args)
(setf (basic-combination-kind call) :error))
(t
;; FIXME: See FIXME note at the previous
;; wrong-number-of-arguments warnings in this file.
- (compiler-warning
+ (compiler-warn
"function called with ~R argument~:P, but wants at most ~R"
call-args max-args)
(setf (basic-combination-kind call) :error))))
(key-vars var))
((:rest :optional))
((:more-context :more-count)
- (compiler-warning "can't local-call functions with &MORE args")
+ (compiler-warn "can't local-call functions with &MORE args")
(setf (basic-combination-kind call) :error)
(return-from convert-more-call))))))
(when (optional-dispatch-keyp fun)
(when (oddp (length more))
- (compiler-warning "function called with odd number of ~
- arguments in keyword portion")
+ (compiler-warn "function called with odd number of ~
+ arguments in keyword portion")
(setf (basic-combination-kind call) :error)
(return-from convert-more-call))
(return)))))))
(when (and loser (not (optional-dispatch-allowp fun)))
- (compiler-warning "function called with unknown argument keyword ~S"
- loser)
+ (compiler-warn "function called with unknown argument keyword ~S"
+ loser)
(setf (basic-combination-kind call) :error)
(return-from convert-more-call)))
(when (losers)
(collect ((messages)
(count 0 +))
- (flet ((frob (string &rest stuff)
+ (flet ((lose1 (string &rest stuff)
(messages string)
(messages stuff)))
(dolist (loser (losers))
(when (and *efficiency-note-limit*
(>= (count) *efficiency-note-limit*))
- (frob "etc.")
+ (lose1 "etc.")
(return))
(let* ((type (template-type loser))
(valid (valid-function-use call type))
(strict-valid (valid-function-use call type
:strict-result t)))
- (frob "unable to do ~A (cost ~W) because:"
- (or (template-note loser) (template-name loser))
- (template-cost loser))
+ (lose1 "unable to do ~A (cost ~W) because:"
+ (or (template-note loser) (template-name loser))
+ (template-cost loser))
(cond
((and valid strict-valid)
- (strange-template-failure loser call ltn-policy #'frob))
+ (strange-template-failure loser call ltn-policy #'lose1))
((not valid)
(aver (not (valid-function-use call type
- :error-function #'frob
- :warning-function #'frob))))
+ :lossage-fun #'lose1
+ :unwinnage-fun #'lose1))))
(t
(aver (ltn-policy-safe-p ltn-policy))
- (frob "can't trust output type assertion under safe policy")))
+ (lose1 "can't trust output type assertion under safe policy")))
(count 1))))
(let ((*compiler-error-context* call))
(ir1-attributep (function-info-attributes info)
recursive))))))
(let ((*compiler-error-context* call))
- (compiler-warning "~@<recursion in known function definition~2I ~
- ~_policy=~S ~_arg types=~S~:>"
- (lexenv-policy (node-lexenv call))
- (mapcar (lambda (arg)
- (type-specifier (continuation-type
- arg)))
- args))))
+ (compiler-warn "~@<recursion in known function definition~2I ~
+ ~_policy=~S ~_arg types=~S~:>"
+ (lexenv-policy (node-lexenv call))
+ (mapcar (lambda (arg)
+ (type-specifier (continuation-type arg)))
+ args))))
(ltn-default-call call ltn-policy)
(return-from ltn-analyze-known-call (values)))
(setf (basic-combination-info call) template)
(warnings (undefined-warning-warnings undef))
(undefined-warning-count (undefined-warning-count undef)))
(dolist (*compiler-error-context* warnings)
- (compiler-style-warning "undefined ~(~A~): ~S" kind name))
+ (compiler-style-warn "undefined ~(~A~): ~S" kind name))
(let ((warn-count (length warnings)))
(when (and warnings (> undefined-warning-count warn-count))
(let ((more (- undefined-warning-count warn-count)))
- (compiler-style-warning
+ (compiler-style-warn
"~W more use~:P of undefined ~(~A~) ~S"
more kind name))))))
(remove kind undefs :test-not #'eq
:key #'undefined-warning-kind))))
(when summary
- (compiler-style-warning
+ (compiler-style-warn
"~:[This ~(~A~) is~;These ~(~A~)s are~] undefined:~
~% ~{~<~% ~1:;~S~>~^ ~}"
(cdr summary) kind summary)))))))
;;; of this move operation. The function is called with three
;;; arguments: the VOP (for context), and the source and destination
;;; TNs. An ASSEMBLE form is wrapped around the body. All uses of
-;;; DEFINE-MOVE-FUNCTION should be compiled before any uses of
+;;; DEFINE-MOVE-FUN should be compiled before any uses of
;;; DEFINE-VOP.
-(defmacro define-move-function ((name cost) lambda-list scs &body body)
+(defmacro define-move-fun ((name cost) lambda-list scs &body body)
(declare (type index cost))
(when (or (oddp (length scs)) (null scs))
(error "malformed SCs spec: ~S" scs))
(do-sc-pairs (from-sc to-sc ',scs)
(unless (eq from-sc to-sc)
(let ((num (sc-number from-sc)))
- (setf (svref (sc-move-functions to-sc) num) ',name)
+ (setf (svref (sc-move-funs to-sc) num) ',name)
(setf (svref (sc-load-costs to-sc) num) ',cost)))))
(defun ,name ,lambda-list
;;; from to the move function used for loading those SCs. We quietly
;;; ignore restrictions to :non-packed (constant) and :unbounded SCs,
;;; since we don't load into those SCs.
-(defun find-move-functions (op load-p)
+(defun find-move-funs (op load-p)
(collect ((funs))
(dolist (sc-name (operand-parse-scs op))
(let* ((sc (meta-sc-or-lose sc-name))
(unless (member (sc-name alt) (operand-parse-scs op) :test #'eq)
(let* ((altn (sc-number alt))
(name (if load-p
- (svref (sc-move-functions sc) altn)
- (svref (sc-move-functions alt) scn)))
+ (svref (sc-move-funs sc) altn)
+ (svref (sc-move-funs alt) scn)))
(found (or (assoc alt (funs) :test #'member)
(rassoc name (funs)))))
(unless name
;;; move function, then we just call that when there is a load TN. If
;;; there are multiple possible move functions, then we dispatch off
;;; of the operand TN's type to see which move function to use.
-(defun call-move-function (parse op load-p)
- (let ((funs (find-move-functions op load-p))
+(defun call-move-fun (parse op load-p)
+ (let ((funs (find-move-funs op load-p))
(load-tn (operand-parse-load-tn op)))
(if funs
(let* ((tn `(tn-ref-tn ,(operand-parse-temp op)))
(tn-ref-load-tn ,temp)))
(binds `(,name ,(decide-to-load parse op)))
(if (eq (operand-parse-kind op) :argument)
- (loads (call-move-function parse op t))
- (saves (call-move-function parse op nil))))
+ (loads (call-move-fun parse op t))
+ (saves (call-move-fun parse op nil))))
(t
(binds `(,name (tn-ref-tn ,temp)))))))
(:temporary
;;; Give someone a hard time because there isn't any load function
;;; defined to move from SRC to DEST.
-(defun no-load-function-error (src dest)
+(defun no-load-fun-error (src dest)
(let* ((src-sc (tn-sc src))
(src-name (sc-name src-sc))
(dest-sc (tn-sc dest))
(emit-load-template node block
(template-or-lose 'move-operand)
src dest
- (list (or (svref (sc-move-functions (tn-sc dest))
+ (list (or (svref (sc-move-funs (tn-sc dest))
(sc-number (tn-sc src)))
- (no-load-function-error src dest)))
+ (no-load-fun-error src dest)))
before)
(values))
(do-ir2-blocks (block component)
(do ((vop (ir2-block-start-vop block) (vop-next vop)))
((null vop))
- (let ((target-fun (vop-info-target-function (vop-info vop))))
+ (let ((target-fun (vop-info-target-fun (vop-info vop))))
(when target-fun
(funcall target-fun vop)))))
(destructuring-bind (quality raw-value) q-and-v-or-just-q
(values quality raw-value)))
(cond ((not (policy-quality-name-p quality))
- (compiler-warning "ignoring unknown optimization quality ~
- ~S in ~S"
- quality spec))
+ (compiler-warn "ignoring unknown optimization quality ~
+ ~S in ~S"
+ quality spec))
((not (and (typep raw-value 'real) (<= 0 raw-value 3)))
- (compiler-warning "ignoring bad optimization value ~S in ~S"
- raw-value spec))
+ (compiler-warn "ignoring bad optimization value ~S in ~S"
+ raw-value spec))
(t
(push (cons quality (rational raw-value))
result)))))
(setf (info :declaration :recognized decl) t)))
(t
(unless (info :declaration :recognized kind)
- (compiler-warning "unrecognized declaration ~S" raw-form)))))
+ (compiler-warn "unrecognized declaration ~S" raw-form)))))
#+sb-xc (/show0 "returning from PROCLAIM")
(values))
;;;; load time.
;;; FIXME: should probably be conditional on #!+SB-SHOW
-(defun check-move-function-consistency ()
+(defun check-move-fun-consistency ()
(dotimes (i sc-number-limit)
(let ((sc (svref *backend-sc-numbers* i)))
(when sc
- (let ((moves (sc-move-functions sc)))
+ (let ((moves (sc-move-funs sc)))
(dolist (const (sc-constant-scs sc))
(unless (svref moves (sc-number const))
(warn "no move function defined to load SC ~S from constant ~
(warn "no move function defined to load SC ~S from alternate ~
SC ~S"
(sc-name sc) (sc-name alt)))
- (unless (svref (sc-move-functions alt) i)
+ (unless (svref (sc-move-funs alt) i)
(warn "no move function defined to save SC ~S to alternate ~
SC ~S"
(sc-name sc) (sc-name alt)))))))))
(not (offs-hook-before-address next-hook))))
(return))
(unless (< hook-offs cur-offs)
- (funcall (offs-hook-function next-hook) stream dstate))
+ (funcall (offs-hook-fun next-hook) stream dstate))
(pop (dstate-cur-offs-hooks dstate))
(unless (= (dstate-next-offs dstate) cur-offs)
(return)))))))
\f
;;; Return a list of the segments of memory containing machine code
;;; instructions for FUNCTION.
-(defun get-function-segments (function)
+(defun get-fun-segments (function)
(declare (type compiled-function function))
(let* ((code (fun-code function))
(fun-map (code-fun-map code))
;;;; top level functions
;;; Disassemble the machine code instructions for FUNCTION.
-(defun disassemble-function (function &key
- (stream *standard-output*)
- (use-labels t))
- (declare (type compiled-function function)
+(defun disassemble-fun (fun &key
+ (stream *standard-output*)
+ (use-labels t))
+ (declare (type compiled-function fun)
(type stream stream)
(type (member t nil) use-labels))
(let* ((dstate (make-dstate))
- (segments (get-function-segments function)))
+ (segments (get-fun-segments fun)))
(when use-labels
(label-segments segments dstate))
(disassemble-segments segments stream dstate)))
+;;; FIXME: We probably don't need this any more now that there are
+;;; no interpreted functions, only compiled ones.
(defun compile-function-lambda-expr (function)
(declare (type function function))
(multiple-value-bind (lambda closurep name)
(error "can't compile a lexical closure"))
(compile nil lambda)))
-(defun compiled-function-or-lose (thing &optional (name thing))
+(defun compiled-fun-or-lose (thing &optional (name thing))
(cond ((or (symbolp thing)
(and (listp thing)
(eq (car thing) 'setf)))
- (compiled-function-or-lose (fdefinition thing) thing))
+ (compiled-fun-or-lose (fdefinition thing) thing))
((functionp thing)
thing)
((and (listp thing)
(type (or (member t) stream) stream)
(type (member t nil) use-labels))
(pprint-logical-block (*standard-output* nil :per-line-prefix "; ")
- (disassemble-function (compiled-function-or-lose object)
- :stream stream
- :use-labels use-labels)
+ (disassemble-fun (compiled-fun-or-lose object)
+ :stream stream
+ :use-labels use-labels)
nil))
;;; Disassembles the given area of memory starting at ADDRESS and
(member-type
`(member ,object ',(member-type-members type)))
(args-type
- (compiler-warning "illegal type specifier for TYPEP: ~S"
- (cadr spec))
+ (compiler-warn "illegal type specifier for TYPEP: ~S"
+ (cadr spec))
`(%typep ,object ,spec))
(t nil))
(typecase type
;; if true, a function that is called with the VOP to do operand
;; targeting. This is done by modifying the TN-REF-TARGET slots in
;; the TN-REFS so that they point to other TN-REFS in the same VOP.
- (target-function nil :type (or null function))
+ (target-fun nil :type (or null function))
;; a function that emits assembly code for a use of this VOP when it
;; is called with the VOP structure. This is null if this VOP has no
;; specified generator (i.e. if it exists only to be inherited by
;; true if the values in this SC needs to be saved across calls
(save-p nil :type boolean)
;; vectors mapping from SC numbers to information about how to load
- ;; from the index SC to this one. Move-Functions holds the names of
- ;; the functions used to do loading, and Load-Costs holds the cost
- ;; of the corresponding Move-Functions. If loading is impossible,
- ;; then the entries are NIL. Load-Costs is initialized to have a 0
+ ;; from the index SC to this one. MOVE-FUNS holds the names of
+ ;; the functions used to do loading, and LOAD-COSTS holds the cost
+ ;; of the corresponding move functions. If loading is impossible,
+ ;; then the entries are NIL. LOAD-COSTS is initialized to have a 0
;; for this SC.
- (move-functions (make-array sc-number-limit :initial-element nil)
- :type sc-vector)
+ (move-funs (make-array sc-number-limit :initial-element nil)
+ :type sc-vector)
(load-costs (make-array sc-number-limit :initial-element nil)
:type sc-vector)
;; a vector mapping from SC numbers to possibly
(inst jmp :ne err-lab))))
;;; Various other error signallers.
-(macrolet ((frob (name error translate &rest args)
+(macrolet ((def (name error translate &rest args)
`(define-vop (,name)
,@(when translate
`((:policy :fast-safe)
(:save-p :compute-only)
(:generator 1000
(error-call vop ,error ,@args)))))
- (frob argument-count-error invalid-argument-count-error
+ (def argument-count-error invalid-argument-count-error
sb!c::%argument-count-error nargs)
- (frob type-check-error object-not-type-error sb!c::%type-check-error
+ (def type-check-error object-not-type-error sb!c::%type-check-error
object type)
- (frob layout-invalid-error layout-invalid-error sb!c::%layout-invalid-error
+ (def layout-invalid-error layout-invalid-error sb!c::%layout-invalid-error
object layout)
- (frob odd-key-arguments-error odd-key-arguments-error
+ (def odd-key-arguments-error odd-key-arguments-error
sb!c::%odd-key-arguments-error)
- (frob unknown-key-argument-error unknown-key-argument-error
+ (def unknown-key-argument-error unknown-key-argument-error
sb!c::%unknown-key-argument-error key)
- (frob nil-function-returned-error nil-function-returned-error nil fun))
+ (def nil-fun-returned-error nil-fun-returned-error nil fun))
\f
;;;; move functions
-;;; x is source, y is destination
-(define-move-function (load-single 2) (vop x y)
+;;; X is source, Y is destination.
+(define-move-fun (load-single 2) (vop x y)
((single-stack) (single-reg))
(with-empty-tn@fp-top(y)
(inst fld (ea-for-sf-stack x))))
-(define-move-function (store-single 2) (vop x y)
+(define-move-fun (store-single 2) (vop x y)
((single-reg) (single-stack))
(cond ((zerop (tn-offset x))
(inst fst (ea-for-sf-stack y)))
;; This may not be necessary as ST0 is likely invalid now.
(inst fxch x))))
-(define-move-function (load-double 2) (vop x y)
+(define-move-fun (load-double 2) (vop x y)
((double-stack) (double-reg))
(with-empty-tn@fp-top(y)
(inst fldd (ea-for-df-stack x))))
-(define-move-function (store-double 2) (vop x y)
+(define-move-fun (store-double 2) (vop x y)
((double-reg) (double-stack))
(cond ((zerop (tn-offset x))
(inst fstd (ea-for-df-stack y)))
(inst fxch x))))
#!+long-float
-(define-move-function (load-long 2) (vop x y)
+(define-move-fun (load-long 2) (vop x y)
((long-stack) (long-reg))
(with-empty-tn@fp-top(y)
(inst fldl (ea-for-lf-stack x))))
#!+long-float
-(define-move-function (store-long 2) (vop x y)
+(define-move-fun (store-long 2) (vop x y)
((long-reg) (long-stack))
(cond ((zerop (tn-offset x))
(store-long-float (ea-for-lf-stack y)))
;;; stored in a more precise form on chip. Anyhow, might as well use
;;; the feature. It can be turned off by hacking the
;;; "immediate-constant-sc" in vm.lisp.
-(define-move-function (load-fp-constant 2) (vop x y)
+(define-move-fun (load-fp-constant 2) (vop x y)
((fp-constant) (single-reg double-reg #!+long-float long-reg))
(let ((value (sb!c::constant-value (sb!c::tn-leaf x))))
(with-empty-tn@fp-top(y)
(make-random-tn :kind :normal :sc (sc-or-lose 'long-reg)
:offset (1+ (tn-offset x))))
-;;; x is source, y is destination.
-(define-move-function (load-complex-single 2) (vop x y)
+;;; X is source, Y is destination.
+(define-move-fun (load-complex-single 2) (vop x y)
((complex-single-stack) (complex-single-reg))
(let ((real-tn (complex-single-reg-real-tn y)))
(with-empty-tn@fp-top (real-tn)
(with-empty-tn@fp-top (imag-tn)
(inst fld (ea-for-csf-imag-stack x)))))
-(define-move-function (store-complex-single 2) (vop x y)
+(define-move-fun (store-complex-single 2) (vop x y)
((complex-single-reg) (complex-single-stack))
(let ((real-tn (complex-single-reg-real-tn x)))
(cond ((zerop (tn-offset real-tn))
(inst fst (ea-for-csf-imag-stack y))
(inst fxch imag-tn)))
-(define-move-function (load-complex-double 2) (vop x y)
+(define-move-fun (load-complex-double 2) (vop x y)
((complex-double-stack) (complex-double-reg))
(let ((real-tn (complex-double-reg-real-tn y)))
(with-empty-tn@fp-top(real-tn)
(with-empty-tn@fp-top(imag-tn)
(inst fldd (ea-for-cdf-imag-stack x)))))
-(define-move-function (store-complex-double 2) (vop x y)
+(define-move-fun (store-complex-double 2) (vop x y)
((complex-double-reg) (complex-double-stack))
(let ((real-tn (complex-double-reg-real-tn x)))
(cond ((zerop (tn-offset real-tn))
(inst fxch imag-tn)))
#!+long-float
-(define-move-function (load-complex-long 2) (vop x y)
+(define-move-fun (load-complex-long 2) (vop x y)
((complex-long-stack) (complex-long-reg))
(let ((real-tn (complex-long-reg-real-tn y)))
(with-empty-tn@fp-top(real-tn)
(inst fldl (ea-for-clf-imag-stack x)))))
#!+long-float
-(define-move-function (store-complex-long 2) (vop x y)
+(define-move-fun (store-complex-long 2) (vop x y)
((complex-long-reg) (complex-long-stack))
(let ((real-tn (complex-long-reg-real-tn x)))
(cond ((zerop (tn-offset real-tn))
(in-package "SB!VM")
-(define-move-function (load-immediate 1) (vop x y)
+(define-move-fun (load-immediate 1) (vop x y)
((immediate)
(any-reg descriptor-reg))
(let ((val (tn-value x)))
(inst mov y (logior (ash (char-code val) n-widetag-bits)
base-char-widetag))))))
-(define-move-function (load-number 1) (vop x y)
+(define-move-fun (load-number 1) (vop x y)
((immediate) (signed-reg unsigned-reg))
(inst mov y (tn-value x)))
-(define-move-function (load-base-char 1) (vop x y)
+(define-move-fun (load-base-char 1) (vop x y)
((immediate) (base-char-reg))
(inst mov y (char-code (tn-value x))))
-(define-move-function (load-system-area-pointer 1) (vop x y)
+(define-move-fun (load-system-area-pointer 1) (vop x y)
((immediate) (sap-reg))
(inst mov y (sap-int (tn-value x))))
-(define-move-function (load-constant 5) (vop x y)
+(define-move-fun (load-constant 5) (vop x y)
((constant) (descriptor-reg any-reg))
(inst mov y x))
-(define-move-function (load-stack 5) (vop x y)
+(define-move-fun (load-stack 5) (vop x y)
((control-stack) (any-reg descriptor-reg)
(base-char-stack) (base-char-reg)
(sap-stack) (sap-reg)
(unsigned-stack) (unsigned-reg))
(inst mov y x))
-(define-move-function (store-stack 5) (vop x y)
+(define-move-fun (store-stack 5) (vop x y)
((any-reg descriptor-reg) (control-stack)
(base-char-reg) (base-char-stack)
(sap-reg) (sap-stack)
(def-simple-type-vops fixnump check-fixnum fixnum object-not-fixnum-error
even-fixnum-lowtag odd-fixnum-lowtag)
-(def-type-vops functionp check-function function
- object-not-function-error fun-pointer-lowtag)
+(def-type-vops functionp check-fun function
+ object-not-fun-error fun-pointer-lowtag)
(def-type-vops listp check-list list object-not-list-error
list-pointer-lowtag)
(make-effective-method-function-simple generic-function form)
;; We have some sort of `real' effective method. Go off and get a
;; compiled function for it. Most of the real hair here is done by
- ;; the GET-FUNCTION mechanism.
+ ;; the GET-FUN mechanism.
(make-effective-method-function-internal generic-function form
method-alist-p wrappers-p)))
(effective-method-lambda (expand-effective-method-function
generic-function effective-method)))
(multiple-value-bind (cfunction constants)
- (get-function1 effective-method-lambda
- (lambda (form)
- (memf-test-converter form generic-function
- method-alist-p wrappers-p))
- (lambda (form)
- (memf-code-converter form generic-function
- metatypes applyp
- method-alist-p wrappers-p))
- (lambda (form)
- (memf-constant-converter form generic-function)))
+ (get-fun1 effective-method-lambda
+ (lambda (form)
+ (memf-test-converter form generic-function
+ method-alist-p wrappers-p))
+ (lambda (form)
+ (memf-code-converter form generic-function
+ metatypes applyp
+ method-alist-p wrappers-p))
+ (lambda (form)
+ (memf-constant-converter form generic-function)))
(lambda (method-alist wrappers)
(let* ((constants
(mapcar (lambda (constant)
initargs-form-list
new-keys
default-initargs-function
- shared-initialize-t-function
- shared-initialize-nil-function
+ shared-initialize-t-fun
+ shared-initialize-nil-fun
constants
combined-initialize-function ; allocate-instance + shared-initialize
make-instance-function ; nil means use gf
((default-initargs-function)
(let ((initargs-form-list (initialize-info-initargs-form-list info)))
(setf (initialize-info-cached-default-initargs-function info)
- (initialize-instance-simple-function
+ (initialize-instance-simple-fun
'default-initargs-function info
class initargs-form-list))))
((valid-p ri-valid-p)
(compute-valid-p
(list (list* 'reinitialize-instance proto nil)
(list* 'shared-initialize proto nil nil)))))))
- ((shared-initialize-t-function)
+ ((shared-initialize-t-fun)
(multiple-value-bind (initialize-form-list ignore)
(make-shared-initialize-form-list class keys t nil)
(declare (ignore ignore))
- (setf (initialize-info-cached-shared-initialize-t-function info)
- (initialize-instance-simple-function
- 'shared-initialize-t-function info
+ (setf (initialize-info-cached-shared-initialize-t-fun info)
+ (initialize-instance-simple-fun
+ 'shared-initialize-t-fun info
class initialize-form-list))))
- ((shared-initialize-nil-function)
+ ((shared-initialize-nil-fun)
(multiple-value-bind (initialize-form-list ignore)
(make-shared-initialize-form-list class keys nil nil)
(declare (ignore ignore))
- (setf (initialize-info-cached-shared-initialize-nil-function info)
- (initialize-instance-simple-function
- 'shared-initialize-nil-function info
+ (setf (initialize-info-cached-shared-initialize-nil-fun info)
+ (initialize-instance-simple-fun
+ 'shared-initialize-nil-fun info
class initialize-form-list))))
((constants combined-initialize-function)
(let ((initargs-form-list (initialize-info-initargs-form-list info))
(make-shared-initialize-form-list class new-keys t t)
(setf (initialize-info-cached-constants info) constants)
(setf (initialize-info-cached-combined-initialize-function info)
- (initialize-instance-simple-function
+ (initialize-instance-simple-fun
'combined-initialize-function info
class (append initargs-form-list initialize-form-list))))))
((make-instance-function-symbol)
info)))
(if separate-p
(values default-initargs-function
- (initialize-info-shared-initialize-t-function info))
+ (initialize-info-shared-initialize-t-fun info))
(values default-initargs-function
- (initialize-info-shared-initialize-t-function
+ (initialize-info-shared-initialize-t-fun
(initialize-info class (initialize-info-new-keys info)
nil allow-other-keys-arg))))))
(defvar *initialize-instance-simple-alist* nil)
(defvar *note-iis-entry-p* nil)
-(defvar *compiled-initialize-instance-simple-functions*
+(defvar *compiled-initialize-instance-simple-funs*
(make-hash-table :test 'equal))
-(defun initialize-instance-simple-function (use info class form-list)
+(defun initialize-instance-simple-fun (use info class form-list)
(let* ((pv-cell (get-pv-cell-for-class class))
(key (initialize-info-key info))
(sf-key (list* use (class-name (car key)) (cdr key))))
(if (or *compile-make-instance-functions-p*
- (gethash sf-key *compiled-initialize-instance-simple-functions*))
+ (gethash sf-key *compiled-initialize-instance-simple-funs*))
(multiple-value-bind (form args)
(form-list-to-lisp pv-cell form-list)
(let ((entry (assoc form *initialize-instance-simple-alist*
:test #'equal)))
(setf (gethash sf-key
- *compiled-initialize-instance-simple-functions*)
+ *compiled-initialize-instance-simple-funs*)
t)
(if entry
(setf (cdddr entry) (union (list sf-key) (cdddr entry)
(setf (cadr entry) function)
(setf (caddr entry) system)
(dolist (use uses)
- (setf (gethash use *compiled-initialize-instance-simple-functions*) t))
+ (setf (gethash use *compiled-initialize-instance-simple-funs*) t))
(setf (cdddr entry) (union uses (cdddr entry)
:test #'equal))))
(in-package "SB-PCL")
\f
-;;; GET-FUNCTION is the main user interface to this code. It is like
+;;; GET-FUN is the main user interface to this code. It is like
;;; COMPILE, only more efficient. It achieves this efficiency by
;;; reducing the number of times that the compiler needs to be called.
-;;; Calls to GET-FUNCTION in which the lambda forms differ only by constants
-;;; can use the same piece of compiled code. (For example, dispatch dfuns and
-;;; combined method functions can often be shared, if they differ only
-;;; by referring to different methods.)
+;;; Calls to GET-FUN in which the lambda forms differ only by
+;;; constants can use the same piece of compiled code. (For example,
+;;; dispatch dfuns and combined method functions can often be shared,
+;;; if they differ only by referring to different methods.)
;;;
-;;; If GET-FUNCTION is called with a lambda expression only, it will return
+;;; If GET-FUN is called with a lambda expression only, it will return
;;; a corresponding function. The optional constant-converter argument
;;; can be a function which will be called to convert each constant appearing
;;; in the lambda to whatever value should appear in the function.
;;;
;;; There are three internal functions which operate on the lambda argument
-;;; to GET-FUNCTION:
-;;; compute-test converts the lambda into a key to be used for lookup,
-;;; compute-code is used by get-new-fun-generator-internal to
+;;; to GET-FUN:
+;;; COMPUTE-TEST converts the lambda into a key to be used for lookup,
+;;; COMPUTE-CODE is used by get-new-fun-generator-internal to
;;; generate the actual lambda to be compiled, and
-;;; compute-constants is used to generate the argument list that is
+;;; COMPUTE-CONSTANTS is used to generate the argument list that is
;;; to be passed to the compiled function.
;;;
-(defun get-function (lambda
- &optional (test-converter #'default-test-converter)
- (code-converter #'default-code-converter)
- (constant-converter #'default-constant-converter))
- (function-apply (get-function-generator lambda test-converter code-converter)
+(defun get-fun (lambda &optional
+ (test-converter #'default-test-converter)
+ (code-converter #'default-code-converter)
+ (constant-converter #'default-constant-converter))
+ (function-apply (get-fun-generator lambda test-converter code-converter)
(compute-constants lambda constant-converter)))
-(defun get-function1 (lambda
- &optional (test-converter #'default-test-converter)
- (code-converter #'default-code-converter)
- (constant-converter #'default-constant-converter))
- (values (the function (get-function-generator lambda test-converter code-converter))
- (compute-constants lambda constant-converter)))
+(defun get-fun1 (lambda &optional
+ (test-converter #'default-test-converter)
+ (code-converter #'default-code-converter)
+ (constant-converter #'default-constant-converter))
+ (values (the function
+ (get-fun-generator lambda test-converter code-converter))
+ (compute-constants lambda constant-converter)))
(defun default-constantp (form)
(and (constantp form)
(defun fgen-generator-lambda (fgen) (svref fgen 3))
(defun fgen-system (fgen) (svref fgen 4))
\f
-(defun get-function-generator (lambda test-converter code-converter)
+(defun get-fun-generator (lambda test-converter code-converter)
(let* ((test (compute-test lambda test-converter))
(fgen (lookup-fgen test)))
(if fgen
(when (eq slot-names t)
(return-from shared-initialize
(call-initialize-function
- (initialize-info-shared-initialize-t-function
+ (initialize-info-shared-initialize-t-fun
(initialize-info (class-of instance) initargs))
instance initargs)))
(when (eq slot-names nil)
(return-from shared-initialize
(call-initialize-function
- (initialize-info-shared-initialize-nil-function
+ (initialize-info-shared-initialize-nil-fun
(initialize-info (class-of instance) initargs))
instance initargs)))
;; Initialize the instance's slots in a two step process:
(let ((check-qualifiers (legal-qualifiers-p method qualifiers))
(check-lambda-list (legal-lambda-list-p method lambda-list))
(check-specializers (legal-specializers-p method specializers))
- (check-function (legal-method-function-p method
- (or function
- fast-function)))
+ (check-fun (legal-method-function-p method
+ (or function
+ fast-function)))
(check-documentation (legal-documentation-p method documentation)))
(unless (eq check-qualifiers t)
(lose :qualifiers qualifiers check-qualifiers))
(lose :lambda-list lambda-list check-lambda-list))
(unless (eq check-specializers t)
(lose :specializers specializers check-specializers))
- (unless (eq check-function t)
- (lose :function function check-function))
+ (unless (eq check-fun t)
+ (lose :function function check-fun))
(unless (eq check-documentation t)
(lose :documentation documentation check-documentation)))))
`(and ,new-type ,@so-far)))))
(defun generate-discrimination-net-internal
- (gf methods types methods-function test-function type-function)
+ (gf methods types methods-function test-fun type-function)
(let* ((arg-info (gf-arg-info gf))
(precedence (arg-info-precedence arg-info))
(nreq (arg-info-number-required arg-info))
known-types))))
(cond ((determined-to-be nil) (do-if nil t))
((determined-to-be t) (do-if t t))
- (t (funcall test-function position type
+ (t (funcall test-fun position type
(do-if t) (do-if nil))))))))))
(do-column precedence methods ()))))
(make-dfun-lambda-list metatypes applyp)
(make-fast-method-call-lambda-list metatypes applyp))))
(multiple-value-bind (cfunction constants)
- (get-function1 `(,(if function-p
- 'sb-kernel:instance-lambda
- 'lambda)
- ,arglist
- ,@(unless function-p
- `((declare (ignore .pv-cell.
- .next-method-call.))))
- (locally (declare #.*optimize-speed*)
- (let ((emf ,net))
- ,(make-emf-call metatypes applyp 'emf))))
- #'net-test-converter
- #'net-code-converter
- (lambda (form)
- (net-constant-converter form generic-function)))
+ (get-fun1 `(,(if function-p
+ 'sb-kernel:instance-lambda
+ 'lambda)
+ ,arglist
+ ,@(unless function-p
+ `((declare (ignore .pv-cell.
+ .next-method-call.))))
+ (locally (declare #.*optimize-speed*)
+ (let ((emf ,net))
+ ,(make-emf-call metatypes applyp 'emf))))
+ #'net-test-converter
+ #'net-code-converter
+ (lambda (form)
+ (net-constant-converter form generic-function)))
(lambda (method-alist wrappers)
(let* ((alist (list nil))
(alist-tail alist))
;;; information, because the functions slot in SB-C::LEXENV is
;;; supposed to have a list of <Name MACRO . #<function> elements.
;;; So, now we hide our bits of interest in the walker-info slot in
-;;; our new BOGO-FUNCTION.
+;;; our new BOGO-FUN.
;;;
;;; MACROEXPAND-1 is the only SBCL function that gets called with the
;;; constructed environment argument.
,macros)))
,@body))
-;;; a unique tag to show that we're the intended caller of BOGO-FUNCTION
-(defvar *bogo-function-magic-tag*
- '(:bogo-function-magic-tag))
+;;; a unique tag to show that we're the intended caller of BOGO-FUN
+(defvar *bogo-fun-magic-tag*
+ '(:bogo-fun-magic-tag))
-;;; The interface of BOGO-FUNCTIONs (previously implemented as
-;;; FUNCALLABLE-INSTANCES) is just these two operations, so we can
-;;; do them with ordinary closures.
+;;; The interface of BOGO-FUNs (previously implemented as
+;;; FUNCALLABLE-INSTANCEs) is just these two operations, so we can do
+;;; them with ordinary closures.
;;;
-;;; KLUDGE: BOGO-FUNCTIONS are sorta weird, and MNA and I have both
-;;; hacked on this code without really figuring out what they're for.
-;;; (He changed them to work after some changes in the IR1 interpreter
+;;; KLUDGE: BOGO-FUNs are sorta weird, and MNA and I have both hacked
+;;; on this code without quite figuring out what they're for. (He
+;;; changed them to work after some changes in the IR1 interpreter
;;; made functions not be built lazily, and I changed them so that
;;; they don't need FUNCALLABLE-INSTANCE stuff, so that the F-I stuff
;;; can become less general.) There may be further simplifications or
;;; clarifications which could be done. -- WHN 2001-10-19
-(defun walker-info-to-bogo-function (walker-info)
+(defun walker-info-to-bogo-fun (walker-info)
(lambda (magic-tag &rest rest)
(aver (not rest)) ; else someone is using me in an unexpected way
- (aver (eql magic-tag *bogo-function-magic-tag*)) ; else ditto
+ (aver (eql magic-tag *bogo-fun-magic-tag*)) ; else ditto
walker-info))
-(defun bogo-function-to-walker-info (bogo-function)
- (declare (type function bogo-function))
- (funcall bogo-function *bogo-function-magic-tag*))
+(defun bogo-fun-to-walker-info (bogo-fun)
+ (declare (type function bogo-fun))
+ (funcall bogo-fun *bogo-fun-magic-tag*))
(defun with-augmented-environment-internal (env functions macros)
;; Note: In order to record the correct function definition, we
(list* (car m)
'sb-c::macro
(if (eq (car m) *key-to-walker-environment*)
- (walker-info-to-bogo-function (cadr m))
+ (walker-info-to-bogo-fun (cadr m))
(coerce (cadr m) 'function))))
macros)))))
(and entry
(eq (cadr entry) 'sb-c::macro)
(if (eq macro *key-to-walker-environment*)
- (values (bogo-function-to-walker-info (cddr entry)))
+ (values (bogo-fun-to-walker-info (cddr entry)))
(values (function-lambda-expression (cddr entry))))))))
\f
;;;; other environment hacking, not so SBCL-specific as the
(sb-kernel:%simple-fun-arglist fun))
(#.sb-vm:closure-header-widetag (has-arglist-info-p
(sb-kernel:%closure-fun fun)))
- ;; In code/describe.lisp, ll. 227 (%describe-function), we use a scheme
+ ;; In code/describe.lisp, ll. 227 (%describe-fun), we use a scheme
;; like above, and it seems to work. -- MNA 2001-06-12
;;
;; (There might be other cases with arglist info also.
;;; for internal versions, especially for internal versions off the
;;; main CVS branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"0.pre7.126"
+"0.pre7.127"
projects / sbcl.git / commitdiff