commit 48bd877efc5215231b6c96c922386b209b78f6cb
parent da59a7cf209fafa7a3bd26bf9bfe7132b3088b0b
Author: Commit-Bot <unknown>
Date: Mon, 26 Apr 2010 22:48:52 +0000
Automatic commit from picoLisp.tgz, From: Mon, 26 Apr 2010 19:48:52 GMT
Diffstat:
15 files changed, 142 insertions(+), 47 deletions(-)
diff --git a/CHANGES b/CHANGES
@@ -1,4 +1,6 @@
* XXjun10 picoLisp-3.0.3
+ 'adr' function
+ 'dir' can also return '.'-files
* 30mar10 picoLisp-3.0.2
Simple incrementing form of 'for'
diff --git a/doc/ref.html b/doc/ref.html
@@ -2366,6 +2366,7 @@ abbreviations:
<a href="refA.html#alarm">alarm</a>
<a href="refP.html#protect">protect</a>
<a href="refH.html#heap">heap</a>
+ <a href="refA.html#adr">adr</a>
<a href="refE.html#env">env</a>
<a href="refU.html#up">up</a>
<a href="refD.html#date">date</a>
diff --git a/doc/refA.html b/doc/refA.html
@@ -21,6 +21,24 @@ href="refA.html#accept">accept</a></code>.
-> "127.0.0.1"
</code></pre>
+<dt><a name="adr"><code>(adr 'var) -> num</code></a>
+<dt><code>(adr 'num) -> var</code>
+<dd>Converts, in the first form, a variable <code>var</code> (a symbol or a
+cell) into <code>num</code> (a pointer). A symbol will result in a negative
+number, and a cell in a positive number. The second form converts a pointer back
+into the original <code>var</code>.
+
+<pre><code>
+: (setq X (box 7))
+-> $53063416137450
+: (adr X)
+-> -2961853431592
+: (adr @)
+-> $53063416137450
+: (val @)
+-> 7
+</code></pre>
+
<dt><a name="*Allow"><code>*Allow</code></a>
<dd>A global variable holding allowed access patterns. If its value is
non-<code>NIL</code>, it should contain a list where the CAR is an <code><a
diff --git a/doc/refD.html b/doc/refD.html
@@ -656,11 +656,11 @@ href="refE.html#equal/2">equal/2</a></code>.
-> T
</code></pre>
-<dt><a name="dir"><code>(dir ['any]) -> lst</code></a>
+<dt><a name="dir"><code>(dir ['any] ['flg]) -> lst</code></a>
<dd>Returns a list of all filenames in the directory <code>any</code>. Names
-starting with a dot '<code>.</code>' are ignored. See also <code><a
-href="refC.html#cd">cd</a></code> and <code><a
-href="refI.html#info">info</a></code>.
+starting with a dot '<code>.</code>' are ignored, unless <code>flg</code> is
+non-<code>NIL</code>. See also <code><a href="refC.html#cd">cd</a></code> and
+<code><a href="refI.html#info">info</a></code>.
<pre><code>
: (filter '((F) (tail '(. c) (chop F))) (dir "src/"))
diff --git a/doc/vim-tsm b/doc/vim-tsm
@@ -0,0 +1,28 @@
+26apr10abu
+(c) Software Lab. Alexander Burger
+
+
+ Transient Symbol Markup for 'vim'
+ =================================
+
+1. Compile 'vim' with Vince Negri's "Conceal" patch:
+ http://vim.wikia.com/wiki/Patch_to_conceal_parts_of_lines
+
+ patch -p0 < conceal-ownsyntax.diff
+ make distclean
+ ./configure --with-features=huge
+ make VIMRUNTIMEDIR=~/local/vim72/runtime MAKE="make -e"
+ cd ~/bin
+ ln -s ~/local/vim72/src/vim
+ ln vim vi
+ ln vim view
+
+
+2. Then put into your ".vimrc" or vim syntax file:
+
+ if has("conceal")
+ set conceallevel=2
+ syn region picoLispTransient concealends matchgroup=picoLispString start=/"/ skip=/\\\\\|\\"/ end=/"/
+ hi picoLispTransient gui=underline term=underline cterm=underline
+ hi picoLispString ctermfg=red guifg=red
+ endif
diff --git a/lib.l b/lib.l
@@ -1,4 +1,4 @@
-# 18mar10abu
+# 25apr10abu
# (c) Software Lab. Alexander Burger
(de task (Key . Prg)
@@ -337,7 +337,7 @@
(de show ("X" . @)
(let *Dbg NIL
- (setq "X" (apply get (rest) "X"))
+ (setq "X" (pass get "X"))
(when (sym? "X")
(print "X" (val "X"))
(prinl)
diff --git a/lib/led.l b/lib/led.l
@@ -1,4 +1,4 @@
-# 19apr10abu
+# 26apr10abu
# (c) Software Lab. Alexander Burger
# Line editor
@@ -390,7 +390,7 @@
(extract
'((X)
(and (pre? S X) (pack P X)) )
- (dir P) ) ) ) ) )
+ (dir P T) ) ) ) ) )
(setq "LPos" 1 "HPos" 0)
(_getLine "Line1" (or "skipFun" delim?))
(prinl (cdr *Tsm)) )
diff --git a/lib/tags b/lib/tags
@@ -25,15 +25,16 @@ $ (2662 . "@src64/flow.l")
>> (2293 . "@src64/big.l")
abs (2383 . "@src64/big.l")
accept (140 . "@src64/net.l")
+adr (511 . "@src64/main.l")
alarm (455 . "@src64/main.l")
all (772 . "@src64/sym.l")
and (1637 . "@src64/flow.l")
any (3750 . "@src64/io.l")
append (1329 . "@src64/subr.l")
apply (581 . "@src64/apply.l")
-arg (1858 . "@src64/main.l")
-args (1834 . "@src64/main.l")
-argv (2467 . "@src64/main.l")
+arg (1871 . "@src64/main.l")
+args (1847 . "@src64/main.l")
+argv (2492 . "@src64/main.l")
as (146 . "@src64/flow.l")
asoq (2938 . "@src64/subr.l")
assoc (2903 . "@src64/subr.l")
@@ -64,7 +65,7 @@ call (2793 . "@src64/flow.l")
car (5 . "@src64/subr.l")
case (1978 . "@src64/flow.l")
catch (2478 . "@src64/flow.l")
-cd (2234 . "@src64/main.l")
+cd (2247 . "@src64/main.l")
cdaaar (464 . "@src64/subr.l")
cdaadr (487 . "@src64/subr.l")
cdaar (179 . "@src64/subr.l")
@@ -86,7 +87,7 @@ chop (1093 . "@src64/sym.l")
circ (816 . "@src64/subr.l")
clip (1784 . "@src64/subr.l")
close (4137 . "@src64/io.l")
-cmd (2449 . "@src64/main.l")
+cmd (2474 . "@src64/main.l")
cnt (1279 . "@src64/apply.l")
commit (1503 . "@src64/db.l")
con (725 . "@src64/subr.l")
@@ -96,9 +97,9 @@ connect (202 . "@src64/net.l")
cons (747 . "@src64/subr.l")
copy (1216 . "@src64/subr.l")
ctl (4077 . "@src64/io.l")
-ctty (2259 . "@src64/main.l")
+ctty (2272 . "@src64/main.l")
cut (1795 . "@src64/sym.l")
-date (1973 . "@src64/main.l")
+date (1986 . "@src64/main.l")
dbck (2092 . "@src64/db.l")
de (551 . "@src64/flow.l")
dec (1991 . "@src64/big.l")
@@ -108,15 +109,15 @@ del (1850 . "@src64/sym.l")
delete (1392 . "@src64/subr.l")
delq (1443 . "@src64/subr.l")
diff (2561 . "@src64/subr.l")
-dir (2392 . "@src64/main.l")
+dir (2405 . "@src64/main.l")
dm (563 . "@src64/flow.l")
do (2152 . "@src64/flow.l")
e (2623 . "@src64/flow.l")
echo (4157 . "@src64/io.l")
-env (510 . "@src64/main.l")
+env (523 . "@src64/main.l")
eof (3308 . "@src64/io.l")
eol (3299 . "@src64/io.l")
-errno (1193 . "@src64/main.l")
+errno (1206 . "@src64/main.l")
eval (208 . "@src64/flow.l")
ext (4852 . "@src64/io.l")
ext? (1034 . "@src64/sym.l")
@@ -124,7 +125,7 @@ extern (900 . "@src64/sym.l")
extra (1280 . "@src64/flow.l")
extract (1084 . "@src64/apply.l")
fifo (1961 . "@src64/sym.l")
-file (2339 . "@src64/main.l")
+file (2352 . "@src64/main.l")
fill (3165 . "@src64/subr.l")
filter (1027 . "@src64/apply.l")
fin (2018 . "@src64/subr.l")
@@ -161,7 +162,7 @@ ifn (1878 . "@src64/flow.l")
in (3974 . "@src64/io.l")
inc (1924 . "@src64/big.l")
index (2609 . "@src64/subr.l")
-info (2296 . "@src64/main.l")
+info (2309 . "@src64/main.l")
intern (875 . "@src64/sym.l")
ipid (2905 . "@src64/flow.l")
isa (976 . "@src64/flow.l")
@@ -215,10 +216,10 @@ n== (2072 . "@src64/subr.l")
nT (2183 . "@src64/subr.l")
name (499 . "@src64/sym.l")
nand (1672 . "@src64/flow.l")
-native (1201 . "@src64/main.l")
+native (1214 . "@src64/main.l")
need (918 . "@src64/subr.l")
new (850 . "@src64/flow.l")
-next (1841 . "@src64/main.l")
+next (1854 . "@src64/main.l")
nil (1755 . "@src64/flow.l")
nond (1955 . "@src64/flow.l")
nor (1693 . "@src64/flow.l")
@@ -232,7 +233,7 @@ onOff (1611 . "@src64/sym.l")
one (1644 . "@src64/sym.l")
open (4099 . "@src64/io.l")
opid (2921 . "@src64/flow.l")
-opt (2570 . "@src64/main.l")
+opt (2595 . "@src64/main.l")
or (1653 . "@src64/flow.l")
out (3994 . "@src64/io.l")
pack (1144 . "@src64/sym.l")
@@ -265,9 +266,9 @@ push (1686 . "@src64/sym.l")
push1 (1722 . "@src64/sym.l")
put (2696 . "@src64/sym.l")
putl (2948 . "@src64/sym.l")
-pwd (2223 . "@src64/main.l")
+pwd (2236 . "@src64/main.l")
queue (1918 . "@src64/sym.l")
-quit (914 . "@src64/main.l")
+quit (927 . "@src64/main.l")
quote (141 . "@src64/flow.l")
rand (2627 . "@src64/big.l")
range (988 . "@src64/subr.l")
@@ -276,7 +277,7 @@ raw (433 . "@src64/main.l")
rd (4869 . "@src64/io.l")
read (2489 . "@src64/io.l")
replace (1490 . "@src64/subr.l")
-rest (1887 . "@src64/main.l")
+rest (1900 . "@src64/main.l")
reverse (1665 . "@src64/subr.l")
rewind (4835 . "@src64/io.l")
rollback (1885 . "@src64/db.l")
@@ -315,7 +316,7 @@ text (1270 . "@src64/sym.l")
throw (2504 . "@src64/flow.l")
tick (2873 . "@src64/flow.l")
till (3394 . "@src64/io.l")
-time (2106 . "@src64/main.l")
+time (2119 . "@src64/main.l")
touch (1049 . "@src64/sym.l")
trim (1746 . "@src64/subr.l")
try (1187 . "@src64/flow.l")
@@ -324,13 +325,13 @@ udp (269 . "@src64/net.l")
unify (3810 . "@src64/subr.l")
unless (1914 . "@src64/flow.l")
until (2098 . "@src64/flow.l")
-up (597 . "@src64/main.l")
+up (610 . "@src64/main.l")
upp? (3228 . "@src64/sym.l")
uppc (3292 . "@src64/sym.l")
use (1586 . "@src64/flow.l")
-usec (2211 . "@src64/main.l")
+usec (2224 . "@src64/main.l")
val (1461 . "@src64/sym.l")
-version (2584 . "@src64/main.l")
+version (2609 . "@src64/main.l")
wait (2973 . "@src64/io.l")
when (1897 . "@src64/flow.l")
while (2074 . "@src64/flow.l")
diff --git a/src/main.c b/src/main.c
@@ -1,4 +1,4 @@
-/* 22apr10abu
+/* 26apr10abu
* (c) Software Lab. Alexander Burger
*/
@@ -232,6 +232,15 @@ any doHeap(any x) {
return boxCnt(n / CELLS);
}
+// (adr 'var) -> num
+// (adr 'num) -> var
+any doAdr(any x) {
+ x = cdr(x);
+ if (isNum(x = EVAL(car(x))))
+ return (any)(unDig(x) * WORD);
+ return box(num(x) / WORD);
+}
+
// (env ['lst] | ['sym 'val] ..) -> lst
any doEnv(any x) {
int i;
@@ -996,32 +1005,33 @@ any doFile(any ex __attribute__((unused))) {
return Pop(c1);
}
-// (dir ['any]) -> lst
+// (dir ['any] ['flg]) -> lst
any doDir(any x) {
any y;
DIR *dp;
struct dirent *p;
cell c1;
- if (isNil(x = evSym(cdr(x))))
+ if (isNil(y = evSym(x = cdr(x))))
dp = opendir(".");
else {
- char nm[pathSize(x)];
+ char nm[pathSize(y)];
- pathString(x, nm);
+ pathString(y, nm);
dp = opendir(nm);
}
if (!dp)
return Nil;
+ x = cdr(x), x = EVAL(car(x));
do {
if (!(p = readdir(dp))) {
closedir(dp);
return Nil;
}
- } while (p->d_name[0] == '.');
+ } while (isNil(x) && p->d_name[0] == '.');
Push(c1, y = cons(mkStr(p->d_name), Nil));
while (p = readdir(dp))
- if (p->d_name[0] != '.')
+ if (!isNil(x) || p->d_name[0] != '.')
y = cdr(y) = cons(mkStr(p->d_name), Nil);
closedir(dp);
return Pop(c1);
diff --git a/src/pico.h b/src/pico.h
@@ -1,4 +1,4 @@
-/* 17mar10abu
+/* 26apr10abu
* (c) Software Lab. Alexander Burger
*/
@@ -398,6 +398,7 @@ void zapZero(any);
any doAbs(any);
any doAccept(any);
any doAdd(any);
+any doAdr(any);
any doAlarm(any);
any doAll(any);
any doAnd(any);
diff --git a/src/tab.c b/src/tab.c
@@ -1,4 +1,4 @@
-/* 14nov09abu
+/* 26apr10abu
* (c) Software Lab. Alexander Burger
*/
@@ -10,6 +10,7 @@ static symInit Symbols[] = {
{doAbs, "abs"},
{doAccept, "accept"},
{doAdd, "+"},
+ {doAdr, "adr"},
{doAlarm, "alarm"},
{doAll, "all"},
{doAnd, "and"},
diff --git a/src64/glob.l b/src64/glob.l
@@ -1,4 +1,4 @@
-# 17mar10abu
+# 26apr10abu
# (c) Software Lab. Alexander Burger
(data 'Globals 0)
@@ -123,6 +123,7 @@
initSym NIL "alarm" doAlarm
initSym NIL "protect" doProtect
initSym NIL "heap" doHeap
+ initSym NIL "adr" doAdr
initSym NIL "env" doEnv
initSym NIL "up" doUp
initSym NIL "quit" doQuit
diff --git a/src64/main.l b/src64/main.l
@@ -1,4 +1,4 @@
-# 17mar10abu
+# 26apr10abu
# (c) Software Lab. Alexander Burger
### Global return labels ###
@@ -506,6 +506,19 @@
or E CNT
ret
+# (adr 'var) -> num
+# (adr 'num) -> var
+(code 'doAdr 2)
+ ld E ((E CDR)) # Eval arg
+ eval
+ num E # 'num' argument?
+ if nz # Yes
+ off E 7 # Make 'var'
+ ret
+ end
+ or E CNT # Make 'num'
+ ret
+
# (env ['lst] | ['sym 'val] ..) -> lst
(code 'doEnv 2)
push X
@@ -2388,10 +2401,12 @@
end
ret
-# (dir ['any]) -> lst
+# (dir ['any] ['flg]) -> lst
(code 'doDir 2)
+ push X
push Z
- ld E ((E CDR)) # Get arg
+ ld X (E CDR) # Args
+ ld E (X) # Get 'any'
call evSymE_E # Evaluate to a symbol
cmp E Nil # NIL?
if eq # Yes
@@ -2404,15 +2419,22 @@
null A # OK?
jz 10 # No
ld Z A # Get directory pointer
+ ld X (X CDR) # Eval 'flg'
+ ld E (X)
+ eval
+ ld X E # into X
do
cc readdir(Z) # Find first directory entry
null A # OK?
if z # No
10 ld E Nil # Return NIL
pop Z
+ pop X
ret
end
lea E (A D_NAME) # Pointer to name entry
+ cmp X Nil # flg?
+ while eq # Yes
ld B (E) # First char
cmp B (char ".") # Skip dot names
until ne
@@ -2428,10 +2450,12 @@
null A # OK?
while nz # Yes
lea E (A D_NAME) # Pointer to name entry
+ cmp X Nil # flg?
+ jne 20 # Yes
ld B (E) # First char
cmp B (char ".") # Ignore dot names
if ne
- call mkStrE_E # Make transient symbol
+20 call mkStrE_E # Make transient symbol
call consE_A # Cons next cell
ld (A) E
ld (A CDR) Nil
@@ -2443,6 +2467,7 @@
drop
cc closedir(Z) # Close directory
pop Z
+ pop X
ret
# (cmd ['any]) -> sym
diff --git a/src64/version.l b/src64/version.l
@@ -1,6 +1,6 @@
-# 22apr10abu
+# 26apr10abu
# (c) Software Lab. Alexander Burger
-(de *Version 3 0 2 13)
+(de *Version 3 0 2 15)
# vi:et:ts=3:sw=3
diff --git a/test/src/main.l b/test/src/main.l
@@ -1,4 +1,4 @@
-# 31jan10abu
+# 26apr10abu
# (c) Software Lab. Alexander Burger
### alarm ###
@@ -19,6 +19,11 @@
(test "Quit" (catch '("Quit") (quit "Quit")))
+### adr ###
+(let (X (box 7) L (123))
+ (test 7 (val (adr (adr X))))
+ (test 123 (car (adr (adr L)))) )
+
### env ###
(test NIL (env))
(test '((A . 1) (B . 2))
@@ -82,11 +87,13 @@
### dir ###
(call 'mkdir "-p" (tmp "dir"))
+(out (tmp "dir/.abc"))
(out (tmp "dir/a"))
(out (tmp "dir/b"))
(out (tmp "dir/c"))
(test '("a" "b" "c") (sort (dir (tmp "dir"))))
+(test '("." ".." ".abc" "a" "b" "c") (sort (dir (tmp "dir") T)))
### cmd ###
