X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fprimordial-extensions.lisp;h=0f901a37d6ac1ac529d7a4f3669d523fa0599675;hb=6c4d4d984b1af6b2a73568cec3ab9c8795cff2da;hp=db95431dd5faa5d2418b3df6e182bd58c6325841;hpb=5384ab22e633886f56e981054bf83580765008ad;p=sbcl.git

diff --git a/src/code/primordial-extensions.lisp b/src/code/primordial-extensions.lisp
index db95431..0f901a3 100644
--- a/src/code/primordial-extensions.lisp
+++ b/src/code/primordial-extensions.lisp
@@ -46,7 +46,7 @@
 ;;; 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)
-  (defconstant +empty-ht-slot+ '%empty-ht-slot%))
+  (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
@@ -68,7 +68,7 @@
 ;;;; DO-related stuff which needs to be visible on the cross-compilation host
 
 (eval-when (:compile-toplevel :load-toplevel :execute)
-  (defun do-do-body (varlist endlist decls-and-code bind step name block)
+  (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
 	   (label-1 (gensym))
@@ -129,17 +129,43 @@
 ;;; EXIT-FORMS are evaluated as a PROGN, with the result being the
 ;;; value of the DO.
 (defmacro do-anonymous (varlist endlist &rest body)
-  (do-do-body varlist endlist body 'let 'psetq 'do-anonymous (gensym)))
+  (frob-do-body varlist endlist body 'let 'psetq 'do-anonymous (gensym)))
 
 ;;;; miscellany
 
+;;; Lots of code wants to get to the KEYWORD package or the
+;;; COMMON-LISP package without a lot of fuss, so we cache them in
+;;; variables. TO DO: How much does this actually buy us? It sounds
+;;; sensible, but I don't know for sure that it saves space or time..
+;;; -- WHN 19990521
+;;;
+;;; (The initialization forms here only matter on the cross-compilation
+;;; host; In the target SBCL, these variables are set in cold init.)
+(declaim (type package *cl-package* *keyword-package*))
+(defvar *cl-package*      (find-package "COMMON-LISP"))
+(defvar *keyword-package* (find-package "KEYWORD"))
+
 ;;; Concatenate together the names of some strings and symbols,
 ;;; producing a symbol in the current package.
 (eval-when (:compile-toplevel :load-toplevel :execute)
   (defun symbolicate (&rest things)
-    (values (intern (apply #'concatenate
-			   'string
-			   (mapcar #'string things))))))
+    (let ((name (case (length things)
+		  ;; why isn't this just the value in the T branch?
+		  ;; Well, this is called early in cold-init, before
+		  ;; the type system is set up; however, now that we
+		  ;; check for bad lengths, the type system is needed
+		  ;; for calls to CONCATENATE. So we need to make sure
+		  ;; that the calls are transformed away:
+		  (1 (concatenate 'string (the simple-string (string (car things)))))
+		  (2 (concatenate 'string 
+				  (the simple-string (string (car things)))
+				  (the simple-string (string (cadr things)))))
+		  (3 (concatenate 'string
+				  (the simple-string (string (car things)))
+				  (the simple-string (string (cadr things)))
+				  (the simple-string (string (caddr things)))))
+		  (t (apply #'concatenate 'string (mapcar #'string things))))))
+    (values (intern name)))))
 
 ;;; like SYMBOLICATE, but producing keywords
 (defun keywordicate (&rest things)
@@ -212,7 +238,7 @@
 	    (if (consp id)
 		(values (car id) (cdr id))
 		(values id nil))
-	  (push `(defconstant ,(symbolicate prefix root suffix)
+	  (push `(def!constant ,(symbolicate prefix root suffix)
 		   ,(+ start (* step index))
 		   ,@docs)
 		results)))
@@ -242,7 +268,7 @@
 ;;; need to avoid runtime indirection through a symbol, you might be
 ;;; able to do something with LOAD-TIME-VALUE or MAKE-LOAD-FORM.
 (defmacro defconstant-eqx (symbol expr eqx &optional doc)
-  `(defconstant ,symbol
+  `(def!constant ,symbol
      (%defconstant-eqx-value ',symbol ,expr ,eqx)
      ,@(when doc (list doc))))
 (defun %defconstant-eqx-value (symbol expr eqx)