0.pre7.127:

	(There were >300 matches to
		"egrep -sn '^\(def[^(;&]*function' ..." before.)
	s/to-function/to-fun/
	s/hook-function/hook-fun/
	s/describe-function/describe-fun/
	s/bogo-function/bogo-fun/
	s/fop-fun/fop-fun/
	s/not-function/not-fun/
	s/named-function/named-fun/
	s/nil-function/nil-fun/
	s/\<t-function/t-fun/
	s/simple-function/simple-fun/
	s/function-call/fun-call/
	s/move-function/move-fun/
	s/traced-function/traced-fun/
	s/function-or-lose/fun-or-lose/
	s/disassemble-function/disassemble-fun/
	s/get-function/get-fun/
	s/output-function/output-fun/
	s/1[-a-z0-9]*function/1$1fun/
	s/note-function/note-fun/
	s/check-function/check-fun/
	s/function-cache/fun-cache/
	s/disassem-function/disassem-fun/
	s/function-cost/fun-guessed-cost/
	s/function-value/fun-value/
	not just s/function/fun/, but also clearing up mess of (1)
		LOSSAGE/SLIME (esp. SLIME), what do they mean? and
		(2) "ERROR" and "WARNING" used in names even though
		the condition system isn't involved...
	...s/error-function/lossage-fun/
	...s/warning-function/unwinnage-fun/
	...s/slime/unwinnage/
	other confusion/inconstency...
	...s/compiler-style-warning/compiler-style-warn/ when used
		as verb (as opposed to used as condition name)
	...and similarly for s/compiler-warning/compiler-warn/
	s/test-function/test-fun/
	s/\*test-fun\*/*ctype-test-fun*/
	(There are now some 230 hits to the egrep at the start, mostly in
		src/pcl/*, where I'm trying to tread lightly to avoid
		gratuitously breaking quasistandard MOPish things.)

diff --git a/TODO b/TODO
index 6c8c147..a314c89 100644 (file)
--- a/TODO
+++ b/TODO
@@ -4,19 +4,14 @@ for 0.7.0:
        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:
        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".
 * 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:
 * 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:
 
 =======================================================================
 for early 0.7.x:
 

@@ -30,7 +25,8 @@ 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:
        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
 * faster bootstrapping (both make.sh and slam.sh)
        ** added mechanisms for automatically finding dead code, and
                used them to remove dead code

diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr
index 9b8fd88..5dda672 100644 (file)
--- a/package-data-list.lisp-expr
+++ b/package-data-list.lisp-expr
@@ -193,7 +193,7 @@
               "CALL" "CALL-LOCAL" "CALL-NAMED" "CALL-OUT" "CALL-VARIABLE"
               "CALLEE-NFP-TN" "CALLEE-RETURN-PC-TN"
               "CASE-BODY" "CATCH-BLOCK" "CHECK-CONS"
               "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" 
               "CHECK-SIGNED-BYTE-32" "CHECK-SYMBOL" "CHECK-UNSIGNED-BYTE-32"
               "CLOSURE-INIT" "CLOSURE-REF"
               "CODE-CONSTANT-REF" "CODE-CONSTANT-SET" 

@@ -208,7 +208,7 @@
               "DEF-IR1-TRANSLATOR"
               "!DEF-PRIMITIVE-TYPE" "!DEF-PRIMITIVE-TYPE-ALIAS"
               "DEFINE-SOURCE-TRANSFORM" "!DEF-VM-SUPPORT-ROUTINE"
               "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"
               "DEFINE-MOVE-VOP" "DEFINE-STORAGE-BASE"
               "DEFINE-STORAGE-CLASS" "DEFINE-VOP"
               "DEFKNOWN" "DEFOPTIMIZER"

@@ -325,9 +325,10 @@
  #s(sb-cold:package-data
     :name "SB!DEBUG"
     :doc
  #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*"
     :use ("CL" "SB!EXT" "SB!INT" "SB!SYS")
     :export ("*DEBUG-BEGINNER-HELP-P*"
              "*DEBUG-CONDITION*"

@@ -335,8 +336,7 @@ like *STACK-TOP-HINT*"
              "*DEBUG-READTABLE*" "*DEBUG-HELP-STRING*"
              "*FLUSH-DEBUG-ERRORS*" "*IN-THE-DEBUGGER*"
              "*TRACE-INDENTATION-STEP*" "*MAX-TRACE-INDENTATION*"
              "*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*"
              "ARG" "BACKTRACE" "INTERNAL-DEBUG" "VAR"
              "*PRINT-LOCATION-KIND*"
              "*ONLY-BLOCK-START-LOCATIONS*" "*STACK-TOP-HINT*"

@@ -358,7 +358,7 @@ like *STACK-TOP-HINT*"
                "DEBUG-SOURCE-P")
     :export ("ACTIVATE-BREAKPOINT"
              "AMBIGUOUS-DEBUG-VARS" "AMBIGUOUS-VAR-NAME" "BREAKPOINT"
                "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"
              "BREAKPOINT-KIND" "BREAKPOINT-P" "BREAKPOINT-WHAT" "CODE-LOCATION"
              "CODE-LOCATION-DEBUG-BLOCK" "CODE-LOCATION-DEBUG-FUN"
              "CODE-LOCATION-DEBUG-SOURCE" "CODE-LOCATION-FORM-NUMBER"

@@ -401,14 +401,14 @@ like *STACK-TOP-HINT*"
              "ADD-COMMENT-HOOK" "ADD-HOOK" "ADD-NOTE-HOOK"
              "ARG-VALUE" "CREATE-DSTATE" "DISASSEM-STATE"
              "DISASSEMBLE-CODE-COMPONENT"
              "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"
              "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"
              "GET-INST-SPACE" "HANDLE-BREAK-ARGS"
              "INST" "INST-FORMAT" "LABEL-SEGMENTS"
              "MAYBE-NOTE-ASSEMBLER-ROUTINE"

@@ -976,7 +976,7 @@ is a good idea, but see SB-SYS re. blurring of boundaries."
              "CODE-COMPONENT" "CODE-COMPONENT-P"
              "CODE-DEBUG-INFO" "CODE-HEADER-REF" "CODE-HEADER-SET"
              "CODE-INSTRUCTIONS"
              "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*"
              "COERCE-TO-LIST" "COERCE-TO-SIMPLE-STRING"
              "COERCE-TO-SIMPLE-VECTOR" "COERCE-TO-VECTOR"
              "*COLD-INIT-COMPLETE-P*"

@@ -1074,7 +1074,7 @@ is a good idea, but see SB-SYS re. blurring of boundaries."
              "MUTATOR-SELF"
              "NAMED-TYPE" "NAMED-TYPE-NAME" "NAMED-TYPE-P"
              "NATIVE-BYTE-ORDER" "NEGATE"
              "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"
              "NOT-<=-ERROR" "NOT-=-ERROR"
              "NOT-DUMPED-AT-ALL"
              "NUMERIC-CONTAGION" "NUMERIC-TYPE"

@@ -1083,7 +1083,7 @@ is a good idea, but see SB-SYS re. blurring of boundaries."
              "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"
              "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-ERROR"
              "OBJECT-NOT-COMPLEX-FLOAT-ERROR"
              "OBJECT-NOT-COMPLEX-SINGLE-FLOAT-ERROR"

@@ -1097,7 +1097,7 @@ is a good idea, but see SB-SYS re. blurring of boundaries."
              "OBJECT-NOT-COMPLEX-VECTOR-ERROR"
              "OBJECT-NOT-CONS-ERROR"
              "OBJECT-NOT-DOUBLE-FLOAT-ERROR" "OBJECT-NOT-FIXNUM-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"
              "OBJECT-NOT-INSTANCE-ERROR"
              "OBJECT-NOT-INTEGER-ERROR"
              "OBJECT-NOT-LIST-ERROR" "OBJECT-NOT-LONG-FLOAT-ERROR"

@@ -1244,7 +1244,7 @@ is a good idea, but see SB-SYS re. blurring of boundaries."
              "%SIMPLE-FUN-TYPE" "PROCLAIM-AS-FUN-NAME"
              "BECOME-DEFINED-FUN-NAME"
              "%NUMERATOR" "CLASS-TYPEP"
              "%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"
              "LAYOUT-INHERITS" "DD-LENGTH" "%CODE-ENTRY-POINTS"
              "%DENOMINATOR"
              "MAKE-STANDARD-CLASS"

@@ -1253,7 +1253,7 @@ is a good idea, but see SB-SYS re. blurring of boundaries."
              "FUNCALLABLE-STRUCTURE-CLASS"
              "%RANDOM-DOUBLE-FLOAT" "%RANDOM-LONG-FLOAT"
              "%RANDOM-SINGLE-FLOAT"
              "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"
              "%FUNCALLABLE-INSTANCE-INFO" "RANDOM-CHUNK"
              "MAKE-FUNCALLABLE-STRUCTURE-CLASS" "LAYOUT-CLOS-HASH-MAX"
              "CLASS-CELL-NAME" "BUILT-IN-CLASS-DIRECT-SUPERCLASSES"

diff --git a/src/code/bignum.lisp b/src/code/bignum.lisp
index 6129b4e..4dc565f 100644 (file)
--- a/src/code/bignum.lisp
+++ b/src/code/bignum.lisp
@@ -208,12 +208,12 @@
   (logand x (1- (ash 1 digit-size))))
 
 #!-32x16-divide
   (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))
 (defun %floor (a b c)
   (let ((a a) (b b) (c c))
     (declare (type bignum-element-type a b c))

diff --git a/src/code/coerce.lisp b/src/code/coerce.lisp
index dc97323..c9630f6 100644 (file)
--- a/src/code/coerce.lisp
+++ b/src/code/coerce.lisp
@@ -81,7 +81,7 @@
 ;;; DEFTRANSFORMs, though.
 (declaim (inline coerce-to-list))
 (declaim (inline coerce-to-simple-string coerce-to-bit-vector coerce-to-vector))
 ;;; 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.)
   ;; (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.)

@@ -270,7 +270,7 @@
        ((csubtypep type (specifier-type 'character))
         (character object))
        ((csubtypep type (specifier-type 'function))
        ((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
        ((numberp object)
         (let ((res
                (cond

diff --git a/src/code/debug-int.lisp b/src/code/debug-int.lisp
index 69182e8..46c9ff3 100644 (file)
--- a/src/code/debug-int.lisp
+++ b/src/code/debug-int.lisp
@@ -394,15 +394,15 @@
            (breakpoint-data-offset obj))))
 
 (defstruct (breakpoint (:constructor %make-breakpoint
            (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
                       (: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
   ;; CODE-LOCATION or DEBUG-FUN
   (what nil :type (or code-location debug-fun))
   ;; :CODE-LOCATION, :FUN-START, or :FUN-END for that kind

@@ -431,7 +431,7 @@
   ;; 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
   ;; 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)
   (cookie-fun nil :type (or null function))
   ;; This slot users can set with whatever information they find useful.
   %info)

@@ -2712,20 +2712,19 @@
 ;;;; user-visible interface
 
 ;;; Create and return a breakpoint. When program execution encounters
 ;;;; 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
 ;;;
 ;;; 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.
 ;;;
 ;;;
 ;;; INFO is information supplied by and used by the user.
 ;;;

@@ -2740,7 +2739,7 @@
 ;;; function.
 ;;;
 ;;; Signal an error if WHAT is an unknown code-location.
 ;;; 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
                        &key (kind :code-location) info fun-end-cookie)
   (etypecase what
     (code-location

@@ -2748,12 +2747,12 @@
        (error "cannot make a breakpoint at an unknown code location: ~S"
              what))
      (aver (eq kind :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)
        (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)
                                               :unknown-return-partner
                                               info)))
              (setf (breakpoint-unknown-return-partner bpt) other-bpt)

@@ -2766,7 +2765,7 @@
     (compiled-debug-fun
      (ecase kind
        (:fun-start
     (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))
        (:fun-end
        (unless (eq (sb!c::compiled-debug-fun-returns
                     (compiled-debug-fun-compiler-debug-fun what))

@@ -2774,11 +2773,11 @@
          (error ":FUN-END breakpoints are currently unsupported ~
                  for the known return convention."))
 
          (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))
               (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)
                  (fun-end-starter-hook starter what))
            (setf (compiled-debug-fun-end-starter what) starter))
          (setf (breakpoint-start-helper bpt) starter)

@@ -2867,7 +2866,7 @@
 \f
 ;;;; ACTIVATE-BREAKPOINT
 
 \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.
 ;;; the next call to DEACTIVATE-BREAKPOINT or DELETE-BREAKPOINT. The
 ;;; system invokes breakpoint hook functions in the opposite order
 ;;; that you activate them.

@@ -2950,7 +2949,7 @@
 \f
 ;;;; DEACTIVATE-BREAKPOINT
 
 \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
 (defun deactivate-breakpoint (breakpoint)
   (when (eq (breakpoint-status breakpoint) :active)
     (without-interrupts

@@ -3148,7 +3147,7 @@
         (frame (do ((f (top-frame) (frame-down f)))
                    ((eq debug-fun (frame-debug-fun f)) f))))
     (dolist (bpt breakpoints)
         (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
               frame
               ;; If this is an :UNKNOWN-RETURN-PARTNER, then pass the
               ;; hook function the original breakpoint, so that users

@@ -3186,7 +3185,7 @@
         (cookie (gethash component *fun-end-cookies*)))
     (remhash component *fun-end-cookies*)
     (dolist (bpt breakpoints)
         (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))))
               frame bpt
               (get-fun-end-breakpoint-values scp)
               cookie))))

diff --git a/src/code/debug.lisp b/src/code/debug.lisp
index 535b429..ba7e75b 100644 (file)
--- a/src/code/debug.lisp
+++ b/src/code/debug.lisp
@@ -305,12 +305,12 @@ Function and macro commands:
        (format t "~&~S: FUN-END in ~S" bp-number
               (sb!di:debug-fun-name place))))))
 \f
        (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.
 
 ;;; 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*)
   (setf *default-breakpoint-debug-fun*
        (sb!di:frame-debug-fun current-frame))
   (dolist (step-info *step-breakpoints*)

@@ -377,7 +377,7 @@ Function and macro commands:
                 (break string)
                 (format t "~A" string)))
            (t
                 (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
 \f
 ;;; Set breakpoints at the next possible code-locations. After calling
 ;;; this, either (CONTINUE) if in the debugger or just let program flow

@@ -399,14 +399,14 @@ Function and macro commands:
            (when bp-info
              (sb!di:deactivate-breakpoint (breakpoint-info-breakpoint
                                            bp-info))))
            (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*))
                                           :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)
                                          :kind :fun-end)))
          (sb!di:activate-breakpoint bp)
          (push (create-breakpoint-info debug-fun bp 0)

@@ -1473,7 +1473,7 @@ argument")
                         *default-breakpoint-debug-fun*))))))
           (setup-fun-start ()
             (let ((code-loc (sb!di:debug-fun-start-location place)))
                         *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))
                                               place
                                               :kind :fun-start))
               (setf break (sb!di:preprocess-for-eval break code-loc))

@@ -1483,7 +1483,7 @@ argument")
                       print-functions))))
           (setup-fun-end ()
             (setf bp
                       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
                                          place
                                          :kind :fun-end))
             (setf break

@@ -1504,8 +1504,7 @@ argument")
                     print-functions)))
           (setup-code-location ()
             (setf place (nth index *possible-breakpoints*))
                     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
                                             :kind :code-location))
             (dolist (form print)
               (push (cons

diff --git a/src/code/describe.lisp b/src/code/describe.lisp
index 4b1aa1d..35971bc 100644 (file)
--- a/src/code/describe.lisp
+++ b/src/code/describe.lisp
@@ -38,7 +38,7 @@
   (call-next-method)
   (when (and (legal-fun-name-p x)
             (fboundp x))
   (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
     ;;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

@@ -156,7 +156,7 @@
 
 ;;; Describe a compiled function. The closure case calls us to print
 ;;; the guts.
 
 ;;; 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.
   (declare (type stream s))
   ;; FIXME: The lowercaseness of %SIMPLE-FUN-ARGLIST results, and the
   ;; non-sentenceness of the "Arguments" label, makes awkward output.

@@ -185,7 +185,7 @@
 ;;; 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.
 ;;; 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))
   (declare (type function x))
   (declare (type stream s))
   (declare (type (member :macro :function nil) kind))

@@ -199,14 +199,14 @@
          (%fun-name x))
   (case (widetag-of x)
     (#.sb-vm:closure-header-widetag
          (%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)
      (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
     (#.sb-vm:funcallable-instance-header-widetag
      (typecase x
        (standard-generic-function

@@ -219,7 +219,7 @@
      (format s "~@:_It is an unknown type of function."))))
 
 (defmethod describe-object ((x function) s)
      (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))
   
 (defmethod describe-object ((x symbol) s)
   (declare (type stream s))

@@ -270,11 +270,11 @@
 
   ;; Describe the function cell.
   (cond ((macro-function x)
 
   ;; 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)
        ((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?
 
   ;; FIXME: Print out other stuff from the INFO database:
   ;;   * Does it name a type?

diff --git a/src/code/dyncount.lisp b/src/code/dyncount.lisp
index 2ad918e..f6b09e0 100644 (file)
--- a/src/code/dyncount.lisp
+++ b/src/code/dyncount.lisp
@@ -273,7 +273,7 @@ comments from CMU CL:
     ("Simple type predicate" "STRUCTUREP" "LISTP" "FIXNUMP")
     ("Simple type check" "CHECK-LIST" "CHECK-FIXNUM" "CHECK-STRUCTURE")
     ("Array bounds check" "CHECK-BOUND")
     ("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")
     ("Special read" "SYMBOL-VALUE")
     ("Special bind" "BIND$")
     ("Tagging" "MOVE-FROM")

diff --git a/src/code/early-fasl.lisp b/src/code/early-fasl.lisp
index a0f5c64..a6259db 100644 (file)
--- a/src/code/early-fasl.lisp
+++ b/src/code/early-fasl.lisp
@@ -110,14 +110,14 @@
 \f
 ;;;; the FOP database
 
 \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
 
 ;;; 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"))))
   (make-array 256
              :initial-element (lambda ()
                                 (error "corrupt fasl file: losing FOP"))))

diff --git a/src/code/fop.lisp b/src/code/fop.lisp
index b290907..5d67fee 100644 (file)
--- a/src/code/fop.lisp
+++ b/src/code/fop.lisp
@@ -37,7 +37,7 @@
       (error "multiple codes for fop name ~S: ~D and ~D" name code ocode)))
   (setf (svref *fop-names* code) name
        (get name 'fop-code) code
       (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
   (values))
 
 ;;; Define a pair of fops which are identical except that one reads

@@ -637,9 +637,9 @@ bug.~:@>")
     (setf (code-header-ref code (clone-arg)) value)
     (values)))
 
     (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
   #+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))
   #-sb-xc-host
   (let ((type (pop-stack))
        (arglist (pop-stack))

diff --git a/src/code/interr.lisp b/src/code/interr.lisp
index 231992d..143784d 100644 (file)
--- a/src/code/interr.lisp
+++ b/src/code/interr.lisp
@@ -62,7 +62,7 @@
 (deferr unknown-error (&rest args)
   (error "unknown error:~{ ~S~})" args))
 
 (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))
   (error 'type-error
         :datum object
         :expected-type 'function))

@@ -179,10 +179,10 @@
                 (symbol fdefn-or-symbol)
                 (fdefn (fdefn-name fdefn-or-symbol)))))
 
                 (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
   (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
 
 (deferr invalid-argument-count-error (nargs)
   (error 'simple-program-error

@@ -221,7 +221,7 @@
         :format-control "attempt to THROW to a tag that does not exist: ~S"
         :format-arguments (list tag)))
 
         :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"
   (error 'simple-control-error
         :format-control
         "A function with declared result type NIL returned:~%  ~S"

diff --git a/src/code/load.lisp b/src/code/load.lisp
index 92f188d..75cfec5 100644 (file)
--- a/src/code/load.lisp
+++ b/src/code/load.lisp
@@ -297,7 +297,7 @@
                        (svref *fop-names* byte)
                        byte
                        (1- (file-position stream))
                        (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)
 
            ;; Actually execute the fop.
            (if (eql byte 3)

@@ -317,7 +317,7 @@
                (setq *fop-stack-pointer* index)
                (setf (svref *fop-stack* index)
                      (svref *current-fop-table* (read-byte stream))))
                (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
 
 (defun load-as-fasl (stream verbose print)
   ;; KLUDGE: ANSI says it's good to do something with the :PRINT

diff --git a/src/code/ntrace.lisp b/src/code/ntrace.lisp
index fd96b83..d4e2158 100644 (file)
--- a/src/code/ntrace.lisp
+++ b/src/code/ntrace.lisp
@@ -37,7 +37,7 @@
 
 ;;; a hash table that maps each traced function to the TRACE-INFO. The
 ;;; entry for a closure is the shared function-entry object.
 
 ;;; 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.
 
 ;;; A TRACE-INFO object represents all the information we need to
 ;;; trace a given function.

@@ -139,7 +139,7 @@
 (defun trace-redefined-update (fname new-value)
   (when (fboundp fname)
     (let* ((fun (trace-fdefinition fname))
 (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)))))
       (when (and info (trace-info-named info))
        (untrace-1 fname)
        (trace-1 fname info new-value)))))

@@ -330,7 +330,7 @@
          (values definition t
                  (nth-value 2 (trace-fdefinition definition)))
          (trace-fdefinition function-or-name))
          (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))
 
       (warn "~S is already TRACE'd, untracing it." function-or-name)
       (untrace-1 fun))
 

@@ -397,7 +397,7 @@
            (sb-di:activate-breakpoint start)
            (sb-di:activate-breakpoint end)))))
 
            (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
 
   function-or-name)
 \f

@@ -477,8 +477,8 @@
        `(let ,(binds) (list ,@(forms)))
        `(list ,@(forms)))))
 
        `(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)
        collect (trace-info-what x)))
 
 (defmacro trace (&rest specs)

@@ -559,14 +559,14 @@
    -AFTER and -ALL forms are evaluated in the null environment."
   (if specs
       (expand-trace 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))
 \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))
     (cond
      ((not info)
       (warn "Function is not TRACEd: ~S" function-or-name))

@@ -578,11 +578,11 @@
        (sb-di:delete-breakpoint (trace-info-start-breakpoint info))
        (sb-di:delete-breakpoint (trace-info-end-breakpoint info))))
       (setf (trace-info-untraced info) t)
        (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 ()
 
 ;;; Untrace all traced functions.
 (defun untrace-all ()

-  (dolist (fun (%list-traced-functions))
+  (dolist (fun (%list-traced-funs))

     (untrace-1 fun))
   t)
 
     (untrace-1 fun))
   t)
 

diff --git a/src/code/parse-defmacro.lisp b/src/code/parse-defmacro.lisp
index 5297670..03aa970 100644 (file)
--- a/src/code/parse-defmacro.lisp
+++ b/src/code/parse-defmacro.lisp
@@ -27,9 +27,9 @@
 (defvar *ignorable-vars*)
 (declaim (type list *ignorable-vars*))
 
 (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)
 (defun parse-defmacro (lambda-list arg-list-name body name error-kind
                                   &key
                                   (anonymousp nil)

diff --git a/src/code/pprint.lisp b/src/code/pprint.lisp
index d268aca..0008579 100644 (file)
--- a/src/code/pprint.lisp
+++ b/src/code/pprint.lisp
@@ -1243,7 +1243,7 @@
     (pprint-fill stream (pprint-pop))
     (pprint-tagbody-guts stream)))
 
     (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
   (declare (ignore noise))
   (funcall (formatter "~:<~^~W~^ ~:_~:I~@{~W~^ ~_~}~:>")
           stream

@@ -1266,7 +1266,7 @@
     (/show0 "doing SET-PPRINT-DISPATCH for regular types")
     (set-pprint-dispatch 'array #'pprint-array)
     (set-pprint-dispatch '(cons (and symbol (satisfies fboundp)))
     (/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")
     (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")

diff --git a/src/code/print.lisp b/src/code/print.lisp
index ad0e294..a7d4ed2 100644 (file)
--- a/src/code/print.lisp
+++ b/src/code/print.lisp
@@ -476,7 +476,7 @@
     (function
      (unless (and (funcallable-instance-p object)
                  (printed-as-funcallable-standard-class object stream))
     (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
     (symbol
      (output-symbol object stream))
     (number

@@ -519,12 +519,12 @@
 
 ;;; This variable contains the current definition of one of three
 ;;; symbol printers. SETUP-PRINTER-STATE sets this variable.
 
 ;;; 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
 
 ;;; 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*))
 (defun setup-printer-state ()
   (unless (and (eq *print-case* *previous-case*)
               (eq (readtable-case *readtable*) *previous-readtable-case*))

@@ -538,7 +538,7 @@
       (setf (readtable-case *readtable*) :upcase)
       (error "invalid READTABLE-CASE value: ~S" *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*
          (case *previous-readtable-case*
            (:upcase
             (case *print-case*

@@ -606,7 +606,7 @@
   (setup-printer-state)
   (if (and maybe-quote (symbol-quotep name))
       (output-quoted-symbol-name name stream)
   (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
 
 \f
 ;;;; escaping symbols
 

@@ -839,10 +839,10 @@
       (when (test letter) (advance OTHER nil))
       (go DIGIT))))
 \f
       (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:
 ;;;; *PRINT-CASE* and READTABLE-CASE.
 
 ;;; called when:

@@ -1570,7 +1570,7 @@
   (declare (ignore object stream))
   nil)
 
   (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
   (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

diff --git a/src/code/profile.lisp b/src/code/profile.lisp
index dbdc65e..837ff7e 100644 (file)
--- a/src/code/profile.lisp
+++ b/src/code/profile.lisp
@@ -217,7 +217,7 @@
 
 ;;; A symbol or (SETF FOO) list names a function, a string names all
 ;;; the functions named by symbols in the named package.
 
 ;;; 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))
   (dolist (name names)
     (etypecase name
       (symbol (funcall function name))

@@ -239,7 +239,7 @@
 
 ;;; Profile the named function, which should exist and not be profiled
 ;;; already.
 
 ;;; 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)
   (let ((encapsulated-fun (fdefinition name)))
     (multiple-value-bind (encapsulation-fun read-stats-fun clear-stats-fun)
        (profile-encapsulation-lambdas encapsulated-fun)

@@ -254,18 +254,18 @@
       (values))))
 
 ;;; Profile the named function. If already profiled, unprofile first.
       (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)
   (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.
        (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*)
   (let ((pinfo (gethash name *profiled-fun-name->info*)))
     (cond (pinfo
           (remhash name *profiled-fun-name->info*)

@@ -293,7 +293,7 @@
   (if (null names)
       `(loop for k being each hash-key in *profiled-fun-name->info*
             collecting k)
   (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
 
 (defmacro unprofile (&rest names)
   #+sb-doc

@@ -303,13 +303,13 @@
   named package. NAMES defaults to the list of names of all currently 
   profiled functions."
   (if names
   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-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."
 
 (defun reset ()
   "Reset the counters for all profiled functions."

diff --git a/src/code/target-error.lisp b/src/code/target-error.lisp
index 76643d8..ef1eea8 100644 (file)
--- a/src/code/target-error.lisp
+++ b/src/code/target-error.lisp
@@ -26,7 +26,7 @@
   function
   report-function
   interactive-function
   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)
 (def!method print-object ((restart restart) stream)
   (if *print-escape*
       (print-unreadable-object (restart stream :type t :identity t)

@@ -36,8 +36,8 @@
 (defun compute-restarts (&optional condition)
   #!+sb-doc
   "Return a list of all the currently active restarts ordered from most
 (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 ()))
    condition) will be returned."
   (let ((associated ())
        (other ()))

@@ -51,7 +51,7 @@
          (when (and (or (not condition)
                         (member restart associated)
                         (not (member restart 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))))
 
            (res restart))))
       (res))))
 

@@ -206,9 +206,7 @@
                                   :interactive-function
                                   result)))
             (when test
                                   :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))
             (nreverse result)))
         (parse-keyword-pairs (list keys)
           (do ((l list (cddr l))

diff --git a/src/cold/snapshot.lisp b/src/cold/snapshot.lisp
index 4712f4d..846c06f 100644 (file)
--- a/src/cold/snapshot.lisp
+++ b/src/cold/snapshot.lisp
@@ -102,7 +102,7 @@
                      #-cmu nil
                      #+cmu (cl::*gc-trigger*
                             cl::inch-ptr
                      #-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
                             cl::ouch-ptr
                             cl::*previous-case*
                             cl::read-buffer

diff --git a/src/compiler/alpha/call.lisp b/src/compiler/alpha/call.lisp
index a571adf..f59202c 100644 (file)
--- a/src/compiler/alpha/call.lisp
+++ b/src/compiler/alpha/call.lisp
@@ -1218,4 +1218,4 @@ default-value-8
     sb!c::%odd-key-arguments-error)
   (frob unknown-key-argument-error unknown-key-argument-error
     sb!c::%unknown-key-argument-error key)
     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))

diff --git a/src/compiler/alpha/float.lisp b/src/compiler/alpha/float.lisp
index 67eff15..2b0a2ea 100644 (file)
--- a/src/compiler/alpha/float.lisp
+++ b/src/compiler/alpha/float.lisp
@@ -13,27 +13,26 @@
 \f
 ;;;; float move functions
 
 \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))
 
   ((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)))
 
   ((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)))
 
   ((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)))
 
   ((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)))
   ((double-reg) (double-stack))
   (let ((nfp (current-nfp-tn vop))
        (offset (* (tn-offset y) n-word-bytes)))

@@ -141,7 +140,7 @@
                  :offset (1+ (tn-offset x))))
 
 
                  :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)))
   ((complex-single-stack) (complex-single-reg))
   (let ((nfp (current-nfp-tn vop))
        (offset (* (tn-offset x) n-word-bytes)))

@@ -150,7 +149,7 @@
     (let ((imag-tn (complex-single-reg-imag-tn y)))
       (inst lds imag-tn (+ offset n-word-bytes) nfp))))
 
     (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)))
   ((complex-single-reg) (complex-single-stack))
   (let ((nfp (current-nfp-tn vop))
        (offset (* (tn-offset y) n-word-bytes)))

@@ -160,7 +159,7 @@
       (inst sts imag-tn (+ offset n-word-bytes) nfp))))
 
 
       (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)))
   ((complex-double-stack) (complex-double-reg))
   (let ((nfp (current-nfp-tn vop))
        (offset (* (tn-offset x) n-word-bytes)))

@@ -169,7 +168,7 @@
     (let ((imag-tn (complex-double-reg-imag-tn y)))
       (inst ldt imag-tn (+ offset (* 2 n-word-bytes)) nfp))))
 
     (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)))
   ((complex-double-reg) (complex-double-stack))
   (let ((nfp (current-nfp-tn vop))
        (offset (* (tn-offset y) n-word-bytes)))

diff --git a/src/compiler/alpha/move.lisp b/src/compiler/alpha/move.lisp
index 79e4bdb..0b76ace 100644 (file)
--- a/src/compiler/alpha/move.lisp
+++ b/src/compiler/alpha/move.lisp
@@ -11,7 +11,7 @@
 
 (in-package "SB!VM")
 
 
 (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)))
   ((null zero immediate)
    (any-reg descriptor-reg))
   (let ((val (tn-value x)))

@@ -26,56 +26,56 @@
        (inst li (logior (ash (char-code val) n-widetag-bits) base-char-widetag)
             y)))))
 
        (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))
 
   ((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))
 
   ((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))
 
   ((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))
 
   ((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))
 
   ((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))))
 
   ((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))))
 
   ((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))
 
   ((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))))
 
   ((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
   ((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
 
 (define-vop (move)
   (:args (x :target y

diff --git a/src/compiler/alpha/type-vops.lisp b/src/compiler/alpha/type-vops.lisp
index 2f34a88..010d84e 100644 (file)
--- a/src/compiler/alpha/type-vops.lisp
+++ b/src/compiler/alpha/type-vops.lisp
@@ -233,8 +233,8 @@
 (def-type-vops fixnump check-fixnum fixnum object-not-fixnum-error
   even-fixnum-lowtag odd-fixnum-lowtag)
 
 (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)
 
 (def-type-vops listp check-list list object-not-list-error
   list-pointer-lowtag)

diff --git a/src/compiler/checkgen.lisp b/src/compiler/checkgen.lisp
index 3986bf6..01f8e29 100644 (file)
--- a/src/compiler/checkgen.lisp
+++ b/src/compiler/checkgen.lisp
@@ -24,7 +24,7 @@
 ;;;
 ;;; We special-case NULL, since it does have a source tranform and is
 ;;; interesting to us.
 ;;;
 ;;; 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))))
   (declare (symbol name))
   (let ((info (info :function :info name))
        (call-cost (template-cost (template-or-lose 'call-named))))

@@ -49,29 +49,29 @@
            (let ((found (cdr (assoc type *backend-type-predicates*
                                     :test #'type=))))
              (if found
            (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))
                  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)
        (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))
             (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))
            (type-test-cost (cons-type-car-type type))

-           (function-cost 'cdr)
+           (fun-guessed-cost 'cdr)

            (type-test-cost (cons-type-cdr-type type))))
        (t
            (type-test-cost (cons-type-cdr-type type))))
        (t

-        (function-cost 'typep)))))
+        (fun-guessed-cost 'typep)))))

 \f
 ;;;; checking strategy determination
 
 \f
 ;;;; checking strategy determination
 

@@ -109,8 +109,9 @@
               min-type
               *universal-type*)))))
 
               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)
   (declare (type ctype type))
   (multiple-value-bind (res count) (values-types type)
     (values (mapcar (lambda (type)

@@ -145,7 +146,7 @@
 (defun maybe-negate-check (cont types force-hairy)
   (declare (type continuation cont) (list types))
   (multiple-value-bind (ptypes count)
 (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)
     (if (eq count :unknown)
        (if (and (every #'type-check-template types) (not force-hairy))
            (values :simple types)

@@ -215,7 +216,7 @@
   (let ((type (continuation-asserted-type cont))
        (dest (continuation-dest cont)))
     (aver (not (eq type *wild-type*)))
   (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)
       (cond ((not (eq count :unknown))
             (if (or (exit-p dest)
                     (and (return-p dest)

@@ -421,10 +422,10 @@
                                                  pos)))))))
     (cond ((eq dtype *empty-type*))
          ((and (ref-p node) (constant-p (ref-leaf node)))
                                                  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
          (t

-          (compiler-warning
+          (compiler-warn

            "~:[Result~;~:*~A~] is a ~S, ~<~%~9T~:;not a ~S.~>"
            what (type-specifier dtype) atype-spec))))
   (values))
            "~:[Result~;~:*~A~] is a ~S, ~<~%~9T~:;not a ~S.~>"
            what (type-specifier dtype) atype-spec))))
   (values))

diff --git a/src/compiler/compiler-error.lisp b/src/compiler/compiler-error.lisp
index ac85e40..39bf68f 100644 (file)
--- a/src/compiler/compiler-error.lisp
+++ b/src/compiler/compiler-error.lisp
@@ -50,10 +50,10 @@
   ;; 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*"))
   ;; 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))
   (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))
 
   (apply #'style-warn format-string format-args)
   (values))
 

diff --git a/src/compiler/constraint.lisp b/src/compiler/constraint.lisp
index 6362e4d..a302245 100644 (file)
--- a/src/compiler/constraint.lisp
+++ b/src/compiler/constraint.lisp
@@ -458,7 +458,7 @@
                      res))
                   (t
                    (let ((*compiler-error-context* (block-last block)))
                      res))
                   (t
                    (let ((*compiler-error-context* (block-last block)))

-                     (compiler-warning
+                     (compiler-warn

                       "unreachable code in constraint ~
                        propagation -- apparent compiler bug"))
                    (make-sset))))
                       "unreachable code in constraint ~
                        propagation -- apparent compiler bug"))
                    (make-sset))))

diff --git a/src/compiler/ctype.lisp b/src/compiler/ctype.lisp
index 8614e92..35538ca 100644 (file)
--- a/src/compiler/ctype.lisp
+++ b/src/compiler/ctype.lisp
@@ -18,35 +18,30 @@
 
 (in-package "SB!C")
 
 
 (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
 ;;; 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.
 ;;; second argument. The function should return values like CSUBTYPEP.

-(defvar *test-function*)
+(defvar *ctype-test-fun*)

 ;;; FIXME: Why is this a variable? Explain.
 
 ;;; 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
 ;;; *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"
 ;;;
 ;;; KLUDGE: Common Lisp is a dynamic language, even if CMU CL was not.
 ;;; As far as I can see, none of the "definite incompatibilities"

@@ -58,21 +53,19 @@
 ;;; upgrade the code to keep track of that, we have to handle all
 ;;; these as STYLE-WARNINGs. -- WHN 2001-02-10
 (defvar *lossage-detected*)
 ;;; 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)
 (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))
   (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*))
   (values))
 
 (declaim (special *compiler-error-context*))

@@ -110,15 +103,15 @@
 ;;; 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
 ;;; 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)
                                (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)
   (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))
         (*compiler-error-context* call)
         (args (combination-args call))
         (nargs (length args))

@@ -170,15 +163,15 @@
                                          dtype))))
       (multiple-value-bind (int win) (funcall result-test out-type return-type)
        (cond ((not win)
                                          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))
              ((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
          (t (values t t)))))
 
 ;;; Check that the derived type of the continuation CONT is compatible

@@ -193,30 +186,30 @@
   (cond
    ((not (constant-type-p type))
     (let ((ctype (continuation-type cont)))
   (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)
        (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*)
               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))
               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)
      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"
                nil)
               ((not res)
                (note-lossage "The ~:R argument is not a constant ~S:~%  ~S"

@@ -226,7 +219,7 @@
 
 ;;; Check that each of the type of each supplied argument intersects
 ;;; with the type specified for that argument. If we can't tell, then
 
 ;;; 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))
 (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))

@@ -243,8 +236,8 @@
 
 ;;; Check that the &KEY args are of the correct type. Each key should
 ;;; be known and the corresponding argument should be of the correct
 
 ;;; 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))
 (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))

@@ -255,8 +248,9 @@
       (cond
        ((not (check-arg-type k (specifier-type 'symbol) n)))
        ((not (constant-continuation-p k))
       (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)
        (t
        (let* ((name (continuation-value k))
               (info (find name (fun-type-keywords type)

@@ -356,8 +350,8 @@
 (declaim (ftype (function (combination
                           &optional (or approximate-fun-type null))
                          approximate-fun-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))
   (let* ((type (or type (make-approximate-fun-type)))
         (types (approximate-fun-type-types type))
         (args (combination-args call))

@@ -423,13 +417,13 @@
                          (values boolean boolean))
                valid-approximate-type))
 (defun valid-approximate-type (call-type type &optional
                          (values boolean boolean))
                valid-approximate-type))
 (defun valid-approximate-type (call-type type &optional

-                                        (*test-function*
+                                        (*ctype-test-fun*

                                          #'types-equal-or-intersect)
                                          #'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)
   (let* ((*lossage-detected* nil)

-        (*slime-detected* nil)
+        (*unwinnage-detected* nil)

         (required (fun-type-required type))
         (min-args (length required))
         (optional (fun-type-optional type))
         (required (fun-type-required type))
         (min-args (length required))
         (optional (fun-type-optional type))

@@ -466,7 +460,7 @@
                                      rest)
 
     (cond (*lossage-detected* (values nil t))
                                      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
          (t (values t t)))))
 
 ;;; Check that each of the types used at each arg position is

@@ -491,11 +485,15 @@
 (defun check-approximate-arg-type (call-types decl-type context &rest args)
   (let ((losers *empty-type*))
     (dolist (ctype call-types)
 (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)
        (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))))))
 
         ((not int)
          (setq losers (type-union ctype losers))))))
 

@@ -703,19 +701,19 @@
 ;;; from the FUN-TYPE.
 ;;;
 ;;; If there is a syntactic or type problem, then we call
 ;;; 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)
 ;;; 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)
                   (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))
           (string where))
   (unless (fun-type-p type)
     (return-from assert-definition-type t))

@@ -747,9 +745,9 @@
            (assert-continuation-type (return-result return) atype))
          (loop for var in vars and type in types do
            (cond ((basic-var-sets var)
            (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)))
                              (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~%"
                              "Assignment to argument: ~S~%  ~
                               prevents use of assertion from function ~
                               type ~A:~%  ~S~%"

diff --git a/src/compiler/debug.lisp b/src/compiler/debug.lisp
index ba299a1..6463f64 100644 (file)
--- a/src/compiler/debug.lisp
+++ b/src/compiler/debug.lisp
@@ -108,7 +108,7 @@
 |#
     ))
 
 |#
     ))
 

-  (check-function-consistency components)
+  (check-fun-consistency components)

 
   (dolist (c components)
     (do ((block (block-next (component-head c)) (block-next block)))
 
   (dolist (c components)
     (do ((block (block-next (component-head c)) (block-next block)))

@@ -160,7 +160,7 @@
     (setf (gethash x *seen-functions*) t)))
 
 ;;; Check that the specified function has been seen.
     (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)))
   (declare (type functional fun))
   (unless (gethash fun *seen-functions*)
     (barf "unseen function ~S in ~S" fun where)))

@@ -168,17 +168,17 @@
 ;;; 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.
 ;;; 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)))
   (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)
        (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 "The LET ~S has entry function." functional))
      (unless (member functional (lambda-lets (lambda-home functional)))

@@ -192,7 +192,7 @@
      (when (functional-entry-fun functional)
        (barf ":OPTIONAL ~S has an ENTRY-FUN." functional))
      (let ((ef (lambda-optional-dispatch 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)))
        (unless (or (member functional (optional-dispatch-entry-points ef))
                   (eq functional (optional-dispatch-more-entry ef))
                   (eq functional (optional-dispatch-main-entry ef)))

@@ -204,11 +204,11 @@
     ((nil :escape :cleanup)
      (let ((ef (functional-entry-fun functional)))
        (when 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
         (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)
 
   (case (functional-kind functional)
     ((nil :optional :external :toplevel :escape :cleanup)

@@ -216,7 +216,7 @@
        (dolist (fun (lambda-lets functional))
         (unless (eq (lambda-home fun) functional)
           (barf "The home in ~S is not ~S." fun functional))
        (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)))))
 
        (unless (eq (lambda-home functional) functional)
         (barf "home not self-pointer in ~S" functional)))))
 

@@ -236,13 +236,13 @@
         (barf "HOME in ~S should be ~S." var functional))))
     (optional-dispatch
      (dolist (ep (optional-dispatch-entry-points 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)))
      (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))
       (observe-functional new-fun))

@@ -257,13 +257,13 @@
 
   (dolist (c components)
     (dolist (new-fun (component-new-funs c))
 
   (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))
     (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))
       (dolist (let (lambda-lets fun))

-       (check-function-stuff let)))))
+       (check-fun-stuff let)))))

 \f
 ;;;; loop consistency checking
 
 \f
 ;;;; loop consistency checking
 

@@ -333,7 +333,7 @@
         (this-cont (block-start block))
         (last (block-last block)))
     (unless fun-deleted
         (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)
     (when (not this-cont)
       (barf "~S has no START." block))
     (when (not last)

@@ -489,7 +489,7 @@
                         :toplevel)
               (barf ":TOPLEVEL-XEP ref in non-top-level component: ~S"
                     node))
                         :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))
     (basic-combination
      (check-dest (basic-combination-fun node) node)
      (dolist (arg (basic-combination-args node))

@@ -527,9 +527,9 @@
     (cset
      (check-dest (set-value node) node))
     (bind
     (cset
      (check-dest (set-value node) node))
     (bind

-     (check-function-reached (bind-lambda node) node))
+     (check-fun-reached (bind-lambda node) node))

     (creturn
     (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)))
      (check-dest (return-result node) node)
      (unless (eq (block-last (node-block node)) node)
        (barf "RETURN not at block end: ~S" node)))

diff --git a/src/compiler/disassem.lisp b/src/compiler/disassem.lisp
index 93d9eb8..6d8e469 100644 (file)
--- a/src/compiler/disassem.lisp
+++ b/src/compiler/disassem.lisp
@@ -85,7 +85,7 @@
          ;; 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)
          ;; 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)))))
        (let ((params
               (or sb!c:*backend-disassem-params*
                   (setf sb!c:*backend-disassem-params* (make-params)))))

@@ -102,14 +102,18 @@
 |#
 \f
 ;;;; cached functions
 |#
 \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))
 
   (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.
 \f
 ;;;; A DCHUNK contains the bits we look at to decode an
 ;;;; instruction.

@@ -292,7 +296,7 @@
 
 (defvar *disassem-inst-formats* (make-hash-table))
 (defvar *disassem-arg-types* nil)
 
 (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))
 
 (defstruct (argument (:conc-name arg-)
                     (:copier nil))

@@ -479,7 +483,7 @@
       `(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))
       `(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
          (multiple-value-bind (printer-fun printer-defun)
              (find-printer-fun ',uniquified-name
                               ',format-name

@@ -1035,7 +1039,7 @@
       (values nil nil)
       (let ((printer-source (preprocess-printer printer-source args)))
        (!with-cached-function
       (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)
                 :constraint printer-source
                 :stem (concatenate 'string
                                    (string %name)

@@ -1408,7 +1412,7 @@
     (if (null labelled-fields)
         (values nil nil)
         (!with-cached-function
     (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))
              :stem (concatenate 'string "LABELLER-" (string %name))
              :constraint labelled-fields)
           (let ((labels-form 'labels))

@@ -1446,7 +1450,7 @@
     (if (null filtered-args)
         (values nil nil)
         (!with-cached-function
     (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)
                                "-"
              :stem (concatenate 'string
                                (string %name)
                                "-"

diff --git a/src/compiler/dump.lisp b/src/compiler/dump.lisp
index 3ea6aee..4946783 100644 (file)
--- a/src/compiler/dump.lisp
+++ b/src/compiler/dump.lisp
@@ -1086,7 +1086,7 @@
     (dump-object name file)
     (dump-object (sb!c::entry-info-arguments entry) file)
     (dump-object (sb!c::entry-info-type entry) file)
     (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)))
 
     (dump-unsigned-32 (label-position (sb!c::entry-info-offset entry)) file)
     (dump-pop file)))
 

diff --git a/src/compiler/generic/core.lisp b/src/compiler/generic/core.lisp
index 3d29e19..8ea0cbd 100644 (file)
--- a/src/compiler/generic/core.lisp
+++ b/src/compiler/generic/core.lisp
@@ -31,7 +31,7 @@
   (debug-info () :type list))
 
 ;;; Note the existence of FUNCTION.
   (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)))
   (declare (type function function)
           (type core-object object))
   (let ((patch-table (core-object-patch-table object)))

diff --git a/src/compiler/generic/genesis.lisp b/src/compiler/generic/genesis.lisp
index 5b8b0a7..c46ffbb 100644 (file)
--- a/src/compiler/generic/genesis.lisp
+++ b/src/compiler/generic/genesis.lisp
@@ -1691,21 +1691,21 @@
 ;;;; general machinery for cold-loading FASL files
 
 ;;; FOP functions for cold loading
 ;;;; 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.
   ;; 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
 
 ;;; 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))
 (defmacro define-cold-fop ((name &optional (pushp t)) &rest forms)
   (aver (member pushp '(nil t :nope)))
   (let ((code (get name 'fop-code))

@@ -1717,7 +1717,7 @@
         ,@(if (eq pushp :nope)
             forms
             `((with-fop-stack ,pushp ,@forms))))
         ,@(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)))
 
 (defmacro clone-cold-fop ((name &optional (pushp t)) (small-name) &rest forms)
   (aver (member pushp '(nil t :nope)))

@@ -1738,8 +1738,8 @@
 (defun cold-load (filename)
   #!+sb-doc
   "Load the file named by FILENAME into the cold load image being built."
 (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)))))
         (*cold-load-filename* (etypecase filename
                                 (string filename)
                                 (pathname (namestring filename)))))

@@ -1759,11 +1759,11 @@
 (define-cold-fop (fop-truth) (cold-intern t))
 
 (define-cold-fop (fop-normal-load :nope)
 (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*
 
 (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))
 
 
 (define-cold-fop (fop-maybe-cold-load :nope))
 

@@ -2330,7 +2330,7 @@
        (code (pop-stack)))
     (write-wordindexed code slot value)))
 
        (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))
   (let* ((type (pop-stack))
         (arglist (pop-stack))
         (name (pop-stack))

diff --git a/src/compiler/generic/interr.lisp b/src/compiler/generic/interr.lisp
index f1dfb33..f119356 100644 (file)
--- a/src/compiler/generic/interr.lisp
+++ b/src/compiler/generic/interr.lisp
@@ -38,7 +38,7 @@
 (define-internal-errors
   (unknown
    "unknown system lossage")
 (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.")
    "Object is not of type FUNCTION.")
   (object-not-list
    "Object is not of type LIST.")

@@ -87,7 +87,7 @@
    ;; 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.")
    ;; 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 coerceable to type FUNCTION.")
   (invalid-argument-count
    "invalid argument count")

@@ -175,7 +175,7 @@
    "Object is not a INSTANCE.")
   (object-not-base-char
    "Object is not of type BASE-CHAR.")
    "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)")
    "A function with declared result type NIL returned.")
   (layout-invalid
    "Object layout is invalid. (indicates obsolete instance)")

diff --git a/src/compiler/generic/target-core.lisp b/src/compiler/generic/target-core.lisp
index dcc4a97..aedc131 100644 (file)
--- a/src/compiler/generic/target-core.lisp
+++ b/src/compiler/generic/target-core.lisp
@@ -31,7 +31,7 @@
       (setf (%simple-fun-arglist res) (entry-info-arguments entry))
       (setf (%simple-fun-type res) (entry-info-type entry))
 
       (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.
 
 ;;; Dump a component to core. We pass in the assembler fixups, code
 ;;; vector and node info.

diff --git a/src/compiler/generic/vm-type.lisp b/src/compiler/generic/vm-type.lisp
index 091475c..65561c9 100644 (file)
--- a/src/compiler/generic/vm-type.lisp
+++ b/src/compiler/generic/vm-type.lisp
@@ -177,7 +177,7 @@
            'sb!c:check-unsigned-byte-32)
           (t nil)))
     (fun-type
            'sb!c:check-unsigned-byte-32)
           (t nil)))
     (fun-type

-     'sb!c:check-function)
+     'sb!c:check-fun)

     (t
      nil)))
 \f
     (t
      nil)))
 \f

diff --git a/src/compiler/info-functions.lisp b/src/compiler/info-functions.lisp
index 2319a83..ab6cc28 100644 (file)
--- a/src/compiler/info-functions.lisp
+++ b/src/compiler/info-functions.lisp
@@ -49,7 +49,7 @@
       (:function) ; happy case
       ((nil)) ; another happy case
       (:macro ; maybe-not-so-good case
       (: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))))
 
        (setf (info :function :where-from name) :assumed)
        (clear-info :function :macro-function name))))
 

@@ -79,7 +79,7 @@
   (when (consp name)
     (when (or (info :setf :inverse name)
              (info :setf :expander 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)))
        "defining as a SETF function a name that already has a SETF macro:~
        ~%  ~S"
        name)))

diff --git a/src/compiler/ir1-translators.lisp b/src/compiler/ir1-translators.lisp
index cdc1fcb..a1c9556 100644 (file)
--- a/src/compiler/ir1-translators.lisp
+++ b/src/compiler/ir1-translators.lisp
@@ -248,7 +248,7 @@
   (declare (type list definitions))
   (unless (= (length definitions)
              (length (remove-duplicates definitions :key #'first)))
   (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)))
   (let* ((processed-definitions (mapcar definitionize-fun definitions))
          (*lexenv* (make-lexenv definitionize-keyword processed-definitions)))
     (funcall fun)))

@@ -735,8 +735,9 @@
     (when (and (not intersects)
               (not (policy *lexenv*
                            (= inhibit-warnings 3)))) ;FIXME: really OK to suppress?
     (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)))
        (type-specifier ctype)
        name
        (type-specifier old-type)))

@@ -795,7 +796,7 @@
               (when (lambda-var-ignorep leaf)
                 ;; ANSI's definition of "Declaration IGNORE, IGNORABLE"
                 ;; requires that this be a STYLE-WARNING, not a full warning.
               (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)))
                  "~S is being set even though it was declared to be ignored."
                  name)))
             (set-variable start cont leaf (second things)))

@@ -1079,7 +1080,7 @@
       (:function
        (remhash name *free-functions*)
        (undefine-fun-name name)
       (: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
        "~S is being redefined as a macro when it was ~
          previously ~(~A~) to be a function."
        name

diff --git a/src/compiler/ir1final.lisp b/src/compiler/ir1final.lisp
index d0a02e3..7f20246 100644 (file)
--- a/src/compiler/ir1final.lisp
+++ b/src/compiler/ir1final.lisp
@@ -33,12 +33,12 @@
                                :argument-test #'types-equal-or-intersect
                                :result-test #'values-types-equal-or-intersect)
            (collect ((messages))
                                :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
                       (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: ~
              (compiler-note "~@<unable to ~
                               ~2I~_~A ~
                               ~I~_due to type uncertainty: ~

@@ -105,7 +105,7 @@
          (when (and (eq (node-component ref) component)
                     (combination-p dest)
                     (eq (continuation-use (basic-combination-fun dest)) ref))
          (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
       (setf (info :function :assumed-type name) atype))))
 
 ;;; Do miscellaneous things that we want to do once all optimization

diff --git a/src/compiler/ir1opt.lisp b/src/compiler/ir1opt.lisp
index 08951f8..ce0522d 100644 (file)
--- a/src/compiler/ir1opt.lisp
+++ b/src/compiler/ir1opt.lisp
@@ -159,9 +159,9 @@
                     (eq int *empty-type*)
                     (not (eq rtype *empty-type*)))
            (let ((*compiler-error-context* node))
                     (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:~
               "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))))))
               (type-specifier rtype) (type-specifier node-type))))
          (setf (node-derived-type node) int)
          (reoptimize-continuation (node-cont node))))))

@@ -880,8 +880,8 @@
                             ;; FIXME: Actually, I think we could
                             ;; issue a full WARNING if the call
                             ;; violates a DECLAIM FTYPE.
                             ;; 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))
         (assert-call-type call type)
         (maybe-terminate-block call ir1-converting-not-optimizing-p)
         (recognize-known-call call ir1-converting-not-optimizing-p))

@@ -999,7 +999,7 @@
               (:aborted
                (setf (combination-kind node) :error)
                (when args
               (:aborted
                (setf (combination-kind node) :error)
                (when args

-                 (apply #'compiler-warning args))
+                 (apply #'compiler-warn args))

                (remhash node table)
                nil)
               (:failure
                (remhash node table)
                nil)
               (:failure

@@ -1471,14 +1471,14 @@
 
        (when total-nvals
          (when (and min (< total-nvals min))
 
        (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))
             "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)
             "MULTIPLE-VALUE-CALL with ~R values when the function expects ~
             at most ~R."
             total-nvals max)

diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp
index 0c83801..3faf0a1 100644 (file)
--- a/src/compiler/ir1tran.lisp
+++ b/src/compiler/ir1tran.lisp
@@ -585,7 +585,7 @@
         (when (lambda-var-ignorep var)
           ;; (ANSI's specification for the IGNORE declaration requires
           ;; that this be a STYLE-WARNING, not a full WARNING.)
         (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))
        (reference-leaf start cont var))
       (cons
        (aver (eq (car var) 'MACRO))

@@ -889,7 +889,7 @@
                             (type-approx-intersection2 old-type type))))
               (cond ((eq int *empty-type*)
                      (unless (policy *lexenv* (= inhibit-warnings 3))
                             (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)))
                         "The type declarations ~S and ~S for ~S conflict."
                         (type-specifier old-type) (type-specifier type)
                         var-name)))

@@ -929,7 +929,7 @@
           (found
            (setf (leaf-type found) type)
            (assert-definition-type found type
           (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
                                    :where "FTYPE declaration"))
           (t
            (res (cons (find-lexically-apparent-function

@@ -957,7 +957,7 @@
           (when (lambda-var-ignorep var)
             ;; ANSI's definition for "Declaration IGNORE, IGNORABLE"
             ;; requires that this be a STYLE-WARNING, not a full WARNING.
           (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)
              "The ignored variable ~S is being declared special."
              name))
           (setf (lambda-var-specvar var)

@@ -1033,8 +1033,8 @@
        ((not var)
        ;; ANSI's definition for "Declaration IGNORE, IGNORABLE"
        ;; requires that this be a STYLE-WARNING, not a full WARNING.
        ((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.
        ;; FIXME: This special case looks like non-ANSI weirdness.
        ((and (consp var) (consp (cdr var)) (eq (cadr var) 'macro))
        ;; Just ignore the IGNORE decl.

@@ -1044,8 +1044,8 @@
        ((lambda-var-specvar var)
        ;; ANSI's definition for "Declaration IGNORE, IGNORABLE"
        ;; requires that this be a STYLE-WARNING, not a full WARNING.
        ((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
        ((eq (first spec) 'ignorable)
        (setf (leaf-ever-used var) t))
        (t

@@ -1094,12 +1094,12 @@
       (dynamic-extent
        (when (policy *lexenv* (> speed inhibit-warnings))
         (compiler-note
       (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))
        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
        res))))
 
 ;;; Use a list of DECLARE forms to annotate the lists of LAMBDA-VAR

@@ -2018,10 +2018,10 @@
      ;; 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
      ;; 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
      :really-assert
      (and for-real
          (not (and info

diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp
index 1760dbc..6dbca4d 100644 (file)
--- a/src/compiler/ir1util.lisp
+++ b/src/compiler/ir1util.lisp
@@ -948,8 +948,8 @@
        (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.
        (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))
 
        (setf (leaf-ever-used var) t)))) ; to avoid repeated warnings? -- WHN
   (values))
 

@@ -1357,7 +1357,7 @@
     (handler-case (apply function args)
       (error (condition)
        (let ((*compiler-error-context* node))
     (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
          (return-from careful-call (values nil nil))))))
    t))
 \f

diff --git a/src/compiler/ir2tran.lisp b/src/compiler/ir2tran.lisp
index 2fd642e..20f5961 100644 (file)
--- a/src/compiler/ir2tran.lisp
+++ b/src/compiler/ir2tran.lisp
@@ -1606,7 +1606,7 @@
                   (unless (or (node-tail-p last)
                               (info :function :info name)
                               (policy last (zerop safety)))
                   (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)
                          (if name
                              (emit-constant name)
                              (multiple-value-bind (tn named)

diff --git a/src/compiler/locall.lisp b/src/compiler/locall.lisp
index 311c5cd..7a0b50d 100644 (file)
--- a/src/compiler/locall.lisp
+++ b/src/compiler/locall.lisp
@@ -477,7 +477,7 @@
           ;; 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.
           ;; 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)))))
            "function called with ~R argument~:P, but wants exactly ~R"
            call-args nargs)
           (setf (basic-combination-kind call) :error)))))

@@ -498,7 +498,7 @@
     (cond ((< call-args min-args)
           ;; FIXME: See FIXME note at the previous
           ;; wrong-number-of-arguments warnings in this file.
     (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))
            "function called with ~R argument~:P, but wants at least ~R"
            call-args min-args)
           (setf (basic-combination-kind call) :error))

@@ -511,7 +511,7 @@
          (t
           ;; FIXME: See FIXME note at the previous
           ;; wrong-number-of-arguments warnings in this file.
          (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))))
            "function called with ~R argument~:P, but wants at most ~R"
            call-args max-args)
           (setf (basic-combination-kind call) :error))))

@@ -582,14 +582,14 @@
               (key-vars var))
              ((:rest :optional))
              ((:more-context :more-count)
               (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))
               (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))
 
          (setf (basic-combination-kind call) :error)
          (return-from convert-more-call))

@@ -618,8 +618,8 @@
                    (return)))))))
 
        (when (and loser (not (optional-dispatch-allowp fun)))
                    (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)))
 
          (setf (basic-combination-kind call) :error)
          (return-from convert-more-call)))
 

diff --git a/src/compiler/ltn.lisp b/src/compiler/ltn.lisp
index bb0dcd8..fe64801 100644 (file)
--- a/src/compiler/ltn.lisp
+++ b/src/compiler/ltn.lisp
@@ -801,31 +801,31 @@
     (when (losers)
       (collect ((messages)
                (count 0 +))
     (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*))
                 (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)))
              (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)
              (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
               ((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))
               (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))
              (count 1))))
 
        (let ((*compiler-error-context* call))

@@ -904,13 +904,12 @@
                                (ir1-attributep (function-info-attributes info)
                                                recursive))))))
          (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)
        (ltn-default-call call ltn-policy)
        (return-from ltn-analyze-known-call (values)))
       (setf (basic-combination-info call) template)

diff --git a/src/compiler/main.lisp b/src/compiler/main.lisp
index 70f82fa..37ae369 100644 (file)
--- a/src/compiler/main.lisp
+++ b/src/compiler/main.lisp
@@ -174,11 +174,11 @@
                (warnings (undefined-warning-warnings undef))
                (undefined-warning-count (undefined-warning-count undef)))
            (dolist (*compiler-error-context* warnings)
                (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)))
            (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))))))
        
                   "~W more use~:P of undefined ~(~A~) ~S"
                   more kind name))))))
        

@@ -187,7 +187,7 @@
                                 (remove kind undefs :test-not #'eq
                                         :key #'undefined-warning-kind))))
            (when summary
                                 (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)))))))
               "~:[This ~(~A~) is~;These ~(~A~)s are~] undefined:~
                ~%  ~{~<~%  ~1:;~S~>~^ ~}"
               (cdr summary) kind summary)))))))

diff --git a/src/compiler/meta-vmdef.lisp b/src/compiler/meta-vmdef.lisp
index db70bbe..fb8a496 100644 (file)
--- a/src/compiler/meta-vmdef.lisp
+++ b/src/compiler/meta-vmdef.lisp
@@ -205,9 +205,9 @@
 ;;; 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
 ;;; 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.
 ;;; 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))
   (declare (type index cost))
   (when (or (oddp (length scs)) (null scs))
     (error "malformed SCs spec: ~S" scs))

@@ -216,7 +216,7 @@
        (do-sc-pairs (from-sc to-sc ',scs)
         (unless (eq from-sc to-sc)
           (let ((num (sc-number from-sc)))
        (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
             (setf (svref (sc-load-costs to-sc) num) ',cost)))))
 
      (defun ,name ,lambda-list

@@ -721,7 +721,7 @@
 ;;; 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.
 ;;; 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))
   (collect ((funs))
     (dolist (sc-name (operand-parse-scs op))
       (let* ((sc (meta-sc-or-lose sc-name))

@@ -735,8 +735,8 @@
            (unless (member (sc-name alt) (operand-parse-scs op) :test #'eq)
              (let* ((altn (sc-number alt))
                     (name (if load-p
            (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
                     (found (or (assoc alt (funs) :test #'member)
                                (rassoc name (funs)))))
                (unless name

@@ -765,8 +765,8 @@
 ;;; 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.
 ;;; 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)))
        (load-tn (operand-parse-load-tn op)))
     (if funs
        (let* ((tn `(tn-ref-tn ,(operand-parse-temp op)))

@@ -836,8 +836,8 @@
                             (tn-ref-load-tn ,temp)))
                    (binds `(,name ,(decide-to-load parse op)))
                    (if (eq (operand-parse-kind op) :argument)
                             (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
                   (t
                    (binds `(,name (tn-ref-tn ,temp)))))))
          (:temporary

diff --git a/src/compiler/pack.lisp b/src/compiler/pack.lisp
index b89c5e1..9830f97 100644 (file)
--- a/src/compiler/pack.lisp
+++ b/src/compiler/pack.lisp
@@ -280,7 +280,7 @@
 
 ;;; Give someone a hard time because there isn't any load function
 ;;; defined to move from SRC to DEST.
 
 ;;; 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))
   (let* ((src-sc (tn-sc src))
         (src-name (sc-name src-sc))
         (dest-sc (tn-sc dest))

@@ -466,9 +466,9 @@
   (emit-load-template node block
                      (template-or-lose 'move-operand)
                      src 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)))
                                       (sc-number (tn-sc src)))

-                               (no-load-function-error src dest)))
+                               (no-load-fun-error src dest)))

                      before)
   (values))
 
                      before)
   (values))
 

@@ -1448,7 +1448,7 @@
     (do-ir2-blocks (block component)
       (do ((vop (ir2-block-start-vop block) (vop-next vop)))
          ((null vop))
     (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)))))
 
          (when target-fun
            (funcall target-fun vop)))))
 

diff --git a/src/compiler/proclaim.lisp b/src/compiler/proclaim.lisp
index 8a616d0..acea779 100644 (file)
--- a/src/compiler/proclaim.lisp
+++ b/src/compiler/proclaim.lisp
@@ -45,12 +45,12 @@
              (destructuring-bind (quality raw-value) q-and-v-or-just-q
                (values quality raw-value)))
        (cond ((not (policy-quality-name-p quality))
              (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)))
              ((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)))))
              (t
               (push (cons quality (rational raw-value))
                     result)))))

@@ -192,6 +192,6 @@
         (setf (info :declaration :recognized decl) t)))
       (t
        (unless (info :declaration :recognized kind)
         (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))
   #+sb-xc (/show0 "returning from PROCLAIM")
   (values))

diff --git a/src/compiler/represent.lisp b/src/compiler/represent.lisp
index 77fafae..99df597 100644 (file)
--- a/src/compiler/represent.lisp
+++ b/src/compiler/represent.lisp
@@ -186,11 +186,11 @@
 ;;;; load time.
 
 ;;; FIXME: should probably be conditional on #!+SB-SHOW
 ;;;; 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
   (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 ~
          (dolist (const (sc-constant-scs sc))
            (unless (svref moves (sc-number const))
              (warn "no move function defined to load SC ~S from constant ~

@@ -202,7 +202,7 @@
              (warn "no move function defined to load SC ~S from alternate ~
                     SC ~S"
                    (sc-name sc) (sc-name alt)))
              (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)))))))))
              (warn "no move function defined to save SC ~S to alternate ~
                     SC ~S"
                    (sc-name sc) (sc-name alt)))))))))

diff --git a/src/compiler/target-disassem.lisp b/src/compiler/target-disassem.lisp
index 0b81dd9..2515499 100644 (file)
--- a/src/compiler/target-disassem.lisp
+++ b/src/compiler/target-disassem.lisp
@@ -519,7 +519,7 @@
                         (not (offs-hook-before-address next-hook))))
            (return))
          (unless (< hook-offs cur-offs)
                         (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)))))))
          (pop (dstate-cur-offs-hooks dstate))
          (unless (= (dstate-next-offs dstate) cur-offs)
            (return)))))))

@@ -1317,7 +1317,7 @@
 \f
 ;;; Return a list of the segments of memory containing machine code
 ;;; instructions for FUNCTION.
 \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))
   (declare (type compiled-function function))
   (let* ((code (fun-code function))
         (fun-map (code-fun-map code))

@@ -1504,18 +1504,20 @@
 ;;;; top level functions
 
 ;;; Disassemble the machine code instructions for FUNCTION.
 ;;;; 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))
           (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)))
 
     (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)
 (defun compile-function-lambda-expr (function)
   (declare (type function function))
   (multiple-value-bind (lambda closurep name)

@@ -1525,11 +1527,11 @@
       (error "can't compile a lexical closure"))
     (compile nil lambda)))
 
       (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)))
   (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)
        ((functionp thing)
         thing)
        ((and (listp thing)

@@ -1550,9 +1552,9 @@
           (type (or (member t) stream) stream)
           (type (member t nil) use-labels))
   (pprint-logical-block (*standard-output* nil :per-line-prefix "; ")
           (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
     nil))
 
 ;;; Disassembles the given area of memory starting at ADDRESS and

diff --git a/src/compiler/typetran.lisp b/src/compiler/typetran.lisp
index 228bce0..370708b 100644 (file)
--- a/src/compiler/typetran.lisp
+++ b/src/compiler/typetran.lisp
@@ -507,8 +507,8 @@
              (member-type
               `(member ,object ',(member-type-members type)))
              (args-type
              (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
               `(%typep ,object ,spec))
              (t nil))
            (typecase type

diff --git a/src/compiler/vop.lisp b/src/compiler/vop.lisp
index 0b3a37e..f609a28 100644 (file)
--- a/src/compiler/vop.lisp
+++ b/src/compiler/vop.lisp
@@ -631,7 +631,7 @@
   ;; 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.
   ;; 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
   ;; 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

@@ -760,13 +760,13 @@
   ;; 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
   ;; 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.
   ;; 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
   (load-costs (make-array sc-number-limit :initial-element nil)
              :type sc-vector)
   ;; a vector mapping from SC numbers to possibly

diff --git a/src/compiler/x86/call.lisp b/src/compiler/x86/call.lisp
index 53d6734..8fed92a 100644 (file)
--- a/src/compiler/x86/call.lisp
+++ b/src/compiler/x86/call.lisp
@@ -1354,7 +1354,7 @@
       (inst jmp :ne err-lab))))
 
 ;;; Various other error signallers.
       (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)
             `(define-vop (,name)
                ,@(when translate
                    `((:policy :fast-safe)

@@ -1366,14 +1366,14 @@
                (:save-p :compute-only)
                (:generator 1000
                  (error-call vop ,error ,@args)))))
                (: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)
     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)
     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)
     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)
     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)
     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))

diff --git a/src/compiler/x86/float.lisp b/src/compiler/x86/float.lisp
index 62d186e..e879b5e 100644 (file)
--- a/src/compiler/x86/float.lisp
+++ b/src/compiler/x86/float.lisp
@@ -123,13 +123,13 @@
 \f
 ;;;; move functions
 
 \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))))
 
   ((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)))
   ((single-reg) (single-stack))
   (cond ((zerop (tn-offset x))
         (inst fst (ea-for-sf-stack y)))

@@ -139,12 +139,12 @@
         ;; This may not be necessary as ST0 is likely invalid now.
         (inst fxch x))))
 
         ;; 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))))
 
   ((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)))
   ((double-reg) (double-stack))
   (cond ((zerop (tn-offset x))
         (inst fstd (ea-for-df-stack y)))

@@ -155,13 +155,13 @@
         (inst fxch x))))
 
 #!+long-float
         (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
   ((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)))
   ((long-reg) (long-stack))
   (cond ((zerop (tn-offset x))
         (store-long-float (ea-for-lf-stack y)))

@@ -177,7 +177,7 @@
 ;;; 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.
 ;;; 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)
   ((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)

@@ -223,8 +223,8 @@
   (make-random-tn :kind :normal :sc (sc-or-lose 'long-reg)
                  :offset (1+ (tn-offset x))))
 
   (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)
   ((complex-single-stack) (complex-single-reg))
   (let ((real-tn (complex-single-reg-real-tn y)))
     (with-empty-tn@fp-top (real-tn)

@@ -233,7 +233,7 @@
     (with-empty-tn@fp-top (imag-tn)
       (inst fld (ea-for-csf-imag-stack x)))))
 
     (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))
   ((complex-single-reg) (complex-single-stack))
   (let ((real-tn (complex-single-reg-real-tn x)))
     (cond ((zerop (tn-offset real-tn))

@@ -247,7 +247,7 @@
     (inst fst (ea-for-csf-imag-stack y))
     (inst fxch imag-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)
   ((complex-double-stack) (complex-double-reg))
   (let ((real-tn (complex-double-reg-real-tn y)))
     (with-empty-tn@fp-top(real-tn)

@@ -256,7 +256,7 @@
     (with-empty-tn@fp-top(imag-tn)
       (inst fldd (ea-for-cdf-imag-stack x)))))
 
     (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))
   ((complex-double-reg) (complex-double-stack))
   (let ((real-tn (complex-double-reg-real-tn x)))
     (cond ((zerop (tn-offset real-tn))

@@ -271,7 +271,7 @@
     (inst fxch imag-tn)))
 
 #!+long-float
     (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)
   ((complex-long-stack) (complex-long-reg))
   (let ((real-tn (complex-long-reg-real-tn y)))
     (with-empty-tn@fp-top(real-tn)

@@ -281,7 +281,7 @@
       (inst fldl (ea-for-clf-imag-stack x)))))
 
 #!+long-float
       (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))
   ((complex-long-reg) (complex-long-stack))
   (let ((real-tn (complex-long-reg-real-tn x)))
     (cond ((zerop (tn-offset real-tn))

diff --git a/src/compiler/x86/move.lisp b/src/compiler/x86/move.lisp
index 20fb961..74ea38e 100644 (file)
--- a/src/compiler/x86/move.lisp
+++ b/src/compiler/x86/move.lisp
@@ -11,7 +11,7 @@
 
 (in-package "SB!VM")
 
 
 (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)))
   ((immediate)
    (any-reg descriptor-reg))
   (let ((val (tn-value x)))

@@ -26,23 +26,23 @@
        (inst mov y (logior (ash (char-code val) n-widetag-bits)
                           base-char-widetag))))))
 
        (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)))
 
   ((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))))
 
   ((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))))
 
   ((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))
 
   ((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)
   ((control-stack) (any-reg descriptor-reg)
    (base-char-stack) (base-char-reg)
    (sap-stack) (sap-reg)

@@ -50,7 +50,7 @@
    (unsigned-stack) (unsigned-reg))
   (inst mov y x))
 
    (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)
   ((any-reg descriptor-reg) (control-stack)
    (base-char-reg) (base-char-stack)
    (sap-reg) (sap-stack)

diff --git a/src/compiler/x86/type-vops.lisp b/src/compiler/x86/type-vops.lisp
index af77dd8..62f09a3 100644 (file)
--- a/src/compiler/x86/type-vops.lisp
+++ b/src/compiler/x86/type-vops.lisp
@@ -323,8 +323,8 @@
 (def-simple-type-vops fixnump check-fixnum fixnum object-not-fixnum-error
   even-fixnum-lowtag odd-fixnum-lowtag)
 
 (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)
 
 (def-type-vops listp check-list list object-not-list-error
   list-pointer-lowtag)

diff --git a/src/pcl/combin.lisp b/src/pcl/combin.lisp
index 610011b..0a7c7d6 100644 (file)
--- a/src/pcl/combin.lisp
+++ b/src/pcl/combin.lisp
@@ -60,7 +60,7 @@
       (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
       (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)))
 
       (make-effective-method-function-internal generic-function form
                                               method-alist-p wrappers-p)))
 

@@ -266,16 +266,16 @@
           (effective-method-lambda (expand-effective-method-function
                                     generic-function effective-method)))
       (multiple-value-bind (cfunction constants)
           (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)
        (lambda (method-alist wrappers)
          (let* ((constants
                  (mapcar (lambda (constant)

diff --git a/src/pcl/fast-init.lisp b/src/pcl/fast-init.lisp
index 8f21ad6..c3d28ab 100644 (file)
--- a/src/pcl/fast-init.lisp
+++ b/src/pcl/fast-init.lisp
@@ -154,8 +154,8 @@
     initargs-form-list
     new-keys
     default-initargs-function
     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
     constants
     combined-initialize-function ; allocate-instance + shared-initialize
     make-instance-function ; nil means use gf

@@ -288,7 +288,7 @@
       ((default-initargs-function)
        (let ((initargs-form-list (initialize-info-initargs-form-list info)))
         (setf (initialize-info-cached-default-initargs-function info)
       ((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)
                'default-initargs-function info
                class initargs-form-list))))
       ((valid-p ri-valid-p)

@@ -310,21 +310,21 @@
                 (compute-valid-p
                  (list (list* 'reinitialize-instance proto nil)
                        (list* 'shared-initialize proto nil nil)))))))
                 (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))
        (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))))
                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))
        (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))
                class initialize-form-list))))
       ((constants combined-initialize-function)
        (let ((initargs-form-list (initialize-info-initargs-form-list info))

@@ -333,7 +333,7 @@
             (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)
             (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)
                  'combined-initialize-function info
                  class (append initargs-form-list initialize-form-list))))))
       ((make-instance-function-symbol)

@@ -562,9 +562,9 @@
                                     info)))
     (if separate-p
        (values default-initargs-function
                                     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
        (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))))))
 
                 (initialize-info class (initialize-info-new-keys info)
                                  nil allow-other-keys-arg))))))
 

@@ -688,21 +688,21 @@
 (defvar *initialize-instance-simple-alist* nil)
 (defvar *note-iis-entry-p* nil)
 
 (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))
 
   (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*
   (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
        (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)
                  t)
            (if entry
                (setf (cdddr entry) (union (list sf-key) (cdddr entry)

@@ -734,7 +734,7 @@
     (setf (cadr entry) function)
     (setf (caddr entry) system)
     (dolist (use uses)
     (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))))
 
     (setf (cdddr entry) (union uses (cdddr entry)
                               :test #'equal))))
 

diff --git a/src/pcl/fngen.lisp b/src/pcl/fngen.lisp
index aec5b59..17a6e72 100644 (file)
--- a/src/pcl/fngen.lisp
+++ b/src/pcl/fngen.lisp
@@ -23,40 +23,41 @@
 
 (in-package "SB-PCL")
 \f
 
 (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.
 ;;; 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
 ;;; 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
 ;;;            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.
 ;;;
 ;;;            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)))
 
                  (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 default-constantp (form)
   (and (constantp form)

@@ -108,7 +109,7 @@
 (defun fgen-generator-lambda (fgen) (svref fgen 3))
 (defun fgen-system          (fgen) (svref fgen 4))
 \f
 (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
   (let* ((test (compute-test lambda test-converter))
         (fgen (lookup-fgen test)))
     (if fgen

diff --git a/src/pcl/init.lisp b/src/pcl/init.lisp
index 927eb47..a1821ec 100644 (file)
--- a/src/pcl/init.lisp
+++ b/src/pcl/init.lisp
@@ -132,13 +132,13 @@
   (when (eq slot-names t)
     (return-from shared-initialize
       (call-initialize-function
   (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 (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:
        (initialize-info (class-of instance) initargs))
        instance initargs)))
   ;; Initialize the instance's slots in a two step process:

diff --git a/src/pcl/methods.lisp b/src/pcl/methods.lisp
index 767d305..40d501e 100644 (file)
--- a/src/pcl/methods.lisp
+++ b/src/pcl/methods.lisp
@@ -132,9 +132,9 @@
     (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))
     (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))
          (check-documentation (legal-documentation-p method documentation)))
       (unless (eq check-qualifiers t)
        (lose :qualifiers qualifiers check-qualifiers))

@@ -142,8 +142,8 @@
        (lose :lambda-list lambda-list check-lambda-list))
       (unless (eq check-specializers t)
        (lose :specializers specializers check-specializers))
        (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)))))
 
       (unless (eq check-documentation t)
        (lose :documentation documentation check-documentation)))))
 

@@ -1052,7 +1052,7 @@
            `(and ,new-type ,@so-far)))))
 
 (defun generate-discrimination-net-internal
            `(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))
   (let* ((arg-info (gf-arg-info gf))
         (precedence (arg-info-precedence arg-info))
         (nreq (arg-info-number-required arg-info))

@@ -1109,7 +1109,7 @@
                                    known-types))))
                         (cond ((determined-to-be nil) (do-if nil t))
                               ((determined-to-be t)   (do-if t   t))
                                    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 ()))))
 
                                           (do-if t) (do-if nil))))))))))
       (do-column precedence methods ()))))
 

@@ -1258,20 +1258,20 @@
                        (make-dfun-lambda-list metatypes applyp)
                        (make-fast-method-call-lambda-list metatypes applyp))))
       (multiple-value-bind (cfunction constants)
                        (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))
        (lambda (method-alist wrappers)
          (let* ((alist (list nil))
                 (alist-tail alist))

diff --git a/src/pcl/walk.lisp b/src/pcl/walk.lisp
index b1bd974..a29e048 100644 (file)
--- a/src/pcl/walk.lisp
+++ b/src/pcl/walk.lisp
@@ -100,7 +100,7 @@
 ;;; 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
 ;;; 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.
 ;;;
 ;;; MACROEXPAND-1 is the only SBCL function that gets called with the
 ;;; constructed environment argument.

@@ -114,29 +114,29 @@
                                                        ,macros)))
      ,@body))
 
                                                        ,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
 ;;; 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
   (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))
     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
    
 (defun with-augmented-environment-internal (env functions macros)
   ;; Note: In order to record the correct function definition, we

@@ -157,7 +157,7 @@
                        (list* (car m)
                               'sb-c::macro
                                (if (eq (car m) *key-to-walker-environment*)
                        (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)))))
 
                                   (coerce (cadr m) 'function))))
                       macros)))))
 

@@ -174,7 +174,7 @@
       (and entry
           (eq (cadr entry) 'sb-c::macro)
            (if (eq macro *key-to-walker-environment*)
       (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
               (values (function-lambda-expression (cddr entry))))))))
 \f
 ;;;; other environment hacking, not so SBCL-specific as the

diff --git a/tests/interface.pure.lisp b/tests/interface.pure.lisp
index 4ad2ffa..858ee3f 100644 (file)
--- a/tests/interface.pure.lisp
+++ b/tests/interface.pure.lisp
@@ -32,7 +32,7 @@
       (sb-kernel:%simple-fun-arglist fun))
     (#.sb-vm:closure-header-widetag (has-arglist-info-p
                                     (sb-kernel:%closure-fun fun)))
       (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.
     ;; like above, and it seems to work. -- MNA 2001-06-12
     ;;
     ;; (There might be other cases with arglist info also.

diff --git a/version.lisp-expr b/version.lisp-expr
index 8117aba..4079ae1 100644 (file)
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -18,4 +18,4 @@
 ;;; for internal versions, especially for internal versions off the
 ;;; main CVS branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
 
 ;;; 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"