picolisp

Unnamed repository; edit this file to name it for gitweb.
git clone https://logand.com/git/picolisp.git/
Log | Files | Refs | README | LICENSE

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:
MCHANGES | 1+
Mdoc/family.l | 6+++---
Mdoc/family.tgz | 0
Mdoc/family64.tgz | 0
Mdoc/refM.html | 2+-
Mdoc/refR.html | 4++--
Mdoc/refT.html | 2+-
Mdoc/refU.html | 2+-
Mdoc/ref_.html | 2+-
Mersatz/fun.src | 8++++----
Mersatz/lib.l | 154+++++++++++++++++++++++++++++++++++++++++++++++--------------------------------
Mersatz/picolisp.jar | 0
Mlib/map | 6+++---
Mlib/pilog.l | 253+++++++++++++++++++++++++++++++++++++++++++------------------------------------
Mmisc/hanoi.l | 6+++---
Aopt/pilog.l | 16++++++++++++++++
Msrc/subr.c | 10+++++-----
Msrc/vers.h | 2+-
Msrc64/subr.l | 68++++++++++++++++++++++++--------------------------------------------
Msrc64/tags | 16++++++++--------
Msrc64/version.l | 4++--
Mtest/src/subr.l | 6+++---
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#->">-&gt</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 ###