From: William Harold Newman Date: Thu, 17 Jan 2002 15:41:19 +0000 (+0000) Subject: 0.pre7.141: X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=0c7ffa8fb85a94482814835c9f28abfd0400ab99;p=sbcl.git 0.pre7.141: made DESCRIBE output of PACKAGE data more concise s/def-frob/def/ --- diff --git a/TODO b/TODO index f8752b4..9918cbf 100644 --- a/TODO +++ b/TODO @@ -5,11 +5,8 @@ for 0.7.0: leaving some filing for later:-) from the monster EVAL/EVAL-WHEN/%COMPILE/DEFUN/DEFSTRUCT cleanup: * more renaming (esp. for global as opposed to lexical names): - ** reserved DO-FOO-style names for iteration macros - ** s/ARGUMENT/ARG/ - ** perhaps s/DEF-FROB/DEF/ or s/DEF-FROB/DEFINE/ - ** merged SB-C-CALL into SB-ALIEN -* Perhaps rename "cold" stuff (e.g. SB-COLD and src/cold/) to "boot". + ** Rename "cold" stuff (e.g. SB-COLD and src/cold/, though + not e.g. #'COLD-INIT) to "boot". * fixed CREDITS, since it's gone pretty stale * reviewed NEWS * pending patches and bug reports that go in (or else get handled diff --git a/src/code/array.lisp b/src/code/array.lisp index 8adb473..dbbfbee 100644 --- a/src/code/array.lisp +++ b/src/code/array.lisp @@ -19,18 +19,18 @@ ;;; These functions are only needed by the interpreter, 'cause the ;;; compiler inlines them. -(macrolet ((def-frob (name) +(macrolet ((def (name) `(progn (defun ,name (array) (,name array)) (defun (setf ,name) (value array) (setf (,name array) value))))) - (def-frob %array-fill-pointer) - (def-frob %array-fill-pointer-p) - (def-frob %array-available-elements) - (def-frob %array-data-vector) - (def-frob %array-displacement) - (def-frob %array-displaced-p)) + (def %array-fill-pointer) + (def %array-fill-pointer-p) + (def %array-available-elements) + (def %array-data-vector) + (def %array-displacement) + (def %array-displaced-p)) (defun %array-rank (array) (%array-rank array)) diff --git a/src/code/backq.lisp b/src/code/backq.lisp index 4c13b43..1a30b5d 100644 --- a/src/code/backq.lisp +++ b/src/code/backq.lisp @@ -204,7 +204,7 @@ ;;; Define synonyms for the lisp functions we use, so that by using ;;; them, the backquoted material will be recognizable to the ;;; pretty-printer. -(macrolet ((def-frob (b-name name) +(macrolet ((def (b-name name) (let ((args (gensym "ARGS"))) ;; FIXME: This function should be INLINE so that the lists ;; aren't consed twice, but I ran into an optimizer bug the @@ -213,11 +213,11 @@ ;; then make these INLINE. `(defun ,b-name (&rest ,args) (apply #',name ,args))))) - (def-frob backq-list list) - (def-frob backq-list* list*) - (def-frob backq-append append) - (def-frob backq-nconc nconc) - (def-frob backq-cons cons)) + (def backq-list list) + (def backq-list* list*) + (def backq-append append) + (def backq-nconc nconc) + (def backq-cons cons)) (/show0 "backq.lisp 204") diff --git a/src/code/bit-bash.lisp b/src/code/bit-bash.lisp index 68865a9..47a86fc 100644 --- a/src/code/bit-bash.lisp +++ b/src/code/bit-bash.lisp @@ -39,20 +39,20 @@ ;;; A particular implementation must offer either VOPs to translate ;;; these, or DEFTRANSFORMs to convert them into something supported ;;; by the architecture. -(macrolet ((def-frob (name &rest args) +(macrolet ((def (name &rest args) `(defun ,name ,args (,name ,@args)))) - (def-frob 32bit-logical-not x) - (def-frob 32bit-logical-and x y) - (def-frob 32bit-logical-or x y) - (def-frob 32bit-logical-xor x y) - (def-frob 32bit-logical-nor x y) - (def-frob 32bit-logical-eqv x y) - (def-frob 32bit-logical-nand x y) - (def-frob 32bit-logical-andc1 x y) - (def-frob 32bit-logical-andc2 x y) - (def-frob 32bit-logical-orc1 x y) - (def-frob 32bit-logical-orc2 x y)) + (def 32bit-logical-not x) + (def 32bit-logical-and x y) + (def 32bit-logical-or x y) + (def 32bit-logical-xor x y) + (def 32bit-logical-nor x y) + (def 32bit-logical-eqv x y) + (def 32bit-logical-nand x y) + (def 32bit-logical-andc1 x y) + (def 32bit-logical-andc2 x y) + (def 32bit-logical-orc1 x y) + (def 32bit-logical-orc2 x y)) ;;; Shift NUMBER by the low-order bits of COUNTOID, adding zero bits ;;; at the "end" and removing bits from the "start". On big-endian diff --git a/src/code/coerce.lisp b/src/code/coerce.lisp index c9630f6..0d1dcff 100644 --- a/src/code/coerce.lisp +++ b/src/code/coerce.lisp @@ -11,7 +11,7 @@ (in-package "SB!IMPL") -(macrolet ((def-frob (name result access src-type &optional typep) +(macrolet ((def (name result access src-type &optional typep) `(defun ,name (object ,@(if typep '(type) ())) (do* ((index 0 (1+ index)) (length (length (the ,(ecase src-type @@ -27,20 +27,20 @@ (:list '(pop in-object)) (:vector '(aref in-object index)))))))) - (def-frob list-to-simple-string* (make-string length) schar :list) + (def list-to-simple-string* (make-string length) schar :list) - (def-frob list-to-bit-vector* (make-array length :element-type '(mod 2)) + (def list-to-bit-vector* (make-array length :element-type '(mod 2)) sbit :list) - (def-frob list-to-vector* (make-sequence-of-type type length) + (def list-to-vector* (make-sequence-of-type type length) aref :list t) - (def-frob vector-to-vector* (make-sequence-of-type type length) + (def vector-to-vector* (make-sequence-of-type type length) aref :vector t) - (def-frob vector-to-simple-string* (make-string length) schar :vector) + (def vector-to-simple-string* (make-string length) schar :vector) - (def-frob vector-to-bit-vector* (make-array length :element-type '(mod 2)) + (def vector-to-bit-vector* (make-array length :element-type '(mod 2)) sbit :vector)) (defun vector-to-list* (object) diff --git a/src/code/float.lisp b/src/code/float.lisp index bb60ed5..104818c 100644 --- a/src/code/float.lisp +++ b/src/code/float.lisp @@ -195,7 +195,7 @@ (and (zerop (ldb sb!vm:long-float-exponent-byte (long-float-exp-bits x))) (not (zerop x)))))) -(macrolet ((def-frob (name doc single double #!+(and long-float x86) long) +(macrolet ((def (name doc single double #!+(and long-float x86) long) `(defun ,name (x) ,doc (number-dispatch ((x float)) @@ -221,7 +221,7 @@ sb!vm:long-float-normal-exponent-max) ,long))))))) - (def-frob float-infinity-p + (def float-infinity-p "Return true if the float X is an infinity (+ or -)." (zerop (ldb sb!vm:single-float-significand-byte bits)) (and (zerop (ldb sb!vm:double-float-significand-byte hi)) @@ -230,7 +230,7 @@ (and (zerop (ldb sb!vm:long-float-significand-byte hi)) (zerop lo))) - (def-frob float-nan-p + (def float-nan-p "Return true if the float X is a NaN (Not a Number)." (not (zerop (ldb sb!vm:single-float-significand-byte bits))) (or (not (zerop (ldb sb!vm:double-float-significand-byte hi))) @@ -239,7 +239,7 @@ (or (not (zerop (ldb sb!vm:long-float-significand-byte hi))) (not (zerop lo)))) - (def-frob float-trapping-nan-p + (def float-trapping-nan-p "Return true if the float X is a trapping NaN (Not a Number)." (zerop (logand (ldb sb!vm:single-float-significand-byte bits) sb!vm:single-float-trapping-nan-bit)) diff --git a/src/code/numbers.lisp b/src/code/numbers.lisp index fac1b02..f663791 100644 --- a/src/code/numbers.lisp +++ b/src/code/numbers.lisp @@ -679,18 +679,18 @@ (+ rem divisor) rem))) -(macrolet ((def-frob (name op doc) +(macrolet ((def (name op doc) `(defun ,name (number &optional (divisor 1)) ,doc (multiple-value-bind (res rem) (,op number divisor) (values (float res (if (floatp rem) rem 1.0)) rem))))) - (def-frob ffloor floor + (def ffloor floor "Same as FLOOR, but returns first value as a float.") - (def-frob fceiling ceiling + (def fceiling ceiling "Same as CEILING, but returns first value as a float." ) - (def-frob ftruncate truncate + (def ftruncate truncate "Same as TRUNCATE, but returns first value as a float.") - (def-frob fround round + (def fround round "Same as ROUND, but returns first value as a float.")) ;;;; comparisons @@ -978,13 +978,13 @@ (fixnum (lognot (truly-the fixnum number))) (bignum (bignum-logical-not number)))) -(macrolet ((def-frob (name op big-op) +(macrolet ((def (name op big-op) `(defun ,name (x y) (number-dispatch ((x integer) (y integer)) (bignum-cross-fixnum ,op ,big-op))))) - (def-frob two-arg-and logand bignum-logical-and) - (def-frob two-arg-ior logior bignum-logical-ior) - (def-frob two-arg-xor logxor bignum-logical-xor)) + (def two-arg-and logand bignum-logical-and) + (def two-arg-ior logior bignum-logical-ior) + (def two-arg-xor logxor bignum-logical-xor)) (defun logcount (integer) #!+sb-doc @@ -1315,10 +1315,10 @@ ;;;; miscellaneous number predicates -(macrolet ((def-frob (name doc) +(macrolet ((def (name doc) `(defun ,name (number) ,doc (,name number)))) - (def-frob zerop "Is this number zero?") - (def-frob plusp "Is this real number strictly positive?") - (def-frob minusp "Is this real number strictly negative?") - (def-frob oddp "Is this integer odd?") - (def-frob evenp "Is this integer even?")) + (def zerop "Is this number zero?") + (def plusp "Is this real number strictly positive?") + (def minusp "Is this real number strictly negative?") + (def oddp "Is this integer odd?") + (def evenp "Is this integer even?")) diff --git a/src/code/stubs.lisp b/src/code/stubs.lisp index 61ef516..0a50761 100644 --- a/src/code/stubs.lisp +++ b/src/code/stubs.lisp @@ -13,15 +13,15 @@ (in-package "SB!IMPL") -(macrolet ((def-frob (name &optional (args '(x))) +(macrolet ((def (name &optional (args '(x))) `(defun ,name ,args (,name ,@args)))) - (def-frob %code-code-size) - (def-frob %code-debug-info) - (def-frob %code-entry-points) - (def-frob %funcallable-instance-fun) - (def-frob %funcallable-instance-layout) - (def-frob %funcallable-instance-lexenv) - (def-frob %set-funcallable-instance-fun (fin new-val))) + (def %code-code-size) + (def %code-debug-info) + (def %code-entry-points) + (def %funcallable-instance-fun) + (def %funcallable-instance-layout) + (def %funcallable-instance-lexenv) + (def %set-funcallable-instance-fun (fin new-val))) (defun %caller-frame-and-pc () (%caller-frame-and-pc)) diff --git a/src/code/target-package.lisp b/src/code/target-package.lisp index 127e2ea..29fe5bc 100644 --- a/src/code/target-package.lisp +++ b/src/code/target-package.lisp @@ -84,12 +84,12 @@ ;;; ANSI says (in the definition of DELETE-PACKAGE) that these, and ;;; most other operations, are unspecified for deleted packages. We ;;; just do the easy thing and signal errors in that case. -(macrolet ((def-frob (ext real) +(macrolet ((def (ext real) `(defun ,ext (x) (,real (find-undeleted-package-or-lose x))))) - (def-frob package-nicknames package-%nicknames) - (def-frob package-use-list package-%use-list) - (def-frob package-used-by-list package-%used-by-list) - (def-frob package-shadowing-symbols package-%shadowing-symbols)) + (def package-nicknames package-%nicknames) + (def package-use-list package-%use-list) + (def package-used-by-list package-%used-by-list) + (def package-shadowing-symbols package-%shadowing-symbols)) (defun %package-hashtable-symbol-count (table) (let ((size (the fixnum diff --git a/src/compiler/array-tran.lisp b/src/compiler/array-tran.lisp index 98befa5..5551e17 100644 --- a/src/compiler/array-tran.lisp +++ b/src/compiler/array-tran.lisp @@ -682,9 +682,10 @@ ;;;; and eliminates the need for any VM-dependent transforms to handle ;;;; these cases. -(macrolet ((def-frob (fun) +(macrolet ((def (fun) `(progn - (deftransform ,fun ((bit-array-1 bit-array-2 &optional result-bit-array) + (deftransform ,fun ((bit-array-1 bit-array-2 + &optional result-bit-array) (bit-vector bit-vector &optional null) * :policy (>= speed space)) `(,',fun bit-array-1 bit-array-2 @@ -693,16 +694,16 @@ (deftransform ,fun ((bit-array-1 bit-array-2 result-bit-array) (bit-vector bit-vector (member t)) *) `(,',fun bit-array-1 bit-array-2 bit-array-1))))) - (def-frob bit-and) - (def-frob bit-ior) - (def-frob bit-xor) - (def-frob bit-eqv) - (def-frob bit-nand) - (def-frob bit-nor) - (def-frob bit-andc1) - (def-frob bit-andc2) - (def-frob bit-orc1) - (def-frob bit-orc2)) + (def bit-and) + (def bit-ior) + (def bit-xor) + (def bit-eqv) + (def bit-nand) + (def bit-nor) + (def bit-andc1) + (def bit-andc2) + (def bit-orc1) + (def bit-orc2)) ;;; Similar for BIT-NOT, but there is only one arg... (deftransform bit-not ((bit-array-1 &optional result-bit-array) diff --git a/src/compiler/debug.lisp b/src/compiler/debug.lisp index e83428b..d6e226b 100644 --- a/src/compiler/debug.lisp +++ b/src/compiler/debug.lisp @@ -879,9 +879,17 @@ ;;;; data structure dumping routines -;;; When we print Continuations and TNs, we assign them small numeric IDs so -;;; that we can get a handle on anonymous objects given a printout. -(macrolet ((def-frob (counter vto vfrom fto ffrom) +;;; When we print CONTINUATIONs and TNs, we assign them small numeric +;;; IDs so that we can get a handle on anonymous objects given a +;;; printout. +;;; +;;; FIXME: +;;; * Perhaps this machinery should be #!+SB-SHOW. +;;; * Probably the hash tables should either be weak hash tables, +;;; or only allocated within a single compilation unit. Otherwise +;;; there will be a tendency for them to grow without bound and +;;; keep garbage from being collected. +(macrolet ((def (counter vto vfrom fto ffrom) `(progn (defvar ,vto (make-hash-table :test 'eq)) (defvar ,vfrom (make-hash-table :test 'eql)) @@ -897,9 +905,10 @@ (defun ,ffrom (num) (values (gethash num ,vfrom)))))) - (def-frob *continuation-number* *continuation-numbers* *number-continuations* cont-num num-cont) - (def-frob *tn-id* *tn-ids* *id-tns* tn-id id-tn) - (def-frob *label-id* *id-labels* *label-ids* label-id id-label)) + (def *continuation-number* *continuation-numbers* *number-continuations* + cont-num num-cont) + (def *tn-id* *tn-ids* *id-tns* tn-id id-tn) + (def *label-id* *id-labels* *label-ids* label-id id-label)) ;;; Print a terse one-line description of LEAF. (defun print-leaf (leaf &optional (stream *standard-output*)) diff --git a/src/compiler/float-tran.lisp b/src/compiler/float-tran.lisp index d1d3005..8279727 100644 --- a/src/compiler/float-tran.lisp +++ b/src/compiler/float-tran.lisp @@ -390,29 +390,29 @@ (double-float) double-float (movable foldable flushable)) -(macrolet ((def-frob (name prim rtype) +(macrolet ((def (name prim rtype) `(progn (deftransform ,name ((x) (single-float) ,rtype) `(coerce (,',prim (coerce x 'double-float)) 'single-float)) (deftransform ,name ((x) (double-float) ,rtype :when :both) `(,',prim x))))) - (def-frob exp %exp *) - (def-frob log %log float) - (def-frob sqrt %sqrt float) - (def-frob asin %asin float) - (def-frob acos %acos float) - (def-frob atan %atan *) - (def-frob sinh %sinh *) - (def-frob cosh %cosh *) - (def-frob tanh %tanh *) - (def-frob asinh %asinh *) - (def-frob acosh %acosh float) - (def-frob atanh %atanh float)) + (def exp %exp *) + (def log %log float) + (def sqrt %sqrt float) + (def asin %asin float) + (def acos %acos float) + (def atan %atan *) + (def sinh %sinh *) + (def cosh %cosh *) + (def tanh %tanh *) + (def asinh %asinh *) + (def acosh %acosh float) + (def atanh %atanh float)) ;;; The argument range is limited on the x86 FP trig. functions. A ;;; post-test can detect a failure (and load a suitable result), but ;;; this test is avoided if possible. -(macrolet ((def-frob (name prim prim-quick) +(macrolet ((def (name prim prim-quick) (declare (ignorable prim-quick)) `(progn (deftransform ,name ((x) (single-float) *) @@ -442,9 +442,9 @@ (type-specifier (continuation-type x))) `(,',prim x))) #!-x86 `(,',prim x))))) - (def-frob sin %sin %sin-quick) - (def-frob cos %cos %cos-quick) - (def-frob tan %tan %tan-quick)) + (def sin %sin %sin-quick) + (def cos %cos %cos-quick) + (def tan %tan %tan-quick)) (deftransform atan ((x y) (single-float single-float) *) `(coerce (%atan2 (coerce x 'double-float) (coerce y 'double-float)) diff --git a/src/compiler/generic/early-objdef.lisp b/src/compiler/generic/early-objdef.lisp index e713b89..18596f4 100644 --- a/src/compiler/generic/early-objdef.lisp +++ b/src/compiler/generic/early-objdef.lisp @@ -15,7 +15,7 @@ ;;; a pain for people just learning to find their way around the code ;;; who want to use lexical search to figure out where things like ;;; EVEN-FIXNUM-LOWTAG are defined. Remove the :SUFFIXes and just expand -;;; out the full names. Or even define them in DEF-FROB EVEN-FIXNUM-LOWTAG +;;; out the full names. Or even define them in DEF EVEN-FIXNUM-LOWTAG ;;; style so searches like 'def.*even-fixnum-lowtag' can find them. ;;; tags for the main low-level types, to be stored in the low three diff --git a/src/compiler/generic/vm-tran.lisp b/src/compiler/generic/vm-tran.lisp index 64f5fb1..8b24413 100644 --- a/src/compiler/generic/vm-tran.lisp +++ b/src/compiler/generic/vm-tran.lisp @@ -179,24 +179,30 @@ (frob (simple-array (unsigned-byte 2) (*)) 2) (frob (simple-array (unsigned-byte 4) (*)) 4)) -;;;; bit vector hackery +;;;; BIT-VECTOR hackery -;;; SIMPLE-BIT-VECTOR bit-array operations are transformed to a word loop that -;;; does 32 bits at a time. +;;; SIMPLE-BIT-VECTOR bit-array operations are transformed to a word +;;; loop that does 32 bits at a time. ;;; -;;; FIXME: This is a lot of repeatedly macroexpanded code. It should be a -;;; function call instead. -(macrolet ((def-frob (bitfun wordfun) +;;; FIXME: This is a lot of repeatedly macroexpanded code. It should +;;; be a function call instead. +(macrolet ((def (bitfun wordfun) `(deftransform ,bitfun ((bit-array-1 bit-array-2 result-bit-array) - (simple-bit-vector simple-bit-vector simple-bit-vector) * + (simple-bit-vector + simple-bit-vector + simple-bit-vector) + * :node node :policy (>= speed space)) `(progn ,@(unless (policy node (zerop safety)) - '((unless (= (length bit-array-1) (length bit-array-2) + '((unless (= (length bit-array-1) + (length bit-array-2) (length result-bit-array)) (error "Argument and/or result bit arrays are not the same length:~ ~% ~S~% ~S ~% ~S" - bit-array-1 bit-array-2 result-bit-array)))) + bit-array-1 + bit-array-2 + result-bit-array)))) (do ((index sb!vm:vector-data-offset (1+ index)) (end (+ sb!vm:vector-data-offset (truncate (the index @@ -209,16 +215,16 @@ (setf (%raw-bits result-bit-array index) (,',wordfun (%raw-bits bit-array-1 index) (%raw-bits bit-array-2 index)))))))) - (def-frob bit-and 32bit-logical-and) - (def-frob bit-ior 32bit-logical-or) - (def-frob bit-xor 32bit-logical-xor) - (def-frob bit-eqv 32bit-logical-eqv) - (def-frob bit-nand 32bit-logical-nand) - (def-frob bit-nor 32bit-logical-nor) - (def-frob bit-andc1 32bit-logical-andc1) - (def-frob bit-andc2 32bit-logical-andc2) - (def-frob bit-orc1 32bit-logical-orc1) - (def-frob bit-orc2 32bit-logical-orc2)) + (def bit-and 32bit-logical-and) + (def bit-ior 32bit-logical-or) + (def bit-xor 32bit-logical-xor) + (def bit-eqv 32bit-logical-eqv) + (def bit-nand 32bit-logical-nand) + (def bit-nor 32bit-logical-nor) + (def bit-andc1 32bit-logical-andc1) + (def bit-andc2 32bit-logical-andc2) + (def bit-orc1 32bit-logical-orc1) + (def bit-orc2 32bit-logical-orc2)) (deftransform bit-not ((bit-array result-bit-array) diff --git a/src/compiler/ir2tran.lisp b/src/compiler/ir2tran.lisp index f004610..2a37493 100644 --- a/src/compiler/ir2tran.lisp +++ b/src/compiler/ir2tran.lisp @@ -1497,7 +1497,7 @@ ;;;; n-argument functions -(macrolet ((def-frob (name) +(macrolet ((def (name) `(defoptimizer (,name ir2-convert) ((&rest args) node block) (let* ((refs (move-tail-full-call-args node block)) (cont (node-cont node)) @@ -1507,8 +1507,8 @@ (vop* ,name node block (refs) ((first res) nil) (length args)) (move-continuation-result node block res cont))))) - (def-frob list) - (def-frob list*)) + (def list) + (def list*)) ;;; Convert the code in a component into VOPs. (defun ir2-convert (component) diff --git a/src/compiler/policy.lisp b/src/compiler/policy.lisp index d4cd154..6139039 100644 --- a/src/compiler/policy.lisp +++ b/src/compiler/policy.lisp @@ -25,7 +25,7 @@ ;;; names of recognized optimization policy qualities (defvar *policy-qualities*) ; (initialized at cold init) -;;; Is X the name of an optimization quality? +;;; Is X the name of an optimization policy quality? (defun policy-quality-name-p (x) (memq x *policy-qualities*)) diff --git a/src/compiler/saptran.lisp b/src/compiler/saptran.lisp index f98d491..4270fed 100644 --- a/src/compiler/saptran.lisp +++ b/src/compiler/saptran.lisp @@ -109,14 +109,14 @@ ;;;; transforms for converting sap relation operators -(macrolet ((def-frob (sap-fun int-fun) +(macrolet ((def (sap-fun int-fun) `(deftransform ,sap-fun ((x y) * *) `(,',int-fun (sap-int x) (sap-int y))))) - (def-frob sap< <) - (def-frob sap<= <=) - (def-frob sap= =) - (def-frob sap>= >=) - (def-frob sap> >)) + (def sap< <) + (def sap<= <=) + (def sap= =) + (def sap>= >=) + (def sap> >)) ;;;; transforms for optimizing SAP+ @@ -129,32 +129,32 @@ '(lambda (sap offset1 offset2) (sap+ sap (+ offset1 offset2)))))) -(macrolet ((def-frob (fun) +(macrolet ((def (fun) `(deftransform ,fun ((sap offset) * *) (extract-fun-args sap 'sap+ 2) `(lambda (sap offset1 offset2) (,',fun sap (+ offset1 offset2)))))) - (def-frob sap-ref-8) - (def-frob %set-sap-ref-8) - (def-frob signed-sap-ref-8) - (def-frob %set-signed-sap-ref-8) - (def-frob sap-ref-16) - (def-frob %set-sap-ref-16) - (def-frob signed-sap-ref-16) - (def-frob %set-signed-sap-ref-16) - (def-frob sap-ref-32) - (def-frob %set-sap-ref-32) - (def-frob signed-sap-ref-32) - (def-frob %set-signed-sap-ref-32) - (def-frob sap-ref-sap) - (def-frob %set-sap-ref-sap) - (def-frob sap-ref-single) - (def-frob %set-sap-ref-single) - (def-frob sap-ref-double) - (def-frob %set-sap-ref-double) + (def sap-ref-8) + (def %set-sap-ref-8) + (def signed-sap-ref-8) + (def %set-signed-sap-ref-8) + (def sap-ref-16) + (def %set-sap-ref-16) + (def signed-sap-ref-16) + (def %set-signed-sap-ref-16) + (def sap-ref-32) + (def %set-sap-ref-32) + (def signed-sap-ref-32) + (def %set-signed-sap-ref-32) + (def sap-ref-sap) + (def %set-sap-ref-sap) + (def sap-ref-single) + (def %set-sap-ref-single) + (def sap-ref-double) + (def %set-sap-ref-double) ;; The original CMUCL code had #!+(and x86 long-float) for this first one, ;; but only #!+long-float for the second. This was redundant, since the ;; LONG-FLOAT target feature only exists on X86. So we removed the ;; redundancy. --njf 2002-01-08 - #!+long-float (def-frob sap-ref-long) - #!+long-float (def-frob %set-sap-ref-long)) + #!+long-float (def sap-ref-long) + #!+long-float (def %set-sap-ref-long)) diff --git a/src/compiler/seqtran.lisp b/src/compiler/seqtran.lisp index 96d47e9..d2de8d2 100644 --- a/src/compiler/seqtran.lisp +++ b/src/compiler/seqtran.lisp @@ -227,8 +227,9 @@ (deftransform %setelt ((s i v) (list * *)) '(setf (car (nthcdr i s)) v)) -(macrolet ((def-frob (name) - `(deftransform ,name ((e l &key (test #'eql)) * * :node node :when :both) +(macrolet ((def (name) + `(deftransform ,name ((e l &key (test #'eql)) * * + :node node :when :both) (unless (constant-continuation-p l) (give-up-ir1-transform)) @@ -246,14 +247,14 @@ ,(frob (cdr els))) nil))) (frob val)))))) - (def-frob member) - (def-frob memq)) + (def member) + (def memq)) ;;; FIXME: We have rewritten the original code that used DOLIST to this ;;; more natural MACROLET. However, the original code suggested that when ;;; this was done, a few bytes could be saved by a call to a shared ;;; function. This remains to be done. -(macrolet ((def-frob (fun eq-fun) +(macrolet ((def (fun eq-fun) `(deftransform ,fun ((item list &key test) (t list &rest t) *) "convert to EQ test" ;; FIXME: The scope of this transformation could be @@ -272,9 +273,9 @@ (specifier-type 'number)) (give-up-ir1-transform "Item might be a number."))) `(,',eq-fun item list)))) - (def-frob delete delq) - (def-frob assoc assq) - (def-frob member memq)) + (def delete delq) + (def assoc assq) + (def member memq)) (deftransform delete-if ((pred list) (t list)) "open code" @@ -537,23 +538,23 @@ ;;; We transform the case-sensitive string predicates into a non-keyword ;;; version. This is an IR1 transform so that we don't have to worry about ;;; changing the order of evaluation. -(macrolet ((def-frob (fun pred*) +(macrolet ((def (fun pred*) `(deftransform ,fun ((string1 string2 &key (start1 0) end1 (start2 0) end2) * *) `(,',pred* string1 string2 start1 end1 start2 end2)))) - (def-frob string< string<*) - (def-frob string> string>*) - (def-frob string<= string<=*) - (def-frob string>= string>=*) - (def-frob string= string=*) - (def-frob string/= string/=*)) + (def string< string<*) + (def string> string>*) + (def string<= string<=*) + (def string>= string>=*) + (def string= string=*) + (def string/= string/=*)) ;;; Return a form that tests the free variables STRING1 and STRING2 ;;; for the ordering relationship specified by LESSP and EQUALP. The ;;; start and end are also gotten from the environment. Both strings ;;; must be SIMPLE-STRINGs. -(macrolet ((def-frob (name lessp equalp) +(macrolet ((def (name lessp equalp) `(deftransform ,name ((string1 string2 start1 end1 start2 end2) (simple-string simple-string t t t t) *) `(let* ((end1 (if (not end1) (length string1) end1)) @@ -569,24 +570,25 @@ (truly-the index (+ index (truly-the fixnum - (- start2 start1)))))) + (- start2 + start1)))))) index) (t nil)) ,(if ',equalp 'end1 nil)))))) - (def-frob string<* t nil) - (def-frob string<=* t t) - (def-frob string>* nil nil) - (def-frob string>=* nil t)) + (def string<* t nil) + (def string<=* t t) + (def string>* nil nil) + (def string>=* nil t)) -(macrolet ((def-frob (name result-fun) +(macrolet ((def (name result-fun) `(deftransform ,name ((string1 string2 start1 end1 start2 end2) (simple-string simple-string t t t t) *) `(,',result-fun (sb!impl::%sp-string-compare string1 start1 (or end1 (length string1)) string2 start2 (or end2 (length string2))))))) - (def-frob string=* not) - (def-frob string/=* identity)) + (def string=* not) + (def string/=* identity)) ;;;; string-only transforms for sequence functions @@ -705,46 +707,46 @@ "sequence type not known at compile time"))))) ;;; %FIND-POSITION-IF and %FIND-POSITION-IF-NOT for LIST data -(macrolet ((def-frob (name condition) - `(deftransform ,name ((predicate sequence from-end start end key) - (function list t t t function) - * - :policy (> speed space) - :important t) - "expand inline" - `(let ((index 0) - (find nil) - (position nil)) - (declare (type index index)) - (dolist (i sequence (values find position)) - (let ((key-i (funcall key i))) - (when (and end (>= index end)) - (return (values find position))) - (when (>= index start) - (,',condition (funcall predicate key-i) - ;; This hack of dealing with non-NIL - ;; FROM-END for list data by iterating - ;; forward through the list and keeping - ;; track of the last time we found a match - ;; might be more screwy than what the user - ;; expects, but it seems to be allowed by - ;; the ANSI standard. (And if the user is - ;; screwy enough to ask for FROM-END - ;; behavior on list data, turnabout is - ;; fair play.) - ;; - ;; It's also not enormously efficient, - ;; calling PREDICATE and KEY more often - ;; than necessary; but all the - ;; alternatives seem to have their own - ;; efficiency problems. - (if from-end - (setf find i - position index) - (return (values i index)))))) - (incf index)))))) - (def-frob %find-position-if when) - (def-frob %find-position-if-not unless)) +(macrolet ((def (name condition) + `(deftransform ,name ((predicate sequence from-end start end key) + (function list t t t function) + * + :policy (> speed space) + :important t) + "expand inline" + `(let ((index 0) + (find nil) + (position nil)) + (declare (type index index)) + (dolist (i sequence (values find position)) + (let ((key-i (funcall key i))) + (when (and end (>= index end)) + (return (values find position))) + (when (>= index start) + (,',condition (funcall predicate key-i) + ;; This hack of dealing with non-NIL + ;; FROM-END for list data by iterating + ;; forward through the list and keeping + ;; track of the last time we found a match + ;; might be more screwy than what the user + ;; expects, but it seems to be allowed by + ;; the ANSI standard. (And if the user is + ;; screwy enough to ask for FROM-END + ;; behavior on list data, turnabout is + ;; fair play.) + ;; + ;; It's also not enormously efficient, + ;; calling PREDICATE and KEY more often + ;; than necessary; but all the + ;; alternatives seem to have their own + ;; efficiency problems. + (if from-end + (setf find i + position index) + (return (values i index)))))) + (incf index)))))) + (def %find-position-if when) + (def %find-position-if-not unless)) ;;; %FIND-POSITION for LIST data can be expanded into %FIND-POSITION-IF ;;; without loss of efficiency. (I.e., the optimizer should be able diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp index eb540a8..86db8a5 100644 --- a/src/compiler/srctran.lisp +++ b/src/compiler/srctran.lisp @@ -1647,7 +1647,7 @@ ;;; Define optimizers for FLOOR and CEILING. (macrolet - ((frob-opt (name q-name r-name) + ((def (name q-name r-name) (let ((q-aux (symbolicate q-name "-AUX")) (r-aux (symbolicate r-name "-AUX"))) `(progn @@ -1711,54 +1711,52 @@ (when (and quot rem) (make-values-type :required (list quot rem)))))))))) - ;; FIXME: DEF-FROB-OPT, not just FROB-OPT - (frob-opt floor floor-quotient-bound floor-rem-bound) - (frob-opt ceiling ceiling-quotient-bound ceiling-rem-bound)) + (def floor floor-quotient-bound floor-rem-bound) + (def ceiling ceiling-quotient-bound ceiling-rem-bound)) ;;; Define optimizers for FFLOOR and FCEILING -(macrolet - ((frob-opt (name q-name r-name) - (let ((q-aux (symbolicate "F" q-name "-AUX")) - (r-aux (symbolicate r-name "-AUX"))) - `(progn - ;; Compute type of quotient (first) result. - (defun ,q-aux (number-type divisor-type) - (let* ((number-interval - (numeric-type->interval number-type)) - (divisor-interval - (numeric-type->interval divisor-type)) - (quot (,q-name (interval-div number-interval - divisor-interval))) - (res-type (numeric-contagion number-type divisor-type))) - (make-numeric-type - :class (numeric-type-class res-type) - :format (numeric-type-format res-type) - :low (interval-low quot) - :high (interval-high quot)))) - - (defoptimizer (,name derive-type) ((number divisor)) - (flet ((derive-q (n d same-arg) - (declare (ignore same-arg)) - (if (and (numeric-type-real-p n) - (numeric-type-real-p d)) - (,q-aux n d) - *empty-type*)) - (derive-r (n d same-arg) - (declare (ignore same-arg)) - (if (and (numeric-type-real-p n) - (numeric-type-real-p d)) - (,r-aux n d) - *empty-type*))) - (let ((quot (two-arg-derive-type - number divisor #'derive-q #',name)) - (rem (two-arg-derive-type - number divisor #'derive-r #'mod))) - (when (and quot rem) - (make-values-type :required (list quot rem)))))))))) - - ;; FIXME: DEF-FROB-OPT, not just FROB-OPT - (frob-opt ffloor floor-quotient-bound floor-rem-bound) - (frob-opt fceiling ceiling-quotient-bound ceiling-rem-bound)) +(macrolet ((def (name q-name r-name) + (let ((q-aux (symbolicate "F" q-name "-AUX")) + (r-aux (symbolicate r-name "-AUX"))) + `(progn + ;; Compute type of quotient (first) result. + (defun ,q-aux (number-type divisor-type) + (let* ((number-interval + (numeric-type->interval number-type)) + (divisor-interval + (numeric-type->interval divisor-type)) + (quot (,q-name (interval-div number-interval + divisor-interval))) + (res-type (numeric-contagion number-type + divisor-type))) + (make-numeric-type + :class (numeric-type-class res-type) + :format (numeric-type-format res-type) + :low (interval-low quot) + :high (interval-high quot)))) + + (defoptimizer (,name derive-type) ((number divisor)) + (flet ((derive-q (n d same-arg) + (declare (ignore same-arg)) + (if (and (numeric-type-real-p n) + (numeric-type-real-p d)) + (,q-aux n d) + *empty-type*)) + (derive-r (n d same-arg) + (declare (ignore same-arg)) + (if (and (numeric-type-real-p n) + (numeric-type-real-p d)) + (,r-aux n d) + *empty-type*))) + (let ((quot (two-arg-derive-type + number divisor #'derive-q #',name)) + (rem (two-arg-derive-type + number divisor #'derive-r #'mod))) + (when (and quot rem) + (make-values-type :required (list quot rem)))))))))) + + (def ffloor floor-quotient-bound floor-rem-bound) + (def fceiling ceiling-quotient-bound ceiling-rem-bound)) ;;; functions to compute the bounds on the quotient and remainder for ;;; the FLOOR function @@ -2665,18 +2663,18 @@ ;;; Flush calls to various arith functions that convert to the ;;; identity function or a constant. -(macrolet ((def-frob (name identity result) +(macrolet ((def (name identity result) `(deftransform ,name ((x y) (* (constant-arg (member ,identity))) * :when :both) "fold identity operations" ',result))) - (def-frob ash 0 x) - (def-frob logand -1 x) - (def-frob logand 0 0) - (def-frob logior 0 x) - (def-frob logior -1 -1) - (def-frob logxor -1 (lognot x)) - (def-frob logxor 0 x)) + (def ash 0 x) + (def logand -1 x) + (def logand 0 0) + (def logior 0 x) + (def logior -1 -1) + (def logxor -1 (lognot x)) + (def logxor 0 x)) ;;; These are restricted to rationals, because (- 0 0.0) is 0.0, not -0.0, and ;;; (* 0 -4.0) is -0.0. @@ -2750,7 +2748,7 @@ 'x) ;;; Fold (OP x +/-1) -(macrolet ((def-frob (name result minus-result) +(macrolet ((def (name result minus-result) `(deftransform ,name ((x y) (t (constant-arg real)) * :when :both) "fold identity operations" @@ -2759,9 +2757,9 @@ (not-more-contagious y x)) (give-up-ir1-transform)) (if (minusp val) ',minus-result ',result))))) - (def-frob * x (%negate x)) - (def-frob / x (%negate x)) - (def-frob expt x (/ 1 x))) + (def * x (%negate x)) + (def / x (%negate x)) + (def expt x (/ 1 x))) ;;; Fold (expt x n) into multiplications for small integral values of ;;; N; convert (expt x 1/2) to sqrt. @@ -2787,24 +2785,23 @@ ;;; transformations? ;;; Perhaps we should have to prove that the denominator is nonzero before ;;; doing them? -- WHN 19990917 -(macrolet ((def-frob (name) +(macrolet ((def (name) `(deftransform ,name ((x y) ((constant-arg (integer 0 0)) integer) * :when :both) "fold zero arg" 0))) - (def-frob ash) - (def-frob /)) + (def ash) + (def /)) -(macrolet ((def-frob (name) +(macrolet ((def (name) `(deftransform ,name ((x y) ((constant-arg (integer 0 0)) integer) * :when :both) "fold zero arg" '(values 0 0)))) - (def-frob truncate) - (def-frob round) - (def-frob floor) - (def-frob ceiling)) - + (def truncate) + (def round) + (def floor) + (def ceiling)) ;;;; character operations @@ -2862,11 +2859,11 @@ (t (give-up-ir1-transform)))) -(macrolet ((def-frob (x) +(macrolet ((def (x) `(%deftransform ',x '(function * *) #'simple-equality-transform))) - (def-frob eq) - (def-frob char=) - (def-frob equal)) + (def eq) + (def char=) + (def equal)) ;;; This is similar to SIMPLE-EQUALITY-PREDICATE, except that we also ;;; try to convert to a type-specific predicate or EQ: diff --git a/src/pcl/describe.lisp b/src/pcl/describe.lisp index 6efcba5..e04d40c 100644 --- a/src/pcl/describe.lisp +++ b/src/pcl/describe.lisp @@ -132,7 +132,7 @@ (pprint-logical-block (stream nil) (format stream "~&~S is a ~S." package (type-of package)) (format stream - "~@[~&It has nicknames ~{~:_~S~^ ~}~]" + "~@[~&It has nicknames ~2I~{~:_~S~^ ~}~]" (package-nicknames package)) (let* ((internal (package-internal-symbols package)) (internal-count (- (package-hashtable-size internal) @@ -143,9 +143,13 @@ (format stream "~&It has ~S internal and ~S external symbols." internal-count external-count)) - (format stream - "~@[~&It uses ~{~:_~S~^ ~}~]" - (package-use-list package)) - (format stream - "~@[~&It is used by ~{~:_~S~^ ~}~]" - (package-used-by-list package)))) + (flet (;; Turn a list of packages into something a human likes + ;; to read. + (humanize (package-list) + (sort (mapcar #'package-name package-list) #'string<))) + (format stream + "~@[~&It uses packages named ~2I~{~:_~S~^ ~}~]" + (humanize (package-use-list package))) + (format stream + "~@[~&It is used by packages named ~2I~{~:_~S~^ ~}~]" + (humanize (package-used-by-list package)))))) diff --git a/version.lisp-expr b/version.lisp-expr index 3c71cd7..03286dc 100644 --- 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".) -"0.pre7.140" +"0.pre7.141"