picolisp

commit 7e169bf4f9af55bed8d0cbfb1b81ee17cfc329c1
parent eb83dc06a69e49e969d694f96bf450a718cc9ec9
Author: Alexander Burger <abu@software-lab.de>
Date:   Sat, 19 Jan 2013 09:26:19 +0100

E/R bug: Incorrect handling of +Idx in combination with +Aux and +Fold
Diffstat:
M
ersatz/picolisp.jar
 | 
0

M
lib/db.l
 | 
54
++++++++++++++++++------------------------------------
M
src/vers.h
 | 
2
+-
M
src64/version.l
 | 
4
++--

4 files changed, 21 insertions(+), 39 deletions(-)
diff --git a/ersatz/picolisp.jar b/ersatz/picolisp.jar
Binary files differ.
diff --git a/lib/db.l b/lib/db.l
@@ -1,4 +1,4 @@
-# 21oct12abu
+# 18jan13abu
 # (c) Software Lab. Alexander Burger
 
 # *Dbs *Jnl *Blob upd
@@ -557,40 +557,43 @@
 (dm rel> (Obj Old New Hook)
    (let
       (Tree (tree (: var) (: cls) (or Hook (get Obj (: hook))))
-         Aux (conc (mapcar '((S) (get Obj S)) (: aux)) Obj) )
+         Aux (conc (mapcar '((S) (get Obj S)) (: aux)) Obj)
+         Aux2 (conc (mapcar '((S) (get Obj S)) (: aux)) (cons Obj)) )
       (when Old
          (store Tree (cons Old Aux) NIL (: dbf))
          (for S (split (cdr (chop Old)) " " "^J")
             (while (nth S (: min))
-               (store Tree (list (pack S) Obj) NIL (: dbf))
+               (store Tree (cons (pack S) Aux2) NIL (: dbf))
                (pop 'S) ) ) )
       (when (and New (not (get Obj T)))
          (store Tree (cons New Aux) Obj (: dbf))
          (for S (split (cdr (chop New)) " " "^J")
             (while (nth S (: min))
-               (store Tree (list (pack S) Obj) Obj (: dbf))
+               (store Tree (cons (pack S) Aux2) Obj (: dbf))
                (pop 'S) ) ) ) )
    (extra Obj Old New Hook) )
 
 (dm lose> (Obj Val Hook)
    (let
       (Tree (tree (: var) (: cls) (or Hook (get Obj (: hook))))
-         Aux (conc (mapcar '((S) (get Obj S)) (: aux)) Obj) )
+         Aux (conc (mapcar '((S) (get Obj S)) (: aux)) Obj)
+         Aux2 (conc (mapcar '((S) (get Obj S)) (: aux)) (cons Obj)) )
       (store Tree (cons Val Aux) NIL (: dbf))
       (for S (split (cdr (chop Val)) " " "^J")
          (while (nth S (: min))
-            (store Tree (list (pack S) Obj) NIL (: dbf))
+            (store Tree (cons (pack S) Aux2) NIL (: dbf))
             (pop 'S) ) ) )
    (extra Obj Val Hook) )
 
 (dm keep> (Obj Val Hook)
    (let
       (Tree (tree (: var) (: cls) (or Hook (get Obj (: hook))))
-         Aux (conc (mapcar '((S) (get Obj S)) (: aux)) Obj) )
+         Aux (conc (mapcar '((S) (get Obj S)) (: aux)) Obj)
+         Aux2 (conc (mapcar '((S) (get Obj S)) (: aux)) (cons Obj)) )
       (store Tree (cons Val Aux) Obj (: dbf))
       (for S (split (cdr (chop Val)) " " "^J")
          (while (nth S (: min))
-            (store Tree (list (pack S) Obj) Obj (: dbf))
+            (store Tree (cons (pack S) Aux2) Obj (: dbf))
             (pop 'S) ) ) )
    (extra Obj Val Hook) )
 
@@ -652,34 +655,13 @@
    (extra Var (cdr Lst)) )
 
 (de relAux (Obj Var Old Lst)
-   (for A Lst
-      (let? Val (get Obj A)
-         (with (meta Obj A)
-            (let Tree (tree (: var) (: cls) (get Obj (: hook)))
-               (let Key
-                  (cons Val
-                     (mapcar
-                        '((S)
-                           (if (== S Var) Old (get Obj S)) )
-                        (: aux) ) )
-                  (store Tree
-                     (if (: ub)
-                        (ubZval Key Obj)
-                        (conc Key Obj) )
-                     NIL
-                     (: dbf) ) )
-               (let Key
-                  (cons Val
-                     (mapcar
-                        '((S)
-                           (if (== S Var) (get Obj Var) (get Obj S)) )
-                        (: aux) ) )
-                  (store Tree
-                     (if (: ub)
-                        (ubZval Key Obj)
-                        (conc Key Obj) )
-                     Obj
-                     (: dbf) ) ) ) ) ) ) )
+   (let New (get Obj Var)
+      (put Obj Var Old)
+      (for A Lst
+         (rel> (meta Obj A) Obj (get Obj A) NIL) )
+      (put Obj Var New)
+      (for A Lst
+         (rel> (meta Obj A) Obj NIL (get Obj A)) ) ) )
 
 
 # UB-Tree (+Aux prefix)
diff --git a/src/vers.h b/src/vers.h
@@ -1 +1 @@
-static byte Version[4] = {3,1,1,7};
+static byte Version[4] = {3,1,1,8};
diff --git a/src64/version.l b/src64/version.l
@@ -1,6 +1,6 @@
-# 12jan13abu
+# 19jan13abu
 # (c) Software Lab. Alexander Burger
 
-(de *Version 3 1 1 7)
+(de *Version 3 1 1 8)
 
 # vi:et:ts=3:sw=3