Many improvements

4 files changed, 38 insertions, 48 deletions

diff --git a/scheme/aps/list-utils.sls b/scheme/aps/list-utils.sls
index 1652661..0398992 100644
--- a/scheme/aps/list-utils.sls
+++ b/scheme/aps/list-utils.sls
@@ -97,7 +97,7 @@
       (let+ (first . rest) items
         (cond
          ((null? rest) #t); single item
-         ((exists (lambda (el) (eq? el first)) rest) #f); duplicate
+         ((exists (cut eq? first <>) rest) #f); duplicate
          (else (distinct? eq? rest)); look at the sublist
          ))))
 ;;END
diff --git a/scheme/aps/struct.sls b/scheme/aps/struct.sls
new file mode 100644
index 0000000..d86e5a9
--- /dev/null
+++ b/scheme/aps/struct.sls
@@ -0,0 +1,32 @@
+(library (aps struct)
+(export struct base struct->alist)
+(import (rnrs) (sweet-macros) (aps list-utils))
+
+;;STRUCT
+(def-syntax (struct base (name value) ...)
+  (begin
+    (assert (for-all identifier? #'(name ...)))
+    (assert (distinct? eq? #'(name ...)))
+    #'(letrec ((->names (append-unique eq? '(name ...) (base '->names)))
+               (name value) ...)
+        (lambda (n)
+          (case n
+            ((name) name) ...
+            ((->names) ->names)
+            ((->base) base)
+            (else (base n)))))))
+;;END
+
+;;BASE-STRUCT
+(define (base n)
+  (case n
+    ((->names) '())
+    ((->base) #f)
+    (else (error 'struct "Unknown name" n))))
+;;END
+
+;;STRUCT->ALIST
+(define (struct->alist s)
+  (map (lambda (k) (list k (s k))) (s '->names)))
+;;END
+)
diff --git a/scheme/struct.sls b/scheme/struct.sls
deleted file mode 100644
index 217d2e8..0000000
--- a/scheme/struct.sls
+++ /dev/null
@@ -1,42 +0,0 @@
-(library (struct)
-(export struct base-struct struct->alist struct-get)
-(import (rnrs) (sweet-macros))
-
-;; ex: (remove-dupl '(1 2 3 1 5 2 4))
-(define (remove-dupl eq? lst)
-  (reverse
-   (fold-left
-    (lambda (acc el)
-      (define (is-el? x) (eq? x el))
-      (if (find is-el? acc); duplicate
-          acc
-          (cons el acc))) '() lst)))
-
-(define (append-unique eq? . lists)
-  (remove-dupl eq? (apply append lists)))
-
-(define (base-struct k)
-  (case k
-    ((->keys) '())
-    (else (error 'struct-key-error "Missing key" k))))
-
-(def-syntax struct
-  (syntax-match ()
-    (sub (struct (name value) ...)
-         #'(struct base-struct (name value) ...))
-    (sub (struct parent (name value) ...)
-         #'(lambda (k)
-             (case k
-               ((->keys) (append-unique eq? '(name ...) (parent '->keys)))
-               ((name) value) ...
-               (else (parent k))))
-         (for-all identifier? #'(name ...)))
-    ))
-             
-(define (struct->alist s)
-  (map (lambda (k) (list k (s k))) (s '->keys)))
-
-(def-syntax (struct-get s name default)
-  #'(let ((value (s 'name)))
-      (if (eq? value struct-null) default value)))
-)
diff --git a/scheme/sweet-macros.sls b/scheme/sweet-macros.sls
index 80dd258..1967cf2 100644
--- a/scheme/sweet-macros.sls
+++ b/scheme/sweet-macros.sls
@@ -45,8 +45,8 @@
         ))))
 
 (define-syntax syntax-match
-  (guarded-syntax-case () (:> sub)
-    ((self (:> (let-form name value) ...) (literal ...)
+  (guarded-syntax-case () (sub local)
+    ((self (local (let-form name value) ...) (literal ...)
            (sub patt skel . rest) ...)
      #'(block (let-form name value) ...
          (guarded-syntax-case ()
@@ -56,10 +56,10 @@
            ((ctx <patterns>)
             #''((... (... patt)) ...))
            ((ctx <source>)
-            #''(self (:> (let-form name value) ...) (literal ...)
+            #''(self (local (let-form name value) ...) (literal ...)
                      (... (... (sub patt skel . rest))) ...))
            ((ctx <transformer>)
-            #'(self (:> (let-form name value) ...) (literal ...)
+            #'(self (local (let-form name value) ...) (literal ...)
                     (... (... (sub patt skel . rest))) ...))
            (patt skel . rest) ...))
      (for-all identifier? #'(literal ...))
@@ -67,7 +67,7 @@
                        (remp identifier? #'(literal ...))))
     
     ((self (literal ...) (sub patt skel . rest) ...)
-     #'(self (:>)(literal ...) (sub patt skel . rest) ...))
+     #'(self (local)(literal ...) (sub patt skel . rest) ...))
 
     ((self x (literal ...) (sub patt skel . rest) ...)
      #'(guarded-syntax-case x (literal ...) (patt skel . rest) ...))