commit 1a486ace2896ec0a22da53dd1e61bdb7b6820555
parent bb91c7bce9646ff3a46db39023fceffeee771b66
Author: Alexander Burger <abu@software-lab.de>
Date: Fri, 19 Jul 2013 14:09:51 +0200
Pilog Lisp call syntax with '^'
Diffstat:
22 files changed, 307 insertions(+), 261 deletions(-)
diff --git a/CHANGES b/CHANGES
@@ -1,4 +1,5 @@
* DDsep13 picoLisp-3.1.4
+ Pilog Lisp call syntax with '^'
'read' preserves trailing white space
* 29jun13 picoLisp-3.1.3
diff --git a/doc/family.l b/doc/family.l
@@ -1,4 +1,4 @@
-# 11nov12abu
+# 19jul13abu
# (c) Software Lab. Alexander Burger
(load "@lib/http.l" "@lib/xhtml.l" "@lib/form.l" "@lib/ps.l")
@@ -152,8 +152,8 @@
@Fin (or (: home obj fin) (+ (: home obj dat) 36525))
(db dat +Person (@Beg . @Fin) @@)
(different @@ @Obj)
- (@ >= (get (-> @@) 'fin) (-> @Dat))
- (@ <= (get (-> @@) 'dat) (-> @Fin)) ) )
+ (^ @ (>= (get (-> @@) 'fin) (-> @Dat)))
+ (^ @ (<= (get (-> @@) 'dat) (-> @Fin))) ) )
7
'((This)
(list This (: job) (: dat) (: fin) (: pa) (: ma) (: mate)) ) )
diff --git a/doc/family.tgz b/doc/family.tgz
Binary files differ.
diff --git a/doc/family64.tgz b/doc/family64.tgz
Binary files differ.
diff --git a/doc/refM.html b/doc/refM.html
@@ -605,7 +605,7 @@ leaf ((Tree) (let (Node (cdr (root Tree)) X) (while (val Node) (setq X (cadr @)
*Dbg ((173 . "lib/btree.l"))
nil 67284680
- T (((@X) (@ not (-> @X))))
+ T (((@X) (^ @ (not (-> @X)))))
. # Stop
-> T
diff --git a/doc/refR.html b/doc/refR.html
@@ -504,9 +504,9 @@ backtracking. See also <code><a href="refR.html#repeat">repeat</a></code> and
<pre><code>
: (be integer (@I) # Generate unlimited supply of integers
- (@C box 0) # Init to zero
+ (^ @C (box 0)) # Init to zero
(repeat) # Repeat from here
- (@I inc (-> @C)) )
+ (^ @I (inc (-> @C))) )
-> integer
: (? (integer @X))
diff --git a/doc/refT.html b/doc/refT.html
@@ -68,7 +68,7 @@ and <a href="ref.html#cmp">Comparing</a>.
: (= 123 123)
-> T
: (get 'not T)
--> ((@P (1 -> @P) T (fail)) (@P))
+-> ((@P (1 (-> @P)) T (fail)) (@P))
</code></pre>
<dt><a name="This"><code>This</code></a>
diff --git a/doc/refU.html b/doc/refU.html
@@ -186,7 +186,7 @@ returns the new environment or <code>NIL</code> if not successful. See also
href="ref_.html#->">-></a></code>.
<pre><code>
-: (? (@A unify '(@B @C)))
+: (? (^ @A (unify '(@B @C))))
@A=(((NIL . @C) 0 . @C) ((NIL . @B) 0 . @B) T)
</code></pre>
diff --git a/doc/ref_.html b/doc/ref_.html
@@ -213,7 +213,7 @@ href="refP.html#prove">prove</a></code> and <code><a
href="refU.html#unify">unify</a></code>.
<pre><code>
-: (? (append (1 2 3) (4 5 6) @X) (@ println 'X '= (-> @X)))
+: (? (append (1 2 3) (4 5 6) @X) (^ @ (println 'X '= (-> @X))))
X = (1 2 3 4 5 6)
@X=(1 2 3 4 5 6)
-> NIL
diff --git a/ersatz/fun.src b/ersatz/fun.src
@@ -1,4 +1,4 @@
-# 17jul13abu
+# 19jul13abu
# (c) Software Lab. Alexander Burger
# Ersatz PicoLisp Functions
@@ -2999,15 +2999,15 @@ prove (i x y)
tp1 = x.Cdr;
}
else if (x.Car.Car instanceof Number) {
- e = x.Car.Cdr.eval();
+ e = x.Car.Cdr.prog();
for (i = ((Number)x.Car.Car).Cnt, x = Pnl; --i > 0;)
x = x.Cdr;
Pnl = new Cell(x.Car, Pnl);
tp2 = new Cell(tp1.Cdr, tp2);
tp1 = e;
}
- else if (x.Car.Car instanceof Symbol && firstChar(x.Car.Car) == '@') {
- if ((e = x.Car.Cdr.eval()) != Nil && unify((Number)Pnl.Car, x.Car.Car, (Number)Pnl.Car, e))
+ else if (x.Car.Car == Up) {
+ if ((e = x.Car.Cdr.Cdr.prog()) != Nil && unify((Number)Pnl.Car, x.Car.Cdr.Car, (Number)Pnl.Car, e))
tp1 = x.Cdr;
else {
Penv = y.Car.Car; y.Car = y.Car.Cdr;
diff --git a/ersatz/lib.l b/ersatz/lib.l
@@ -1,4 +1,4 @@
-# 04mar13abu
+# 19jul13abu
# (c) Software Lab. Alexander Burger
(setq *OS (java (java "java.lang.System" "getProperty" "os.name")))
@@ -875,19 +875,19 @@
(be true)
-(be not @P (1 -> @P) T (fail))
+(be not @P (1 (-> @P)) T (fail))
(be not @P)
(be call @P
- (2 cons (-> @P)) )
+ (2 (cons (-> @P))) )
-(be or @L (@C box (-> @L)) (_or @C))
+(be or @L (^ @C (box (-> @L))) (_or @C))
-(be _or (@C) (3 pop (-> @C)))
-(be _or (@C) (@ not (val (-> @C))) T (fail))
+(be _or (@C) (3 (pop (-> @C))))
+(be _or (@C) (^ @ (not (val (-> @C)))) T (fail))
(repeat)
-(be nil (@X) (@ not (-> @X)))
+(be nil (@X) (^ @ (not (-> @X))))
(be equal (@X @X))
@@ -910,55 +910,76 @@
(permute @D @Y) )
(be uniq (@B @X)
- (@ not (idx (-> @B) (-> @X) T)) )
+ (^ @ (not (idx (-> @B) (-> @X) T))) )
-(be asserta (@C) (@ asserta (-> @C)))
+(be asserta (@C) (^ @ (asserta (-> @C))))
-(be assertz (@C) (@ assertz (-> @C)))
+(be assertz (@C) (^ @ (assertz (-> @C))))
(be retract (@C)
- (2 cons (-> @C))
- (@ retract (list (car (-> @C)) (cdr (-> @C)))) )
+ (2 (cons (-> @C)))
+ (^ @ (retract (list (car (-> @C)) (cdr (-> @C))))) )
(be clause ("@H" "@B")
- ("@A" get (-> "@H") T)
+ (^ "@A" (get (-> "@H") T))
(member "@B" "@A") )
-(be show (@X) (@ show (-> @X)))
+(be show (@X) (^ @ (show (-> @X))))
+(be for (@N @End) (for @N 1 @End 1))
+(be for (@N @Beg @End) (for @N @Beg @End 1))
+(be for (@N @Beg @End @Step) (equal @N @Beg))
+(be for (@N @Beg @End @Step)
+ (^ @I (box (-> @Beg)))
+ (_for @N @I @End @Step) )
+
+(be _for (@N @I @End @Step)
+ (^ @
+ (if (>= (-> @End) (val (-> @I)))
+ (> (inc (-> @I) (-> @Step)) (-> @End))
+ (> (-> @End) (dec (-> @I) (-> @Step))) ) )
+ T
+ (fail) )
+
+(be _for (@N @I @End @Step)
+ (^ @N (val (-> @I))) )
+
+(repeat)
(be val (@V . @L)
- (@V apply get (-> @L))
+ (^ @V (apply get (-> @L)))
T )
(be lst (@V . @L)
- (@Lst box (apply get (-> @L)))
+ (^ @Lst (box (apply get (-> @L))))
(_lst @V @Lst) )
-(be _lst (@Val @Lst) (@ not (val (-> @Lst))) T (fail))
-(be _lst (@Val @Lst) (@Val pop (-> @Lst)))
+(be _lst (@Val @Lst) (^ @ (not (val (-> @Lst)))) T (fail))
+(be _lst (@Val @Lst) (^ @Val (pop (-> @Lst))))
(repeat)
(be map (@V . @L)
- (@Lst box (apply get (-> @L)))
+ (^ @Lst (box (apply get (-> @L))))
(_map @V @Lst) )
-(be _map (@Val @Lst) (@ not (val (-> @Lst))) T (fail))
-(be _map (@Val @Lst) (@Val prog1 (val (-> @Lst)) (pop (-> @Lst))))
+(be _map (@Val @Lst) (^ @ (not (val (-> @Lst)))) T (fail))
+(be _map (@Val @Lst) (^ @Val (prog1 (val (-> @Lst)) (pop (-> @Lst)))))
(repeat)
(be isa (@Typ . @L)
- (@ or
- (not (-> @Typ))
- (isa (-> @Typ) (apply get (-> @L))) ) )
+ (^ @
+ (or
+ (not (-> @Typ))
+ (isa (-> @Typ) (apply get (-> @L))) ) ) )
(be same (@V . @L)
- (@ let V (-> @V)
- (or
- (not V)
- (let L (-> @L)
- ("same" (car L) (cdr L)) ) ) ) )
+ (^ @
+ (let V (-> @V)
+ (or
+ (not V)
+ (let L (-> @L)
+ ("same" (car L) (cdr L)) ) ) ) ) )
(de "same" (X L)
(cond
@@ -975,16 +996,18 @@
(T ("same" (apply get (car L) X) (cdr L))) ) )
(be bool (@F . @L)
- (@ or
- (not (-> @F))
- (apply get (-> @L)) ) )
+ (^ @
+ (or
+ (not (-> @F))
+ (apply get (-> @L)) ) ) )
(be range (@N . @L)
- (@ let N (-> @N)
- (or
- (not N)
- (let L (-> @L)
- ("range" (car L) (cdr L)) ) ) ) )
+ (^ @
+ (let N (-> @N)
+ (or
+ (not N)
+ (let L (-> @L)
+ ("range" (car L) (cdr L)) ) ) ) ) )
(de "range" (X L)
(cond
@@ -1008,11 +1031,12 @@
(T ("range" (apply get (car L) X) (cdr L))) ) )
(be head (@S . @L)
- (@ let S (-> @S)
- (or
- (not S)
- (let L (-> @L)
- ("head" (car L) (cdr L)) ) ) ) )
+ (^ @
+ (let S (-> @S)
+ (or
+ (not S)
+ (let L (-> @L)
+ ("head" (car L) (cdr L)) ) ) ) ) )
(de "head" (X L)
(cond
@@ -1029,11 +1053,12 @@
(T ("head" (apply get (car L) X) (cdr L))) ) )
(be fold (@S . @L)
- (@ let S (-> @S)
- (or
- (not S)
- (let L (-> @L)
- ("fold" (car L) (cdr L)) ) ) ) )
+ (^ @
+ (let S (-> @S)
+ (or
+ (not S)
+ (let L (-> @L)
+ ("fold" (car L) (cdr L)) ) ) ) ) )
(de "fold" (X L)
(cond
@@ -1051,11 +1076,12 @@
(T ("fold" (apply get (car L) X) (cdr L))) ) )
(be part (@S . @L)
- (@ let S (-> @S)
- (or
- (not S)
- (let L (-> @L)
- ("part" (car L) (cdr L)) ) ) ) )
+ (^ @
+ (let S (-> @S)
+ (or
+ (not S)
+ (let L (-> @L)
+ ("part" (car L) (cdr L)) ) ) ) ) )
(de "part" (X L)
(cond
@@ -1073,11 +1099,12 @@
(T ("part" (apply get (car L) X) (cdr L))) ) )
(be tolr (@S . @L)
- (@ let S (-> @S)
- (or
- (not S)
- (let L (-> @L)
- ("tolr" (car L) (cdr L)) ) ) ) )
+ (^ @
+ (let S (-> @S)
+ (or
+ (not S)
+ (let L (-> @L)
+ ("tolr" (car L) (cdr L)) ) ) ) ) )
(de "tolr" (X L)
(cond
@@ -1099,16 +1126,17 @@
(be _remote ((@Obj . @))
- (@ not (val (-> @Sockets 2)))
+ (^ @ (not (val (-> @Sockets 2))))
T
(fail) )
(be _remote ((@Obj . @))
- (@Obj let (Box (-> @Sockets 2) Lst (val Box))
- (rot Lst)
- (loop
- (T ((cdar Lst)) @)
- (NIL (set Box (setq Lst (cdr Lst)))) ) ) )
+ (^ @Obj
+ (let (Box (-> @Sockets 2) Lst (val Box))
+ (rot Lst)
+ (loop
+ (T ((cdar Lst)) @)
+ (NIL (set Box (setq Lst (cdr Lst)))) ) ) ) )
(repeat)
diff --git a/ersatz/picolisp.jar b/ersatz/picolisp.jar
Binary files differ.
diff --git a/lib/map b/lib/map
@@ -6,7 +6,7 @@ $ (3023 . "@src64/flow.l")
*/ (2446 . "@src64/big.l")
+ (2171 . "@src64/big.l")
- (2209 . "@src64/big.l")
--> (3929 . "@src64/subr.l")
+-> (3909 . "@src64/subr.l")
/ (2513 . "@src64/big.l")
: (3060 . "@src64/sym.l")
:: (3084 . "@src64/sym.l")
@@ -300,7 +300,7 @@ setq (1649 . "@src64/sym.l")
sigio (493 . "@src64/main.l")
size (2809 . "@src64/subr.l")
skip (3531 . "@src64/io.l")
-sort (3978 . "@src64/subr.l")
+sort (3958 . "@src64/subr.l")
sp? (727 . "@src64/sym.l")
space (5104 . "@src64/io.l")
split (1593 . "@src64/subr.l")
@@ -333,7 +333,7 @@ trim (1760 . "@src64/subr.l")
try (1177 . "@src64/flow.l")
type (920 . "@src64/flow.l")
udp (304 . "@src64/net.l")
-unify (3951 . "@src64/subr.l")
+unify (3931 . "@src64/subr.l")
unless (1901 . "@src64/flow.l")
until (2085 . "@src64/flow.l")
up (776 . "@src64/main.l")
diff --git a/lib/pilog.l b/lib/pilog.l
@@ -1,4 +1,4 @@
-# 09jul12abu
+# 19jul13abu
# (c) Software Lab. Alexander Burger
# *Rule
@@ -99,19 +99,19 @@
(be true)
-(be not @P (1 -> @P) T (fail))
+(be not @P (1 (-> @P)) T (fail))
(be not @P)
(be call @P
- (2 cons (-> @P)) )
+ (2 (cons (-> @P))) )
-(be or @L (@C box (-> @L)) (_or @C))
+(be or @L (^ @C (box (-> @L))) (_or @C))
-(be _or (@C) (3 pop (-> @C)))
-(be _or (@C) (@ not (val (-> @C))) T (fail))
+(be _or (@C) (3 (pop (-> @C))))
+(be _or (@C) (^ @ (not (val (-> @C)))) T (fail))
(repeat)
-(be nil (@X) (@ not (-> @X)))
+(be nil (@X) (^ @ (not (-> @X))))
(be equal (@X @X))
@@ -134,36 +134,39 @@
(permute @D @Y) )
(be uniq (@B @X)
- (@ not (idx (-> @B) (-> @X) T)) )
+ (^ @ (not (idx (-> @B) (-> @X) T))) )
-(be asserta (@C) (@ asserta (-> @C)))
+(be asserta (@C) (^ @ (asserta (-> @C))))
-(be assertz (@C) (@ assertz (-> @C)))
+(be assertz (@C) (^ @ (assertz (-> @C))))
(be retract (@C)
- (2 cons (-> @C))
- (@ retract (list (car (-> @C)) (cdr (-> @C)))) )
+ (2 (cons (-> @C)))
+ (^ @ (retract (list (car (-> @C)) (cdr (-> @C))))) )
(be clause ("@H" "@B")
- ("@A" get (-> "@H") T)
+ (^ "@A" (get (-> "@H") T))
(member "@B" "@A") )
-(be show (@X) (@ show (-> @X)))
+(be show (@X) (^ @ (show (-> @X))))
(be for (@N @End) (for @N 1 @End 1))
(be for (@N @Beg @End) (for @N @Beg @End 1))
(be for (@N @Beg @End @Step) (equal @N @Beg))
-(be for (@N @Beg @End @Step) (@I box (-> @Beg)) (_for @N @I @End @Step))
+(be for (@N @Beg @End @Step)
+ (^ @I (box (-> @Beg)))
+ (_for @N @I @End @Step) )
(be _for (@N @I @End @Step)
- (@ if (>= (-> @End) (val (-> @I)))
- (> (inc (-> @I) (-> @Step)) (-> @End))
- (> (-> @End) (dec (-> @I) (-> @Step))) )
+ (^ @
+ (if (>= (-> @End) (val (-> @I)))
+ (> (inc (-> @I) (-> @Step)) (-> @End))
+ (> (-> @End) (dec (-> @I) (-> @Step))) ) )
T
(fail) )
(be _for (@N @I @End @Step)
- (@N val (-> @I)) )
+ (^ @N (val (-> @I))) )
(repeat)
@@ -215,79 +218,85 @@
# (db var cls obj)
(be db (@Var @Cls @Obj)
- (@Q box
- (with (or (get (-> @Cls) (-> @Var)) (meta (-> @Cls) (-> @Var)))
- (initQuery (: var) (: cls) NIL '(NIL . T)) ) )
+ (^ @Q
+ (box
+ (with (or (get (-> @Cls) (-> @Var)) (meta (-> @Cls) (-> @Var)))
+ (initQuery (: var) (: cls) NIL '(NIL . T)) ) ) )
(_db @Obj) )
# (db var cls hook|val obj)
(be db (@Var @Cls @X @Obj)
- (@Q box
- (with (or (get (-> @Cls) (-> @Var)) (meta (-> @Cls) (-> @Var)))
- (cond
- ((: hook)
- (initQuery (: var) (: cls) (-> @X) '(NIL . T)) )
- ((isa '+Fold This)
- (initQuery (: var) (: cls) NIL (fold (-> @X))) )
- (T
- (initQuery (: var) (: cls) NIL (-> @X)) ) ) ) )
+ (^ @Q
+ (box
+ (with (or (get (-> @Cls) (-> @Var)) (meta (-> @Cls) (-> @Var)))
+ (cond
+ ((: hook)
+ (initQuery (: var) (: cls) (-> @X) '(NIL . T)) )
+ ((isa '+Fold This)
+ (initQuery (: var) (: cls) NIL (fold (-> @X))) )
+ (T
+ (initQuery (: var) (: cls) NIL (-> @X)) ) ) ) ) )
(_db @Obj) )
# (db var cls hook val obj)
(be db (@Var @Cls @Hook @Val @Obj)
- (@Q box
- (with (or (get (-> @Cls) (-> @Var)) (meta (-> @Cls) (-> @Var)))
- (initQuery (: var) (: cls) (-> @Hook)
- (if (isa '+Fold This)
- (fold (-> @Val))
- (-> @Val) ) ) ) )
+ (^ @Q
+ (box
+ (with (or (get (-> @Cls) (-> @Var)) (meta (-> @Cls) (-> @Var)))
+ (initQuery (: var) (: cls) (-> @Hook)
+ (if (isa '+Fold This)
+ (fold (-> @Val))
+ (-> @Val) ) ) ) ) )
(_db @Obj) )
(be _db (@Obj)
- (@ let (Q (val (-> @Q 2)) Cls (-> @Cls 2))
- (loop
- (NIL (step Q (= '(NIL) (caaar Q))) T)
- (T (isa Cls (setq "R" @))) ) )
+ (^ @
+ (let (Q (val (-> @Q 2)) Cls (-> @Cls 2))
+ (loop
+ (NIL (step Q (= '(NIL) (caaar Q))) T)
+ (T (isa Cls (setq "R" @))) ) ) )
T
(fail) )
-(be _db (@Obj) (@Obj . "R"))
+(be _db (@Obj) (^ @Obj "R"))
(repeat)
(be val (@V . @L)
- (@V apply get (-> @L))
+ (^ @V (apply get (-> @L)))
T )
(be lst (@V . @L)
- (@Lst box (apply get (-> @L)))
+ (^ @Lst (box (apply get (-> @L))))
(_lst @V @Lst) )
-(be _lst (@Val @Lst) (@ not (val (-> @Lst))) T (fail))
-(be _lst (@Val @Lst) (@Val pop (-> @Lst)))
+(be _lst (@Val @Lst) (^ @ (not (val (-> @Lst)))) T (fail))
+(be _lst (@Val @Lst) (^ @Val (pop (-> @Lst))))
(repeat)
(be map (@V . @L)
- (@Lst box (apply get (-> @L)))
+ (^ @Lst (box (apply get (-> @L))))
(_map @V @Lst) )
-(be _map (@Val @Lst) (@ not (val (-> @Lst))) T (fail))
-(be _map (@Val @Lst) (@Val prog1 (val (-> @Lst)) (pop (-> @Lst))))
+(be _map (@Val @Lst) (^ @ (not (val (-> @Lst)))) T (fail))
+(be _map (@Val @Lst) (^ @Val (prog1 (val (-> @Lst)) (pop (-> @Lst)))))
(repeat)
(be isa (@Typ . @L)
- (@ or
- (not (-> @Typ))
- (isa (-> @Typ) (apply get (-> @L))) ) )
+ (^ @
+ (or
+ (not (-> @Typ))
+ (isa (-> @Typ) (apply get (-> @L))) ) ) )
(be same (@V . @L)
- (@ let V (-> @V)
- (or
- (not V)
- (let L (-> @L)
- ("same" (car L) (cdr L)) ) ) ) )
+ (^ @
+ (let V (-> @V)
+ (or
+ (not V)
+ (let L (-> @L)
+ ("same" (car L) (cdr L)) ) ) ) ) )
(de "same" (X L)
(cond
@@ -304,16 +313,18 @@
(T ("same" (apply get (car L) X) (cdr L))) ) )
(be bool (@F . @L)
- (@ or
- (not (-> @F))
- (apply get (-> @L)) ) )
+ (^ @
+ (or
+ (not (-> @F))
+ (apply get (-> @L)) ) ) )
(be range (@N . @L)
- (@ let N (-> @N)
- (or
- (not N)
- (let L (-> @L)
- ("range" (car L) (cdr L)) ) ) ) )
+ (^ @
+ (let N (-> @N)
+ (or
+ (not N)
+ (let L (-> @L)
+ ("range" (car L) (cdr L)) ) ) ) ) )
(de "range" (X L)
(cond
@@ -337,11 +348,12 @@
(T ("range" (apply get (car L) X) (cdr L))) ) )
(be head (@S . @L)
- (@ let S (-> @S)
- (or
- (not S)
- (let L (-> @L)
- ("head" (car L) (cdr L)) ) ) ) )
+ (^ @
+ (let S (-> @S)
+ (or
+ (not S)
+ (let L (-> @L)
+ ("head" (car L) (cdr L)) ) ) ) ) )
(de "head" (X L)
(cond
@@ -358,11 +370,12 @@
(T ("head" (apply get (car L) X) (cdr L))) ) )
(be fold (@S . @L)
- (@ let S (-> @S)
- (or
- (not S)
- (let L (-> @L)
- ("fold" (car L) (cdr L)) ) ) ) )
+ (^ @
+ (let S (-> @S)
+ (or
+ (not S)
+ (let L (-> @L)
+ ("fold" (car L) (cdr L)) ) ) ) ) )
(de "fold" (X L)
(cond
@@ -380,11 +393,12 @@
(T ("fold" (apply get (car L) X) (cdr L))) ) )
(be part (@S . @L)
- (@ let S (-> @S)
- (or
- (not S)
- (let L (-> @L)
- ("part" (car L) (cdr L)) ) ) ) )
+ (^ @
+ (let S (-> @S)
+ (or
+ (not S)
+ (let L (-> @L)
+ ("part" (car L) (cdr L)) ) ) ) ) )
(de "part" (X L)
(cond
@@ -402,11 +416,12 @@
(T ("part" (apply get (car L) X) (cdr L))) ) )
(be tolr (@S . @L)
- (@ let S (-> @S)
- (or
- (not S)
- (let L (-> @L)
- ("tolr" (car L) (cdr L)) ) ) ) )
+ (^ @
+ (let S (-> @S)
+ (or
+ (not S)
+ (let L (-> @L)
+ ("tolr" (car L) (cdr L)) ) ) ) ) )
(de "tolr" (X L)
(cond
@@ -505,39 +520,43 @@
(T (step Q (= '(NIL) (caaar Q)))) ) )
(be select (("@Obj" . "@X") . "@Lst")
- (@ unify (-> "@X"))
- ("@P" box (cdr (-> "@Lst")))
- ("@C" box # ((obj ..) curr . lst)
- (let L (car (-> "@Lst"))
- (setq L
- (or
- (mapcan "select" L)
- ("select" (car L) T) ) )
- (cons NIL L L) ) )
+ (^ @ (unify (-> "@X")))
+ (^ "@P" (box (cdr (-> "@Lst"))))
+ (^ "@C"
+ (box # ((obj ..) curr . lst)
+ (let L (car (-> "@Lst"))
+ (setq L
+ (or
+ (mapcan "select" L)
+ ("select" (car L) T) ) )
+ (cons NIL L L) ) ) )
(_gen "@Obj")
(_sel) )
(be _gen (@Obj)
- (@ let C (caadr (val (-> "@C" 2)))
- (not (setq "*R" (_gen (car C) (cdr C)))) )
+ (^ @
+ (let C (caadr (val (-> "@C" 2)))
+ (not (setq "*R" (_gen (car C) (cdr C)))) ) )
T
(fail) )
-(be _gen (@Obj) (@Obj . "*R"))
+(be _gen (@Obj) (^ @Obj "*R"))
(repeat)
(be _sel ()
- (2 val (-> "@P" 2))
- (@ let C (val (-> "@C" 2))
- (unless (idx C "*R" T)
- (rot (cddr C) (offset (cadr C) (cddr C)))
- (set (cdr C) (cddr C)) ) )
+ (2 (val (-> "@P" 2)))
+ (^ @
+ (let C (val (-> "@C" 2))
+ (unless (idx C "*R" T)
+ (rot (cddr C) (offset (cadr C) (cddr C)))
+ (set (cdr C) (cddr C)) ) ) )
T )
(be _sel ()
- (@ let C (cdr (val (-> "@C" 2)))
- (set C (or (cdar C) (cdr C))) )
+ (^ @
+ (let C (cdr (val (-> "@C" 2)))
+ (set C (or (cdar C) (cdr C))) ) )
(fail) )
### Remote queries ###
@@ -548,25 +567,27 @@
(bye) )
(be remote ("@Lst" . "@CL")
- (@Sockets box
- (prog1 (cdr (-> "@Lst"))
- (for X @ # (out . in)
- ((car X)
- (cons 'rqry (car (-> "@Lst")) (-> "@CL")) ) ) ) )
- (@ unify (car (-> "@Lst")))
+ (^ @Sockets
+ (box
+ (prog1 (cdr (-> "@Lst"))
+ (for X @ # (out . in)
+ ((car X)
+ (cons 'rqry (car (-> "@Lst")) (-> "@CL")) ) ) ) ) )
+ (^ @ (unify (car (-> "@Lst"))))
(_remote "@Lst") )
(be _remote ((@Obj . @))
- (@ not (val (-> @Sockets 2)))
+ (^ @ (not (val (-> @Sockets 2))))
T
(fail) )
(be _remote ((@Obj . @))
- (@Obj let (Box (-> @Sockets 2) Lst (val Box))
- (rot Lst)
- (loop
- (T ((cdar Lst)) @)
- (NIL (set Box (setq Lst (cdr Lst)))) ) ) )
+ (^ @Obj
+ (let (Box (-> @Sockets 2) Lst (val Box))
+ (rot Lst)
+ (loop
+ (T ((cdar Lst)) @)
+ (NIL (set Box (setq Lst (cdr Lst)))) ) ) ) )
(repeat)
diff --git a/misc/hanoi.l b/misc/hanoi.l
@@ -1,4 +1,4 @@
-# 10nov04abu
+# 19jul13abu
# (c) Software Lab. Alexander Burger
# Lisp
@@ -18,7 +18,7 @@
(be move (0 @ @ @) T)
(be move (@N @A @B @C)
- (@M - (-> @N) 1)
+ (^ @M (dec (-> @N)))
(move @M @A @C @B)
- (@ println 'Move 'disk 'from 'the (-> @A) 'to 'the (-> @B) 'pole)
+ (^ @ (println 'Move 'disk 'from 'the (-> @A) 'to 'the (-> @B) 'pole))
(move @M @C @B @A) )
diff --git a/opt/pilog.l b/opt/pilog.l
@@ -0,0 +1,16 @@
+# 19jul13abu
+# (c) Software Lab. Alexander Burger
+
+(be mapcar (@ NIL NIL))
+(be mapcar (@P (@X . @L) (@Y . @M))
+ (call @P @X @Y)
+ (mapcar @P @L @M) )
+
+# Contributed by Clemens Hinze <cle-picolisp@qiao.in-berlin.de>
+(be findall (@Pat @P @Res)
+ (^ @Res
+ (solve
+ (-> @P)
+ (or @Pat (fill (-> @Pat))) ) ) )
+
+# vi:et:ts=3:sw=3
diff --git a/src/subr.c b/src/subr.c
@@ -1,4 +1,4 @@
-/* 17mar13abu
+/* 19jul13abu
* (c) Software Lab. Alexander Burger
*/
@@ -1577,16 +1577,16 @@ any doProve(any x) {
data(tp1) = cdr(x);
}
else if (isNum(caar(x))) {
- data(e) = EVAL(cdar(x));
+ data(e) = prog(cdar(x));
for (i = unDig(caar(x)), x = data(nl); (i -= 2) > 0;)
x = cdr(x);
data(nl) = cons(car(x), data(nl));
data(tp2) = cons(cdr(data(tp1)), data(tp2));
data(tp1) = data(e);
}
- else if (isSym(caar(x)) && firstByte(caar(x)) == '@') {
- if (!isNil(data(e) = EVAL(cdar(x))) &&
- unify(car(data(nl)), caar(x), car(data(nl)), data(e)) )
+ else if (caar(x) == Up) {
+ if (!isNil(data(e) = prog(cddar(x))) &&
+ unify(car(data(nl)), cadar(x), car(data(nl)), data(e)) )
data(tp1) = cdr(x);
else {
data(env) = caar(data(q)), car(data(q)) = cdar(data(q));
diff --git a/src/vers.h b/src/vers.h
@@ -1 +1 @@
-static byte Version[4] = {3,1,3,4};
+static byte Version[4] = {3,1,3,5};
diff --git a/src64/subr.l b/src64/subr.l
@@ -1,4 +1,4 @@
-# 31mar13abu
+# 19jul13abu
# (c) Software Lab. Alexander Burger
# (car 'var) -> any
@@ -3693,7 +3693,8 @@
ld (L V) ((L V) CDR) # nl = cdr(nl)
continue T
end
- cmp (X) TSym # car(tp1) == T?
+ ld Y (X) # car(tp1)
+ cmp Y TSym # car(tp1) == T?
if eq
do
ld C ((L IX)) # car(q)
@@ -3706,12 +3707,12 @@
ld (L III) (X CDR) # tp1 = cdr(tp1)
continue T
end
- num ((X)) # caar(tp1) numeric?
+ num (Y) # caar(tp1) numeric?
if nz # Yes
- ld E ((X) CDR) # Eval cdar(tp1)
- eval
+ ld Z (Y CDR) # Run Lisp body
+ prog Z
ld (L I) E # -> e
- ld C ((X)) # Get count
+ ld C (Y) # Get count
shr C 4 # Normalize short
ld A (L V) # nl
do
@@ -3730,50 +3731,29 @@
ld (L III) (L I) # tp1 = e
continue T
end
- ld E ((X)) # caar(tp1)
- sym E # Symbolic?
- if nz # Yes
- ld A (E TAIL)
- call firstByteA_B # starting with "@"?
- cmp B (char "@")
- if eq # Yes
- ld E ((X) CDR) # Eval cdar(tp1)
- eval
- ld (L I) E # -> e
- cmp E Nil # Any?
- if ne # Yes
- ld C ((L V)) # car(nl)
- ld Y ((X)) # caar(tp1)
- ld E C # car(nl)
- ld Z (L I) # e
- call unifyCEYZ_F # Match?
- if eq # Yes
- ld (L III) ((L III) CDR) # tp1 = cdr(tp1)
- continue T
- end
- end
- ld X (((L IX))) # env = caar(q)
- ld ((L IX)) (((L IX)) CDR) # car(q) = cdar(q)
- ld (L VI) (X) # n = car(env)
- ld X (X CDR) # env = cdr(env)
- ld (L V) (X) # nl = car(env)
- ld X (X CDR) # env = cdr(env)
- ld (L IV) (X) # alt = car(env)
- ld X (X CDR) # env = cdr(env)
- ld (L III) (X) # tp1 = car(env)
- ld X (X CDR) # env = cdr(env)
- ld (L II) (X) # tp2 = car(env)
- ld X (X CDR) # env = cdr(env)
- ld (L VII) X # Set env
- continue T
- end
+ ld E (Y) # caar(tp1)
+ cmp E Up # Lisp call?
+ if eq # Yes
+ ld Z ((Y CDR) CDR) # Run Lisp body
+ prog Z
+ ld (L I) E # -> e
+ cmp E Nil # Any?
+ jeq 20 # No
+ ld C ((L V)) # car(nl)
+ ld Y ((Y CDR)) # cadar(tp1)
+ ld E C # car(nl)
+ ld Z (L I) # e
+ call unifyCEYZ_F # Match?
+ jne 20 # No
+ ld (L III) ((L III) CDR) # tp1 = cdr(tp1)
+ continue T
end
ld C TSym # get(caar(tp1), T)
call getEC_E
ld (L IV) E # -> alt
atom E # Atomic?
if nz # Yes
- ld X (((L IX))) # env = caar(q)
+20 ld X (((L IX))) # env = caar(q)
ld ((L IX)) (((L IX)) CDR) # car(q) = cdar(q)
ld (L VI) (X) # n = car(env)
ld X (X CDR) # env = cdr(env)
diff --git a/src64/tags b/src64/tags
@@ -1238,14 +1238,14 @@ sys/x86-64.freeBsd.defs.l,1994
fillE_FE3274,66981
unifyCEYZ_F3377,69250
doProve3543,73614
-lupCE_E3828,82084
-lookupCE_E3885,83475
-uniFillE_E3899,83728
-doArrow3929,84361
-doUnify3951,84771
-doSort3978,85259
-cmpDfltA_F4133,90440
-cmpUserAX_F4138,90591
+lupCE_E3808,81284
+lookupCE_E3865,82675
+uniFillE_E3879,82928
+doArrow3909,83561
+doUnify3931,83971
+doSort3958,84459
+cmpDfltA_F4113,89640
+cmpUserAX_F4118,89791
./net.l,192
doPort5,96
diff --git a/src64/version.l b/src64/version.l
@@ -1,6 +1,6 @@
-# 17jul13abu
+# 19jul13abu
# (c) Software Lab. Alexander Burger
-(de *Version 3 1 3 4)
+(de *Version 3 1 3 5)
# vi:et:ts=3:sw=3
diff --git a/test/src/subr.l b/test/src/subr.l
@@ -1,4 +1,4 @@
-# 31mar13abu
+# 19jul13abu
# (c) Software Lab. Alexander Burger
### c[ad]*r ###
@@ -496,12 +496,12 @@
### -> ###
(test '((@A . 3) (@B . 7))
- (prove (goal '(@A 3 (@B + 4 (-> @A))))) )
+ (prove (goal '(@A 3 (^ @B (+ 4 (-> @A)))))) )
### unify ###
(test '((@A ((NIL . @C) 0 . @C) ((NIL . @B) 0 . @B) T))
- (prove (goal '((@A unify '(@B @C))))) )
+ (prove (goal '((^ @A (unify '(@B @C)))))) )
### sort ###
