Internal change

macro-test.lisp

@@ -63,6 +63,7 @@
   (expect (equal '(1 1 1 1) (lconc (i (list 1 2 3 4)) (j '(0 1 2 3))
                                    (list (- i j))))))
 
+
 (deftest with-gensyms-test ()
   (expect (gensymp (with-gensyms (s) s)))
   (expect (gensymp (with-gensyms ((s "FOO")) s)))
@@ -74,6 +75,17 @@
   (expect (macroexpand '(with-gensyms (s) s)))
   (expect (macroexpand '(with-gensyms ((s "FOO")) s))))
 
+(deftest with-syms-test ()
+  (expect (gensymp (with-syms (s) s)))
+  (expect (gensymp (with-syms ((s "FOO")) s)))
+  (let* ((foo :foo)
+         (sym (with-syms ((s foo)) s)))
+    (expect (string-equal :foo sym))
+    (expect (gensymp (with-syms ((s foo)) s))))
+
+  (expect (macroexpand '(with-syms (s) s)))
+  (expect (macroexpand '(with-syms ((s "FOO")) s))))
+
 (defun! compile-time-function (&optional (result "compile-time"))
   (declare (string result))
   result)

macro.lisp

@@ -54,6 +54,9 @@
    #:gensymp
    #:with-gensyms
 
+   #:sym*
+   #:with-syms
+
    #:lexenv
    #:remove-declarations
    #:remove-type-declarations
@@ -492,6 +495,38 @@ E.g.:
     `(let ,(lmap ((s name) symbols) `(,s (gensym* ,name)))
        ,@body)))
 
+
+(declaim (ftype (function (&rest t) (values symbol &optional)) gensym*)
+         (inline sym*))
+(defun sym* (&rest rest)
+  "Return a free symbol that is not interned into any package.
+ The symbol's name is based on the string designators in the REST argument."
+  (declare (dynamic-extent rest))
+  (cond ((null (car rest))
+         (make-symbol ""))
+        ((cdr rest)
+         (make-symbol (apply #'concatenate 'string (mapcar #'genstr* rest))))
+        (t
+         (make-symbol (genstr* (car rest))))))
+(define-compiler-macro sym* (&rest rest)
+  (if rest
+      `(make-symbol (concatenate 'string ,@(lmap (r rest) `(genstr* ,r))))
+      `(make-symbol "")))
+
+(defmacro with-syms ((&rest symbols) &body body)
+  "SYMBOLS are bound to uninterned symbols around the BODY forms.
+Each of the SYMBOL specifiers can also have the form (SYMBOL NAME)
+where NAME is evaluated at runtime and used as the symbol name.
+
+E.g.:
+ (with-syms ((s :FOO) t u v)
+   `(let ((,s ...))
+      ...))
+"
+  (let ((symbols (lmap (s symbols) (if (consp s) s `(,s ',s)))))
+    `(let ,(lmap ((s name) symbols) `(,s (sym* ,name)))
+       ,@body)))
+
 ;;;
 ;;; Declarations.
 ;;;