1.1.13: will be tagged as "sbcl-1.1.13"

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

diff --git a/src/code/primordial-extensions.lisp b/src/code/primordial-extensions.lisp
index f9293be..e91d56d 100644 (file)
--- a/src/code/primordial-extensions.lisp
+++ b/src/code/primordial-extensions.lisp
@@ -124,6 +124,21 @@
 \f
 ;;;; GENSYM tricks
 
+;;; Compile a version of BODY for all TYPES, and dispatch to the
+;;; correct one based on the value of VAR. This was originally used
+;;; only for strings, hence the name. Renaming it to something more
+;;; generic might not be a bad idea.
+(defmacro string-dispatch ((&rest types) var &body body)
+  (let ((fun (sb!xc:gensym "STRING-DISPATCH-FUN")))
+    `(flet ((,fun (,var)
+              ,@body))
+       (declare (inline ,fun))
+       (etypecase ,var
+         ,@(loop for type in types
+                 ;; TRULY-THE allows transforms to take advantage of the type
+                 ;; information without need for constraint propagation.
+                 collect `(,type (,fun (truly-the ,type ,var))))))))
+
 ;;; Automate an idiom often found in macros:
 ;;;   (LET ((FOO (GENSYM "FOO"))
 ;;;         (MAX-INDEX (GENSYM "MAX-INDEX-")))
@@ -139,15 +154,20 @@
                           (stem (if (every #'alpha-char-p symbol-name)
                                     symbol-name
                                     (concatenate 'string symbol-name "-"))))
-                     `(,symbol (gensym ,stem))))
+                     `(,symbol (sb!xc: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)))
+(declaim (ftype (function (index &optional t) (values list &optional))
+                make-gensym-list))
+(defun make-gensym-list (n &optional name)
+  (when (eq t name)
+    (break))
+  (if name
+      (loop repeat n collect (sb!xc:gensym (string name)))
+      (loop repeat n collect (sb!xc:gensym))))
 \f
 ;;;; miscellany
 
@@ -177,6 +197,11 @@
             (replace name x :start1 index)
             (incf index len)))))))
 
+(defun gensymify (x)
+  (if (symbolp x)
+      (sb!xc:gensym (symbol-name x))
+      (sb!xc:gensym)))
+
 ;;; like SYMBOLICATE, but producing keywords
 (defun keywordicate (&rest things)
   (let ((*package* *keyword-package*))
@@ -197,7 +222,8 @@
                 ;; but it will immediately lead to undefined to behavior,
                 ;; since almost any operation on a deleted package is
                 ;; undefined.
-                (package-name maybe-package))
+                #-sb-xc-host
+                (package-%name maybe-package))
            maybe-package)
           (t
            ;; We're in the undefined behavior zone. First, munge the
@@ -236,7 +262,7 @@
     dfd))
 
 ;;; Give names to elements of a numeric sequence.
-(defmacro defenum ((&key (prefix "") (suffix "") (start 0) (step 1))
+(defmacro defenum ((&key (start 0) (step 1))
                    &rest identifiers)
   (let ((results nil)
         (index 0)
@@ -244,11 +270,11 @@
         (step (eval step)))
     (dolist (id identifiers)
       (when id
-        (multiple-value-bind (root docs)
+        (multiple-value-bind (sym docs)
             (if (consp id)
                 (values (car id) (cdr id))
                 (values id nil))
-          (push `(def!constant ,(symbolicate prefix root suffix)
+          (push `(def!constant ,sym
                    ,(+ start (* step index))
                    ,@docs)
                 results)))
@@ -319,6 +345,21 @@
                                        (1- max))))
         (t nil)))
 
+(defun proper-list-p (x)
+  (unless (consp x)
+    (return-from proper-list-p (null x)))
+  (let ((rabbit (cdr x))
+        (turtle x))
+    (flet ((pop-rabbit ()
+             (when (eql rabbit turtle) ; circular
+               (return-from proper-list-p nil))
+             (when (atom rabbit)
+               (return-from proper-list-p (null rabbit)))
+             (pop rabbit)))
+      (loop (pop-rabbit)
+            (pop-rabbit)
+            (pop turtle)))))
+
 ;;; Helpers for defining error-signalling NOP's for "not supported
 ;;; here" operations.
 (defmacro define-unsupported-fun (name &optional