X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fprimordial-extensions.lisp;h=4f259760e5190fe9a23a0e8c081e535c1038bf5e;hb=22b819c0cd0ca0ea5be52ba280b9e9e0b8e86210;hp=0f901a37d6ac1ac529d7a4f3669d523fa0599675;hpb=627c66211b93537e90c08b34b387edbd7e301011;p=sbcl.git

diff --git a/src/code/primordial-extensions.lisp b/src/code/primordial-extensions.lisp
index 0f901a3..4f25976 100644
--- a/src/code/primordial-extensions.lisp
+++ b/src/code/primordial-extensions.lisp
@@ -10,7 +10,7 @@
 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
 ;;;; files for more information.
 
-(in-package "SB!INT")
+(in-package "SB!IMPL")
 
 ;;;; target constants which need to appear as early as possible
 
@@ -35,20 +35,10 @@
 ;;; gencgc.c code on this value being a symbol. (This is only one of
 ;;; several nasty dependencies between that code and this, alas.)
 ;;; -- WHN 2001-08-17
-;;;
-;;; FIXME: We end up doing two DEFCONSTANT forms because (1) LispWorks
-;;; needs EVAL-WHEN wrapped around DEFCONSTANT, and (2) SBCL's
-;;; DEFCONSTANT expansion doesn't seem to behave properly inside
-;;; EVAL-WHEN, so that without this, the +EMPTY-HT-SLOT+ references in
-;;; e.g. DOHASH macroexpansions don't end up being replaced by
-;;; constant values, so that the system dies at cold init because
-;;; '+EMPTY-HT-SLOT+ isn't bound yet. It's hard to fix this properly
-;;; until SBCL's EVAL-WHEN is fixed, which is waiting for the IR1
-;;; interpreter to go away, which is waiting for sbcl-0.7.x..
 (eval-when (:compile-toplevel :load-toplevel :execute)
   (def!constant +empty-ht-slot+ '%empty-ht-slot%))
 ;;; We shouldn't need this mess now that EVAL-WHEN works.
-#+nil (defconstant +empty-ht-slot+ '#.+empty-ht-slot+) ; egads.. See FIXME above.
+
 ;;; KLUDGE: Using a private symbol still leaves us vulnerable to users
 ;;; getting nonconforming behavior by messing around with
 ;;; DO-ALL-SYMBOLS. That seems like a fairly obscure problem, so for
@@ -67,7 +57,7 @@
 
 ;;;; DO-related stuff which needs to be visible on the cross-compilation host
 
-(eval-when (:compile-toplevel :load-toplevel :execute)
+(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
   (defun frob-do-body (varlist endlist decls-and-code bind step name block)
     (let* ((r-inits nil) ; accumulator for reversed list
 	   (r-steps nil) ; accumulator for reversed list
@@ -131,6 +121,33 @@
 (defmacro do-anonymous (varlist endlist &rest body)
   (frob-do-body varlist endlist body 'let 'psetq 'do-anonymous (gensym)))
 
+;;;; GENSYM tricks
+
+;;; Automate an idiom often found in macros:
+;;;   (LET ((FOO (GENSYM "FOO"))
+;;;         (MAX-INDEX (GENSYM "MAX-INDEX-")))
+;;;     ...)
+;;;
+;;; "Good notation eliminates thought." -- Eric Siggia
+;;;
+;;; Incidentally, this is essentially the same operator which
+;;; _On Lisp_ calls WITH-GENSYMS.
+(defmacro with-unique-names (symbols &body body)
+  `(let ,(mapcar (lambda (symbol)
+		   (let* ((symbol-name (symbol-name symbol))
+			  (stem (if (every #'alpha-char-p symbol-name)
+				    symbol-name
+				    (concatenate 'string symbol-name "-"))))
+		     `(,symbol (gensym ,stem))))
+		 symbols)
+     ,@body))
+
+;;; Return a list of N gensyms. (This is a common suboperation in
+;;; macros and other code-manipulating code.)
+(declaim (ftype (function (index) list) make-gensym-list))
+(defun make-gensym-list (n)
+  (loop repeat n collect (gensym)))
+
 ;;;; miscellany
 
 ;;; Lots of code wants to get to the KEYWORD package or the
@@ -147,7 +164,7 @@
 
 ;;; Concatenate together the names of some strings and symbols,
 ;;; producing a symbol in the current package.
-(eval-when (:compile-toplevel :load-toplevel :execute)
+(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
   (defun symbolicate (&rest things)
     (let ((name (case (length things)
 		  ;; why isn't this just the value in the T branch?
@@ -272,6 +289,7 @@
      (%defconstant-eqx-value ',symbol ,expr ,eqx)
      ,@(when doc (list doc))))
 (defun %defconstant-eqx-value (symbol expr eqx)
+  (declare (type function eqx))
   (flet ((bummer (explanation)
 	   (error "~@<bad DEFCONSTANT-EQX ~S ~2I~_~S: ~2I~_~A ~S~:>"
 		  symbol
@@ -286,3 +304,24 @@
 	   (bummer "already bound as a different constant value"))
 	  (t
 	   (symbol-value symbol)))))
+
+;;; a helper function for various macros which expect clauses of a
+;;; given length, etc.
+;;;
+;;; Return true if X is a proper list whose length is between MIN and
+;;; MAX (inclusive).
+(defun proper-list-of-length-p (x min &optional (max min))
+  ;; FIXME: This implementation will hang on circular list
+  ;; structure. Since this is an error-checking utility, i.e. its
+  ;; job is to deal with screwed-up input, it'd be good style to fix
+  ;; it so that it can deal with circular list structure.
+  (cond ((minusp max) nil)
+	((null x) (zerop min))
+	((consp x)
+	 (and (plusp max)
+	      (proper-list-of-length-p (cdr x)
+				       (if (plusp (1- min))
+					   (1- min)
+					   0)
+				       (1- max))))
+	(t nil)))