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
;;; 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))
;;; 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
;; 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")
;;; 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
(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
(: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)
(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))
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))
(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)))
(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))
(+ 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."))
\f
;;;; comparisons
(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
\f
;;;; 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?"))
(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))
;;; 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
;;;; 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
(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)
\f
;;;; 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))
(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*))
(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) *)
(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))
;;; 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
(frob (simple-array (unsigned-byte 2) (*)) 2)
(frob (simple-array (unsigned-byte 4) (*)) 4))
\f
-;;;; 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
(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)
\f
;;;; 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))
(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*))
\f
;;; Convert the code in a component into VOPs.
(defun ir2-convert (component)
;;; 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*))
\f
;;;; 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> >))
\f
;;;; transforms for optimizing SAP+
'(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))
(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))
,(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
(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"
;;; 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))
(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))
\f
;;;; string-only transforms for sequence functions
"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
;;; 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
(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
;;; 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.
'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"
(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.
;;; 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))
\f
;;;; character operations
(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:
(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)
(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))))))
;;; 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"
projects / sbcl.git / commitdiff