0.7.12.18:

[sbcl.git] / src / code / early-extensions.lisp

diff --git a/src/code/early-extensions.lisp b/src/code/early-extensions.lisp
index cb48d4e..5163fe1 100644 (file)
--- a/src/code/early-extensions.lisp
+++ b/src/code/early-extensions.lisp
@@ -40,11 +40,20 @@
 ;;; alpha platform. -- CSR, 2002-06-24
 (def!type unsigned-byte-with-a-bite-out (s bite)
   (cond ((eq s '*) 'integer)
-        ((and (integerp s) (> s 1))
+        ((and (integerp s) (> s 0))
          (let ((bound (ash 1 s)))
            `(integer 0 ,(- bound bite 1))))
         (t
-         (error "Bad size specified for SIGNED-BYTE type specifier: ~S." s))))
+         (error "Bad size specified for UNSIGNED-BYTE type specifier: ~S." s))))
+
+;;; Motivated by the mips port. -- CSR, 2002-08-22
+(def!type signed-byte-with-a-bite-out (s bite)
+  (cond ((eq s '*) 'integer)
+       ((and (integerp s) (> s 1))
+        (let ((bound (ash 1 (1- s))))
+          `(integer ,(- bound) ,(- bound bite 1))))
+       (t
+        (error "Bad size specified for SIGNED-BYTE type specifier: ~S." s))))
 
 (def!type load/store-index (scale lowtag min-offset
                                 &optional (max-offset min-offset))
@@ -551,6 +560,19 @@
                             ,@(values-names))
                            (values ,@(values-names)))
                          (values ,@(values-names))))))))))))
+
+(defmacro define-cached-synonym
+    (name &optional (original (symbolicate "%" name)))
+  (let ((cached-name (symbolicate "%%" name "-cached")))
+    `(progn
+       (defun-cached (,cached-name :hash-bits 8
+                                   :hash-function (lambda (x)
+                                                    (logand (sxhash x) #xff)))
+           ((args equal))
+         (apply #',original args))
+       (defun ,name (&rest args)
+         (,cached-name args)))))
+
 \f
 ;;;; package idioms
 
@@ -583,20 +605,35 @@
 (defun legal-fun-name-p (name)
   (or (symbolp name)
       (and (consp name)
-           (eq (car name) 'setf)
+           (or (eq (car name) 'setf)
+              (eq (car name) 'sb!pcl::class-predicate))
            (consp (cdr name))
            (symbolp (cadr name))
            (null (cddr name)))))
 
-;;; Given a function name, return the name for the BLOCK which
-;;; encloses its body (e.g. in DEFUN, DEFINE-COMPILER-MACRO, or FLET).
+;;; Signal an error unless NAME is a legal function name.
+(defun legal-fun-name-or-type-error (name)
+  (unless (legal-fun-name-p name)
+    (error 'simple-type-error
+          :datum name
+          :expected-type '(or symbol list)
+          :format-control "invalid function name: ~S"
+          :format-arguments (list name))))
+
+;;; Given a function name, return the symbol embedded in it.
+;;;
+;;; The ordinary use for this operator (and the motivation for the
+;;; name of this operator) is to convert from a function name to the
+;;; name of the BLOCK which encloses its body.
+;;;
+;;; Occasionally the operator is useful elsewhere, where the operator
+;;; name is less mnemonic. (Maybe it should be changed?)
 (declaim (ftype (function ((or symbol cons)) symbol) fun-name-block-name))
 (defun fun-name-block-name (fun-name)
   (cond ((symbolp fun-name)
         fun-name)
        ((and (consp fun-name)
-             (= (length fun-name) 2)
-             (eq (first fun-name) 'setf))
+             (legal-fun-name-p fun-name))
         (second fun-name))
        (t
         (error "not legal as a function name: ~S" fun-name))))
@@ -997,3 +1034,17 @@ which can be found at <http://sbcl.sourceforge.net/>.~:@>"
   (warn "using deprecated ~S~@[, should use ~S instead~]"
        bad-name
        good-name))
+
+;;; Anaphoric macros
+(defmacro awhen (test &body body)
+  `(let ((it ,test))
+     (when it ,@body)))
+
+(defmacro acond (&rest clauses)
+  (if (null clauses)
+      `()
+      (destructuring-bind ((test &body body) &rest rest) clauses
+        (once-only ((test test))
+          `(if ,test
+               (let ((it ,test)) (declare (ignorable it)),@body)
+               (acond ,@rest))))))