X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fearly-extensions.lisp;h=323982d5ed5b9b9b201ca8690f6eb3f941a451fb;hb=2217cdb364e8b48c187b085895bb2a5cbdbd9622;hp=0f6fba90991fef888cf77c3941955962c7de0b28;hpb=8731c1a7c1a585d190151fa881050fb5e14c0616;p=sbcl.git

diff --git a/src/code/early-extensions.lisp b/src/code/early-extensions.lisp
index 0f6fba9..323982d 100644
--- a/src/code/early-extensions.lisp
+++ b/src/code/early-extensions.lisp
@@ -36,6 +36,35 @@
 ;;; index leaving the loop range)
 (def!type index-or-minus-1 () `(integer -1 (,sb!xc:array-dimension-limit)))
 
+;;; A couple of VM-related types that are currently used only on the
+;;; alpha platform. -- CSR, 2002-06-24
+(def!type unsigned-byte-with-a-bite-out (s bite)
+  (cond ((eq s '*) 'integer)
+        ((and (integerp s) (> s 0))
+         (let ((bound (ash 1 s)))
+           `(integer 0 ,(- bound bite 1))))
+        (t
+         (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))
+  `(integer ,(- (truncate (+ (ash 1 16)
+			     (* min-offset sb!vm:n-word-bytes)
+			     (- lowtag))
+			  scale))
+	    ,(truncate (- (+ (1- (ash 1 16)) lowtag)
+			  (* max-offset sb!vm:n-word-bytes))
+		       scale)))
+
 ;;; the default value used for initializing character data. The ANSI
 ;;; spec says this is arbitrary, so we use the value that falls
 ;;; through when we just let the low-level consing code initialize
@@ -531,6 +560,40 @@
 			     ,@(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)))))
+
+;;; FIXME: maybe not the best place
+;;;
+;;; FIXME: think of a better name -- not only does this not have the
+;;; CAR recursion of EQUAL, it also doesn't have the special treatment
+;;; of pathnames, bit-vectors and strings.
+;;;
+;;; KLUDGE: This means that we will no longer cache specifiers of the
+;;; form '(INTEGER (0) 4).  This is probably not a disaster.
+;;;
+;;; A helper function for the type system, which is the main user of
+;;; these caches: we must be more conservative than EQUAL for some of
+;;; our equality tests, because MEMBER and friends refer to EQLity.
+;;; So:
+(defun equal-but-no-car-recursion (x y)
+  (cond
+    ((eql x y) t)
+    ((consp x)
+     (and (consp y)
+	  (eql (car x) (car y))
+	  (equal-but-no-car-recursion (cdr x) (cdr y))))
+    (t nil)))
 
 ;;;; package idioms
 
@@ -563,21 +626,51 @@
 (defun legal-fun-name-p (name)
   (or (symbolp name)
       (and (consp name)
-           (eq (car name) 'setf)
-           (consp (cdr name))
-           (symbolp (cadr name))
-           (null (cddr name)))))
+	   ;; (SETF FOO)
+	   ;; (CLASS-PREDICATE FOO)
+           (or (and (or (eq (car name) 'setf)
+			(eq (car name) 'sb!pcl::class-predicate))
+		    (consp (cdr name))
+		    (symbolp (cadr name))
+		    (null (cddr name)))
+	       ;; (SLOT-ACCESSOR <CLASSNAME-OR-:GLOBAL>
+	       ;;  <SLOT-NAME> [READER|WRITER|BOUNDP])
+	       (and (eq (car name) 'sb!pcl::slot-accessor)
+		    (consp (cdr name))
+		    (symbolp (cadr name))
+		    (consp (cddr name))
+		    (symbolp (caddr name))
+		    (consp (cdddr name))
+		    (member
+		     (cadddr name)
+		     '(sb!pcl::reader sb!pcl::writer sb!pcl::boundp)))))))
 
-;;; 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))
-	 (second fun-name))
+	      (legal-fun-name-p fun-name))
+	 (case (car fun-name)
+	   ((setf sb!pcl::class-predicate) (second fun-name))
+	   ((sb!pcl::slot-accessor) (third fun-name))))
 	(t
 	 (error "not legal as a function name: ~S" fun-name))))
 
@@ -977,3 +1070,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))))))