From 63d18cb2cb30c20c9bbf00501b253bbc1cee5011 Mon Sep 17 00:00:00 2001
From: Kaz Kylheku <kaz@kylheku.com>
Date: Wed, 15 May 2019 06:35:29 -0700
Subject: oop: new new* and lnew* macros.

* lisplib.c (struct_set_entries): Add autoload entries for
new* and lnew* symbols.

* share/txr/stdlib/struct.tl (sys:new-type, sys:new-expander):
New functions.
(new, lnew): Macros now implemented using sys:new-expander.
(new*, lnew*): New macros.

* txr.1: Documented.
---
 share/txr/stdlib/struct.tl | 62 +++++++++++++++++++++++++++-------------------
 1 file changed, 36 insertions(+), 26 deletions(-)

(limited to 'share')

diff --git a/share/txr/stdlib/struct.tl b/share/txr/stdlib/struct.tl
index 5aa61d74..424748e7 100644
--- a/share/txr/stdlib/struct.tl
+++ b/share/txr/stdlib/struct.tl
@@ -244,36 +244,46 @@
     (t (with-gensyms (ovar)
          ^(lambda (,ovar) (qref ,ovar ,*args))))))
 
-(defmacro new (:form form spec . pairs)
-  (if (oddp (length pairs))
-    (throwf 'eval-error "~s: slot initform arguments must occur pairwise"
-            'new))
+(defun sys:new-type (op form type)
+  (caseq op
+    ((new lnew) (sys:check-struct form type) ^',type)
+    (t type)))
+
+(defun sys:new-expander (op form spec pairs)
+  (when (oddp (length pairs))
+    (compile-error form
+                   "~s: slot initform arguments must occur pairwise" op))
   (let ((qpairs (mappend (aret ^(',@1 ,@2)) (tuples 2 pairs))))
     (tree-case spec
-      ((atom . args)
-        (sys:check-struct form atom)
-        (if qpairs
-          ^(make-struct ',atom (list ,*qpairs) ,*args)
-          ^(struct-from-args ',atom ,*args)))
-      (atom
-        (sys:check-struct form atom)
-        ^(struct-from-plist ',atom ,*qpairs)))))
+      ((texpr . args)
+       (let ((type (sys:new-type op form texpr)))
+         (caseq op
+           ((new new*) (if qpairs
+                         ^(make-struct ,type (list ,*qpairs) ,*args)
+                         ^(struct-from-args ,type ,*args)))
+           ((new* lnew*) ^(make-lazy-struct ,type
+                                            (lambda ()
+                                              (cons (list ,*qpairs)
+                                                    (list ,*args))))))))
+      (texpr
+        (let ((type (sys:new-type op form texpr)))
+          (caseq op
+            ((new new*) ^(struct-from-plist ,type ,*qpairs))
+            ((lnew lnew*) ^(make-lazy-struct type
+                                             (lambda ()
+                                               (list (list ,*qpairs)))))))))))
+
+(defmacro new (:form form spec . pairs)
+  (sys:new-expander (car form) form spec pairs))
+
+(defmacro new* (:form form spec . pairs)
+  (sys:new-expander (car form) form spec pairs))
 
 (defmacro lnew (:form form spec . pairs)
-  (if (oddp (length pairs))
-    (throwf 'eval-error "~s: slot initform arguments must occur pairwise"
-            'lnew))
-  (let ((qpairs (mappend (aret ^(',@1 ,@2)) (tuples 2 pairs))))
-    (tree-case spec
-      ((atom . args)
-        (sys:check-struct form atom)
-        ^(make-lazy-struct ',atom
-                           (lambda ()
-                             (cons (list ,*qpairs)
-                                   (list ,*args)))))
-      (atom
-        (sys:check-struct form atom)
-        ^(make-lazy-struct ',atom (lambda () (list (list ,*qpairs))))))))
+  (sys:new-expander (car form) form spec pairs))
+
+(defmacro lnew* (:form form spec . pairs)
+  (sys:new-expander (car form) form spec pairs))
 
 (defmacro meth (obj slot . bound-args)
   ^[(fun method) ,obj ',slot ,*bound-args])
-- 
cgit v1.2.3