commit 3eb25b2a059cebc006d357aaa2bd6b671f9be987
parent a24033c586ff4948537ef592027809cf6f3af2af
Author: Commit-Bot <unknown>
Date: Thu, 25 Nov 2010 12:05:27 +0000
Automatic commit from picoLisp.tgz, From: Thu, 25 Nov 2010 12:05:27 GMT
Diffstat:
15 files changed, 110 insertions(+), 25 deletions(-)
diff --git a/CHANGES b/CHANGES
@@ -1,4 +1,5 @@
* XXdec10 picoLisp-3.0.5
+ 'prior' function
'circ?' function
Ersatz PicoLisp (Java) version
Bug in (rd 'cnt)
diff --git a/doc/ref.html b/doc/ref.html
@@ -2011,6 +2011,7 @@ abbreviations:
<a href="refD.html#diff">diff</a>
<a href="refI.html#index">index</a>
<a href="refO.html#offset">offset</a>
+ <a href="refP.html#prior">prior</a>
<a href="refA.html#assoc">assoc</a>
<a href="refA.html#asoq">asoq</a>
<a href="refR.html#rank">rank</a>
diff --git a/doc/refP.html b/doc/refP.html
@@ -575,6 +575,23 @@ href="refP.html#println">println</a></code>.
(a b c) def -> def
</code></pre>
+<dt><a name="prior"><code>(prior 'lst1 'lst2) -> lst | NIL</code></a>
+<dd>Returns the cell in <code>lst2</code> which immediately precedes the cell
+<code>lst1</code>, or <code>NIL</code> if <code>lst1</code> is not found in
+<code>lst2</code>. <code><a href="ref_.html#==">==</a></code> is used for
+comparison (pointer equality). See also <code><a
+href="refO.html#offset">offset</a></code> and <code><a
+href="refM.html#memq">memq</a></code>.
+
+<pre><code>
+: (setq L (1 2 3 4 5 6))
+-> (1 2 3 4 5 6)
+: (setq X (cdddr L))
+-> (4 5 6)
+: (prior X L)
+-> (3 4 5 6)
+</code></pre>
+
<dt><a name="proc"><code>(proc 'sym ..) -> T</code></a>
<dd>Shows a list of processes with command names given by the <code>sym</code>
arguments, using the system <code>ps</code> utility. See also <code><a
diff --git a/doc/refR.html b/doc/refR.html
@@ -298,7 +298,7 @@ symbol <code>recurse</code> is bound to the function definition
(when (lt0 N)
(quit "Bad fibonacci" N) )
(recur (N)
- (if (< N 2)
+ (if (> 2 N)
1
(+
(recurse (dec N))
diff --git a/ersatz/fun.src b/ersatz/fun.src
@@ -1,4 +1,4 @@
-# 19nov10abu
+# 25nov10abu
# (c) Software Lab. Alexander Burger
# Ersatz PicoLisp Functions
@@ -2776,6 +2776,18 @@ offset (i x y)
return new Number(i);
return Nil;
+# (prior 'lst1 'lst2) -> lst | NIL
+prior (x y)
+ y = (x = ex.Cdr).Car.eval();
+ x = x.Cdr.Car.eval();
+ if (x != y)
+ while (x instanceof Cell) {
+ if (y == x.Cdr)
+ return x;
+ x = x.Cdr;
+ }
+ return Nil;
+
# (length 'any) -> cnt | T
length (n)
return (n = ex.Cdr.Car.eval().length()) >= 0? new Number(n) : T;
diff --git a/ersatz/picolisp.jar b/ersatz/picolisp.jar
Binary files differ.
diff --git a/lib.l b/lib.l
@@ -1,4 +1,4 @@
-# 03oct10abu
+# 23nov10abu
# (c) Software Lab. Alexander Burger
(de task (Key . Prg)
@@ -254,7 +254,7 @@
### Pretty Printing ###
(de *PP
T NIL if ifn when unless while until do case state for
- with catch finally ! setq default push job use let let?
+ with catch finally co ! setq default push job use let let?
prog1 later recur redef =: in out ctl tab new )
(de *PP1 let let? for redef)
(de *PP2 setq default)
diff --git a/lib/tags b/lib/tags
@@ -6,7 +6,7 @@ $ (2943 . "@src64/flow.l")
*/ (2446 . "@src64/big.l")
+ (2171 . "@src64/big.l")
- (2209 . "@src64/big.l")
--> (3842 . "@src64/subr.l")
+-> (3870 . "@src64/subr.l")
/ (2511 . "@src64/big.l")
: (2898 . "@src64/sym.l")
:: (2922 . "@src64/sym.l")
@@ -36,8 +36,8 @@ arg (2266 . "@src64/main.l")
args (2242 . "@src64/main.l")
argv (2887 . "@src64/main.l")
as (146 . "@src64/flow.l")
-asoq (2964 . "@src64/subr.l")
-assoc (2929 . "@src64/subr.l")
+asoq (2992 . "@src64/subr.l")
+assoc (2957 . "@src64/subr.l")
at (2106 . "@src64/flow.l")
atom (2372 . "@src64/subr.l")
bind (1359 . "@src64/flow.l")
@@ -128,7 +128,7 @@ extra (1263 . "@src64/flow.l")
extract (1096 . "@src64/apply.l")
fifo (1963 . "@src64/sym.l")
file (2747 . "@src64/main.l")
-fill (3199 . "@src64/subr.l")
+fill (3227 . "@src64/subr.l")
filter (1039 . "@src64/apply.l")
fin (2020 . "@src64/subr.l")
finally (2520 . "@src64/flow.l")
@@ -173,7 +173,7 @@ journal (970 . "@src64/db.l")
key (3279 . "@src64/io.l")
kill (3225 . "@src64/flow.l")
last (2031 . "@src64/subr.l")
-length (2700 . "@src64/subr.l")
+length (2728 . "@src64/subr.l")
let (1476 . "@src64/flow.l")
let? (1537 . "@src64/flow.l")
lieu (1156 . "@src64/db.l")
@@ -202,7 +202,7 @@ mapcon (919 . "@src64/apply.l")
maplist (811 . "@src64/apply.l")
maps (668 . "@src64/apply.l")
mark (1965 . "@src64/db.l")
-match (3084 . "@src64/subr.l")
+match (3112 . "@src64/subr.l")
max (2314 . "@src64/subr.l")
maxi (1389 . "@src64/apply.l")
member (2442 . "@src64/subr.l")
@@ -258,12 +258,13 @@ prinl (4932 . "@src64/io.l")
print (4958 . "@src64/io.l")
println (4989 . "@src64/io.l")
printsp (4974 . "@src64/io.l")
+prior (2700 . "@src64/subr.l")
prog (1757 . "@src64/flow.l")
prog1 (1765 . "@src64/flow.l")
prog2 (1782 . "@src64/flow.l")
prop (2781 . "@src64/sym.l")
protect (532 . "@src64/main.l")
-prove (3456 . "@src64/subr.l")
+prove (3484 . "@src64/subr.l")
push (1688 . "@src64/sym.l")
push1 (1724 . "@src64/sym.l")
put (2698 . "@src64/sym.l")
@@ -274,7 +275,7 @@ quit (1098 . "@src64/main.l")
quote (141 . "@src64/flow.l")
rand (2959 . "@src64/big.l")
range (988 . "@src64/subr.l")
-rank (2992 . "@src64/subr.l")
+rank (3020 . "@src64/subr.l")
raw (465 . "@src64/main.l")
rd (5036 . "@src64/io.l")
read (2562 . "@src64/io.l")
@@ -294,9 +295,9 @@ seq (1083 . "@src64/db.l")
set (1482 . "@src64/sym.l")
setq (1515 . "@src64/sym.l")
sigio (503 . "@src64/main.l")
-size (2765 . "@src64/subr.l")
+size (2793 . "@src64/subr.l")
skip (3406 . "@src64/io.l")
-sort (3891 . "@src64/subr.l")
+sort (3919 . "@src64/subr.l")
sp? (711 . "@src64/sym.l")
space (4936 . "@src64/io.l")
split (1579 . "@src64/subr.l")
@@ -326,7 +327,7 @@ trim (1746 . "@src64/subr.l")
try (1172 . "@src64/flow.l")
type (912 . "@src64/flow.l")
udp (268 . "@src64/net.l")
-unify (3864 . "@src64/subr.l")
+unify (3892 . "@src64/subr.l")
unless (1898 . "@src64/flow.l")
until (2082 . "@src64/flow.l")
up (712 . "@src64/main.l")
diff --git a/src/pico.h b/src/pico.h
@@ -1,4 +1,4 @@
-/* 16nov10abu
+/* 25nov10abu
* (c) Software Lab. Alexander Burger
*/
@@ -644,6 +644,7 @@ any doPrinl(any);
any doPrint(any);
any doPrintln(any);
any doPrintsp(any);
+any doPrior(any);
any doProg(any);
any doProg1(any);
any doProg2(any);
diff --git a/src/subr.c b/src/subr.c
@@ -1,4 +1,4 @@
-/* 16nov10abu
+/* 25nov10abu
* (c) Software Lab. Alexander Burger
*/
@@ -1171,6 +1171,22 @@ any doOffset(any x) {
return Nil;
}
+// (prior 'lst1 'lst2) -> lst | NIL
+any doPrior(any x) {
+ any y;
+ cell c1;
+
+ x = cdr(x), Push(c1, EVAL(car(x)));
+ x = cdr(x), y = EVAL(car(x));
+ if ((x = Pop(c1)) != y)
+ while (isCell(y)) {
+ if (x == cdr(y))
+ return y;
+ y = cdr(y);
+ }
+ return Nil;
+}
+
// (length 'any) -> cnt | T
any doLength(any x) {
int n, c;
diff --git a/src/tab.c b/src/tab.c
@@ -1,4 +1,4 @@
-/* 16nov10abu
+/* 25nov10abu
* (c) Software Lab. Alexander Burger
*/
@@ -257,6 +257,7 @@ static symInit Symbols[] = {
{doPrint, "print"},
{doPrintln, "println"},
{doPrintsp, "printsp"},
+ {doPrior, "prior"},
{doProg, "prog"},
{doProg1, "prog1"},
{doProg2, "prog2"},
diff --git a/src64/glob.l b/src64/glob.l
@@ -1,4 +1,4 @@
-# 16nov10abu
+# 25nov10abu
# (c) Software Lab. Alexander Burger
(data 'Globals 0)
@@ -445,6 +445,7 @@
initSym NIL "diff" doDiff
initSym NIL "index" doIndex
initSym NIL "offset" doOffset
+ initSym NIL "prior" doPrior
initSym NIL "length" doLength
initSym NIL "size" doSize
initSym NIL "assoc" doAssoc
diff --git a/src64/subr.l b/src64/subr.l
@@ -1,4 +1,4 @@
-# 16nov10abu
+# 25nov10abu
# (c) Software Lab. Alexander Burger
# (car 'var) -> any
@@ -2667,9 +2667,9 @@
ld E (X) # Eval first
eval
link
- push E # <L I> 'any'
+ push E # <L I> 'lst1'
link
- ld E ((X CDR)) # Eval second
+ ld E ((X CDR)) # Eval 'lst2'
eval
ld C 0 # Init result
ld X (L I) # Get 'lst1'
@@ -2696,6 +2696,34 @@
pop X
ret
+# (prior 'lst1 'lst2) -> lst | NIL
+(code 'doPrior 2)
+ push X
+ ld X (E CDR) # Args
+ ld E (X) # Eval first
+ eval
+ link
+ push E # <L I> 'lst1'
+ link
+ ld E ((X CDR)) # Eval 'lst2'
+ eval
+ ld C (L I) # Get 'lst1'
+ drop
+ pop X
+ cmp C E # First cell?
+ if ne # No
+ do
+ atom E # More?
+ while z # Yes
+ ld A (E CDR)
+ cmp A C # Found prior cell?
+ jeq ret # Yes
+ ld E A
+ loop
+ end
+ ld E Nil
+ ret
+
# (length 'any) -> cnt | T
(code 'doLength 2)
ld E (E CDR) # Get arg
diff --git a/src64/version.l b/src64/version.l
@@ -1,6 +1,6 @@
-# 19nov10abu
+# 25nov10abu
# (c) Software Lab. Alexander Burger
-(de *Version 3 0 4 12)
+(de *Version 3 0 4 13)
# vi:et:ts=3:sw=3
diff --git a/test/src/subr.l b/test/src/subr.l
@@ -1,4 +1,4 @@
-# 16nov10abu
+# 25nov10abu
# (c) Software Lab. Alexander Burger
### c[ad]*r ###
@@ -384,6 +384,12 @@
(test NIL (offset '(c d e) '(a b c d e f)))
+### prior ###
+(let (L (1 2 3 4 5 6) X (cdddr L))
+ (test NIL (prior L L))
+ (test (3 4 5 6) (prior X L)) )
+
+
### length ###
(test 3 (length "abc"))
(test 3 (length "äbc"))
