From 4463445b017cd0099cbb0fa050d199a814505f72 Mon Sep 17 00:00:00 2001
From: Kaz Kylheku <kaz@kylheku.com>
Date: Sun, 30 Aug 2015 08:47:29 -0700
Subject: Introducing structs.

* args.c (args_cat_zap): New function.

* args.h: (args_cat_zap): Declared.

* eval.c (struct_lit_s): New symbol variable.
(eval_init): Initialize struct_lit_s.

* eval.h (struct_lit_s): Declared.

* gc.c (finalize): If a symbol has a struct slot
hash attached to it, we must free it when
the symbol is reclaimed.

* lib.c (make_sym): Initialize symbol's slot_cache pointer
to null.
(copy): Copy structure objects.
(init): Call struct_init to initialize struct module.

* lib.h (SLOT_CACHE_SIZE): New preprocessor symbol
(slot_cache_line_t, slot_cache_t): New typedefs.
(struct sym): New member, slot_cache.

* lisplib.c (struct_set_entries, struct_instantiate):  New
static functions.
(liplib_init): Register new functions in dl_table.

parser.y (HASH_S): New terminal symbol.
(struct): New grammar rule.
(n_expr): Derive struct.
(yybadtoken): Map HASH_S to #S string.

parser.l (grammar): Recognize #S and return HASH_S token.

share/txr/stdlib/place.tl (slot): New defplace.

share/txr/stdlib/struct.tl: New file.

struct.c: New file.

struct.h: New file.

* Makefile (OBJS): Adding struct.o.
---
 share/txr/stdlib/place.tl  | 11 +++++++++
 share/txr/stdlib/struct.tl | 57 ++++++++++++++++++++++++++++++++++++++++++++++
 2 files changed, 68 insertions(+)
 create mode 100644 share/txr/stdlib/struct.tl

(limited to 'share')

diff --git a/share/txr/stdlib/place.tl b/share/txr/stdlib/place.tl
index 270baace..256f8592 100644
--- a/share/txr/stdlib/place.tl
+++ b/share/txr/stdlib/place.tl
@@ -592,6 +592,17 @@
     ^(macrolet ((,deleter () ^(makunbound ,',sym-expr)))
        ,*body)))
 
+(defplace (slot struct sym) body
+  (getter setter
+    (with-gensyms (struct-sym)
+      ^(rlet ((,struct-sym ,struct))
+         (macrolet ((,getter () ^(slot ,',struct-sym ,',sym))
+                    (,setter (val) ^(slotset ,',struct-sym ,',sym ,val)))
+           ,body))))
+  (ssetter
+    ^(macrolet ((,ssetter (val) ^(slotset ,',struct ,',sym ,val)))
+      ,body)))
+
 (defmacro define-modify-macro (name lambda-list function)
   (let ((cleaned-lambda-list (mapcar [iffi consp car]
                                      (remql : lambda-list))))
diff --git a/share/txr/stdlib/struct.tl b/share/txr/stdlib/struct.tl
new file mode 100644
index 00000000..9030a90a
--- /dev/null
+++ b/share/txr/stdlib/struct.tl
@@ -0,0 +1,57 @@
+(defmacro defstruct (name-spec super . slot-specs)
+  (tree-bind (name args) (tree-case name-spec
+                           ((atom . args) (list atom args))
+                           (atom (list atom nil)))
+    (unless (bindable name)
+      (throwf 'eval-error "~s: ~s isn't a bindable symbol" 'defstruct name))
+    (unless (proper-listp slot-specs)
+      (throwf 'eval-error "~s: bad slot syntax" 'defstruct))
+    (let ((slot-init-forms (collect-each ((slot slot-specs))
+                             (tree-case slot
+                               ((sym init-form) slot)
+                               (sym (list sym nil))))))
+      (whenlet ((bad [find-if [notf bindable] slot-init-forms car]))
+        (throwf 'eval-error "~s: slot name ~s isn't a bindable symbol"
+                'defstruct (car bad)))
+      (let ((arg-sym (gensym)))
+        ^(make-struct-type ',name ',super ',[mapcar car slot-init-forms]
+           (lambda (,arg-sym)
+             ,*(mapcar (aret ^(slotset ,arg-sym ',@1 ,@2)) slot-init-forms))
+           ,(if args
+              (let ((gens (mapcar (ret (gensym)) args)))
+                ^(lambda (,arg-sym ,*gens)
+                   ,*(mapcar (ret ^(slotset ,arg-sym ',@1 ,@2))
+                             args gens)))))))))
+
+(defmacro sys:struct-lit (name . plist)
+  ^(make-struct ',name ',plist))
+
+(defmacro qref (:whole form obj . refs)
+  (when (null refs)
+    (throwf 'eval-error "~s: bad syntax" 'qref))
+  (tree-case refs
+    (() ())
+    (((dw sym . args))
+     (if (eq dw 'dwim) ^[(slot ,obj ',sym) ,*args] :))
+    (((dw sym . args) . more)
+     (if (eq dw 'dwim) ^(qref [(slot ,obj ',sym) ,*args] ,*more) :))
+    (((sym . args))
+     (let ((osym (gensym)))
+       ^(let ((,osym ,obj))
+          (call (slot ,osym ',sym) ,osym ,*args))))
+    (((sym . args) . more)
+     (let ((osym (gensym)))
+       ^(qref (let ((,osym ,obj))
+                (call (slot ,osym ',sym) ,osym ,*args)) ,*more)))
+    ((sym) ^(slot ,obj ',sym))
+    ((sym . more) ^(qref (slot ,obj ',sym) ,*more))
+    (obj (throwf 'eval-error "~s: bad syntax: ~s" 'qref refs))))
+
+(defmacro new (spec . pairs)
+  (let ((qpairs (mappend (aret ^(',@1 ,@2)) (tuples 2 pairs))))
+    (tree-case spec
+      ((atom . args) ^(make-struct ',atom (list ,*qpairs) ,*args))
+      (atom ^(make-struct ',atom (list ,*qpairs))))))
+
+(defmacro meth (obj slot)
+  ^(method ,obj ',slot))
-- 
cgit v1.2.3