Changeset 38710 in project for release

Timestamp:

05/28/20 17:08:14 (2 months ago)

Author:

juergen

Message:

procedural-macros 3.0.1 with simplyfied code

Location:

release/5/procedural-macros

Files:

• tags/3.0.1 (copied) (copied from release/5/procedural-macros/trunk)
• tags/3.0.1/procedural-macros.egg (copied) (copied from release/5/procedural-macros/trunk/procedural-macros.egg) (1 diff)
• tags/3.0.1/procedural-macros.scm (copied) (copied from release/5/procedural-macros/trunk/procedural-macros.scm) (1 diff)
• tags/3.0.1/tests/run.scm (copied) (copied from release/5/procedural-macros/trunk/tests/run.scm)
• trunk/procedural-macros.egg (modified) (1 diff)
• trunk/procedural-macros.scm (modified) (1 diff)

release/5/procedural-macros/tags/3.0.1/procedural-macros.egg

@@ -5 +5 @@
  (dependencies bindings)
  (author "Juergen Lorenz")
- (version "3.0")
+ (version "3.0.1")
  (components
    (extension procedural-macros

release/5/procedural-macros/tags/3.0.1/procedural-macros.scm

@@ -416 +416 @@
 ;;; The code is more or less due to
 ;;; P. Seibel, Practical Common Lisp, p. 102
-(define-syntax once-only
-  (er-macro-transformer
-    (lambda (form rename compare?)
-      (let ((syms (cadr form))
-            (xpr (caddr form))
-            (xprs (cdddr form)))
-        (let ((%syms (map rename syms))
-              (%let (rename 'let))
-              (%list (rename 'list)))
-          `(,%let ,(map (lambda (g) `(,g ,(rename `',g))) %syms)
-             `(,',%let ,(,%list ,@(map (lambda (g n) ``(,,g ,,n))
-                                   %syms syms))
-                ,(,%let ,(map (lambda (n g) `(,n ,g))
-                            syms %syms)
-                   ,xpr ,@xprs))))))))
+(define-macro (once-only (x . xs) xpr . xprs)
+  (let ((syms (cons x xs)) (body (cons xpr xprs)))
+    (let ((gensyms (map (lambda (n) (gensym)) syms)))
+      `(let ,(map (lambda (g) `(,g ',(gensym))) gensyms)
+         `(let ,(list ,@(map (lambda (g n) ``(,,g ,,n))
+                             gensyms syms))
+            ,(let ,(map (lambda (n g) `(,n ,g))
+                        syms gensyms)
+               ,@body))))))
 
 ;;; (with-renamed-symbols (renamer . %syms) xpr . xprs)
 ;;; ---------------------------------------------------
-(define-syntax with-renamed-symbols
-  (er-macro-transformer
-    (lambda (form rename compare?)
-      (let ((syms (cadr form))
-            (xpr (caddr form))
-            (xprs (cdddr form))
-            )
-        (let ((renamer (car syms))
-              (%syms (cdr syms))
-              (%let (rename 'let))
-              )
-          `(,%let ,(map (lambda (s)
-                          ;`(,(symbol-append prefix s) (,renamer ',s)))
-                          `(,s (,renamer
-                            ',(string->symbol
-                               (substring (symbol->string s) 1)))))
-                        %syms)
-             ,xpr ,@xprs))))))
+(define-er-macro (with-renamed-symbols (renamer . syms) xpr . xprs)
+  %
+  `(,%let ,(map (lambda (s)
+                  `(,s (,renamer
+                    ',(string->symbol
+                       (substring (symbol->string s) 1)))))
+                syms)
+     ,xpr ,@xprs))
 
 ;;; (with-gensyms (name ....) xpr ....)
 ;;; -----------------------------------
 ;;; binds name ... to (gensym 'name) ... in body xpr ...
-(define-syntax with-gensyms
-  (ir-macro-transformer
-    (lambda (form inject compare?)
-      `(let ,(map (lambda (n) `(,n (gensym ',n))) (cadr form))
-         ,@(cddr form)))))
+(define-macro (with-gensyms (name . names) xpr . xprs)
+  (let ((names (cons name names)) (body (cons xpr xprs)))
+    `(let ,(map (lambda (n) `(,n (gensym ',n))) names)
+       ,@body)))
 
 ;;; (procedural-macros sym ..)

release/5/procedural-macros/trunk/procedural-macros.egg

@@ -5 +5 @@
  (dependencies bindings)
  (author "Juergen Lorenz")
- (version "3.0")
+ (version "3.0.1")
  (components
    (extension procedural-macros

release/5/procedural-macros/trunk/procedural-macros.scm

@@ -416 +416 @@
 ;;; The code is more or less due to
 ;;; P. Seibel, Practical Common Lisp, p. 102
-(define-syntax once-only
-  (er-macro-transformer
-    (lambda (form rename compare?)
-      (let ((syms (cadr form))
-            (xpr (caddr form))
-            (xprs (cdddr form)))
-        (let ((%syms (map rename syms))
-              (%let (rename 'let))
-              (%list (rename 'list)))
-          `(,%let ,(map (lambda (g) `(,g ,(rename `',g))) %syms)
-             `(,',%let ,(,%list ,@(map (lambda (g n) ``(,,g ,,n))
-                                   %syms syms))
-                ,(,%let ,(map (lambda (n g) `(,n ,g))
-                            syms %syms)
-                   ,xpr ,@xprs))))))))
+(define-macro (once-only (x . xs) xpr . xprs)
+  (let ((syms (cons x xs)) (body (cons xpr xprs)))
+    (let ((gensyms (map (lambda (n) (gensym)) syms)))
+      `(let ,(map (lambda (g) `(,g ',(gensym))) gensyms)
+         `(let ,(list ,@(map (lambda (g n) ``(,,g ,,n))
+                             gensyms syms))
+            ,(let ,(map (lambda (n g) `(,n ,g))
+                        syms gensyms)
+               ,@body))))))
 
 ;;; (with-renamed-symbols (renamer . %syms) xpr . xprs)
 ;;; ---------------------------------------------------
-(define-syntax with-renamed-symbols
-  (er-macro-transformer
-    (lambda (form rename compare?)
-      (let ((syms (cadr form))
-            (xpr (caddr form))
-            (xprs (cdddr form))
-            )
-        (let ((renamer (car syms))
-              (%syms (cdr syms))
-              (%let (rename 'let))
-              )
-          `(,%let ,(map (lambda (s)
-                          ;`(,(symbol-append prefix s) (,renamer ',s)))
-                          `(,s (,renamer
-                            ',(string->symbol
-                               (substring (symbol->string s) 1)))))
-                        %syms)
-             ,xpr ,@xprs))))))
+(define-er-macro (with-renamed-symbols (renamer . syms) xpr . xprs)
+  %
+  `(,%let ,(map (lambda (s)
+                  `(,s (,renamer
+                    ',(string->symbol
+                       (substring (symbol->string s) 1)))))
+                syms)
+     ,xpr ,@xprs))
 
 ;;; (with-gensyms (name ....) xpr ....)
 ;;; -----------------------------------
 ;;; binds name ... to (gensym 'name) ... in body xpr ...
-(define-syntax with-gensyms
-  (ir-macro-transformer
-    (lambda (form inject compare?)
-      `(let ,(map (lambda (n) `(,n (gensym ',n))) (cadr form))
-         ,@(cddr form)))))
+(define-macro (with-gensyms (name . names) xpr . xprs)
+  (let ((names (cons name names)) (body (cons xpr xprs)))
+    `(let ,(map (lambda (n) `(,n (gensym ',n))) names)
+       ,@body)))
 
 ;;; (procedural-macros sym ..)