X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fprimordial-extensions.lisp;h=d09a8b22294dcad516a1bd6e010b471c6f31955f;hb=35697e2c02e7b29f7953ae318d50305561927a16;hp=83a3e49927c18cb2345059cc3e0a372291a4379c;hpb=b0642df835dc2fca3e4cf47aff978ecdc88799d5;p=sbcl.git

diff --git a/src/code/primordial-extensions.lisp b/src/code/primordial-extensions.lisp
index 83a3e49..d09a8b2 100644
--- a/src/code/primordial-extensions.lisp
+++ b/src/code/primordial-extensions.lisp
@@ -57,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
@@ -98,18 +98,19 @@
 			 (t (illegal-varlist)))))
 		(t (illegal-varlist)))))
       ;; Construct the new form.
-      (multiple-value-bind (code decls) (parse-body decls-and-code nil)
+      (multiple-value-bind (code decls)
+	  (parse-body decls-and-code :doc-string-allowed nil)
 	`(block ,block
 	   (,bind ,(nreverse r-inits)
 		  ,@decls
 		  (tagbody
-		   (go ,label-2)
-		   ,label-1
-		   ,@code
-		   (,step ,@(nreverse r-steps))
-		   ,label-2
-		   (unless ,(first endlist) (go ,label-1))
-		   (return-from ,block (progn ,@(rest endlist))))))))))
+                     (go ,label-2)
+                     ,label-1
+                     (tagbody ,@code)
+                     (,step ,@(nreverse r-steps))
+                     ,label-2
+                     (unless ,(first endlist) (go ,label-1))
+                     (return-from ,block (progn ,@(rest endlist))))))))))
 
 ;;; This is like DO, except it has no implicit NIL block. Each VAR is
 ;;; initialized in parallel to the value of the specified INIT form.
@@ -121,6 +122,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
@@ -137,25 +165,17 @@
 
 ;;; 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?
-		  ;; 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)))))
+    (let* ((length (reduce #'+ things
+                           :key (lambda (x) (length (string x)))))
+           (name (make-array length :element-type 'character)))
+      (let ((index 0))
+        (dolist (thing things (values (intern name)))
+          (let* ((x (string thing))
+                 (len (length x)))
+            (replace name x :start1 index)
+            (incf index len)))))))
 
 ;;; like SYMBOLICATE, but producing keywords
 (defun keywordicate (&rest things)
@@ -298,3 +318,19 @@
 					   0)
 				       (1- max))))
 	(t nil)))
+
+;;; Helpers for defining error-signalling NOP's for "not supported 
+;;; here" operations.
+(defmacro define-unsupported-fun (name &optional 
+                                  (doc "Unsupported on this platform.")
+                                  (control 
+                                   "~S is unsupported on this platform ~
+                                    (OS, CPU, whatever)."
+                                   controlp)
+                                  arguments)
+  `(defun ,name (&rest args)
+    ,doc
+    (declare (ignore args))
+    (error 'unsupported-operator 
+     :format-control ,control
+     :format-arguments (if ,controlp ',arguments (list ',name)))))