commit de4b23b6bd672871b6467fb62129399d2368e633
parent 71e19745e82a2f655f4ffdf1a240d1f764fe8a5a
Author: Commit-Bot <unknown>
Date: Thu, 23 Sep 2010 13:12:50 +0000
Automatic commit from picoLisp.tgz, From: Thu, 23 Sep 2010 13:12:50 GMT
Diffstat:
12 files changed, 346 insertions(+), 242 deletions(-)
diff --git a/CHANGES b/CHANGES
@@ -1,4 +1,5 @@
* XXsep10 picoLisp-3.0.4
+ Extended protocol for 'sync'
MIT/X11 License
Drag & Drop file upload
Generic 'lisp' C-callbacks
diff --git a/ReleaseNotes b/ReleaseNotes
@@ -1,4 +1,4 @@
-19sep10abu
+23sep10abu
(c) Software Lab. Alexander Burger
@@ -45,5 +45,9 @@ E. The license was changed from GPL to the MIT/X11 License with this release
F. The usage of the poll(2) system call in the 64-bit version was found to cause
errors. The database stress test in "misc/stress.l" occasionally indicated
- inconsistencies (for unknown reasons). Therefore, the 64-bit version is now -
- like the 32-bit version - based on select(2).
+ inconsistencies (for reasons which are not completely clear). Therefore, the
+ 64-bit version is now - like the 32-bit version - based on select(2). And,
+ both versions employ now a different strategy for syncing the communication
+ between child processes. This required a slight change in the semantics of
+ 'sync' and 'tell', which should, however, not have influence on normal
+ applications.
diff --git a/doc/faq.html b/doc/faq.html
@@ -37,6 +37,7 @@
<li><a href="#arrays">What about arrays?</a>
<li><a href="#bind">What happens when I locally bind a symbol which has a function definition?</a>
<li><a href="#hardware">Would it make sense to build PicoLisp in hardware?</a>
+<li><a href="#segfault">I get a segfault if I ...</a>
<li><a href="#ask">Where can I ask questions?</a>
</ul>
@@ -56,7 +57,8 @@ are the case-insensitivity and complexity of current Lisp systems.
<p>PicoLisp is for programmers who want to control their programming
environment, at all levels, from the application domain down to the bare metal.
Who want use a transparent and simple - yet universal - programming model, and
-want to know exactly what is going on. This is an aspect influenced by Forth.
+want to know exactly what is going on. This is an aspect influenced by
+<code>Forth</code>.
<p>It does <i>not</i> pretend to be easy to learn. There are already plenty of
languages that do so. It is not for people who don't care what's under the hood,
@@ -235,9 +237,9 @@ PicoLisp's somewhat inefficient implementation of bignums in the 32-bit version.
<p>But in practice, speed was never a problem, even with the first versions of
PicoLisp in 1988 on a Mac II with a 12 MHz CPU. And certain things are cleaner
-and easier to do in plain C anyway. It is very easy to write C functions in
-PicoLisp, either in the kernel, as shared object libraries, or even inline in
-the Lisp code.
+and easier to do in plain <code>C</code> anyway. It is very easy to write
+<code>C</code> functions in PicoLisp, either in the kernel, as shared object
+libraries, or even inline in the Lisp code.
<p>PicoLisp is very space-effective. Other Lisp systems reserve heap space twice
as much as needed, or use rather large internal structures to store cells and
@@ -423,7 +425,8 @@ dynamic context
</ol>
<p>This is a form of lexical <i>scoping</i> - though we still have dynamic
-<i>binding</i> - of symbols, similar to the <code>static</code> keyword in C.
+<i>binding</i> - of symbols, similar to the <code>static</code> keyword in
+<code>C</code>.
<p>In fact, these problems are a real threat, and may lead to mysterious bugs
(other Lisps have similar problems, e.g. with symbol capture in macros). They
@@ -638,7 +641,7 @@ prefetch" would look down the CAR- and CDR-chains, and perhaps need only a
single cache for both data and instructions.
<p>Primitive functions like <code>set</code>, <code>val</code>, <code>if</code>
-and <code>while</code>, which are written in <Code>C</code> or assembly language
+and <code>while</code>, which are written in <code>C</code> or assembly language
now, would be implemented in microcode. Plus a few I/O functions for hardware
access. <code>EVAL</code> itself would be a microcode subroutine.
@@ -651,6 +654,16 @@ microcode levels) are s-expressions: The machine language is <i>Lisp</i>.
<p><hr>
+<h2><a name="segfault">I get a segfault if I ...</a></h2>
+
+<p>PicoLisp is a pragmatic language. It doesn't check at runtime for all
+possible error conditions which won't occur during normal usage. Such errors are
+usually detected quickly at the first test run, and checking for them after that
+would just produce runtime overhead. It is recommended, though, to inspect the
+code periodically with <code><a <code><a href="refL.html#lint">lint</a></code>.
+
+
+<p><hr>
<h2><a name="ask">Where can I ask questions?</a></h2>
<p>The best place is the <a
diff --git a/doc/refS.html b/doc/refS.html
@@ -896,7 +896,16 @@ href="refE.html#ext?">ext?</a></code>.
still sending data (via the <code><a href="refT.html#tell">tell</a></code>
mechanism), a <code>select</code> system call is executed for all file
descriptors and timers in the <code>VAL</code> of the global variable <code><a
-href="refR.html#*Run">*Run</a></code>. See also <code><a
+href="refR.html#*Run">*Run</a></code>. When used in a non-database context,
+<code>(tell)</code> should be called in the end to inform the parent process
+that it may grant synchronization to other processes waiting for
+<code>sync</code>. In a database context, where <code>sync</code> is usually
+called by <code><a href="refD.html#dbSync">dbSync</a></code>, this is not
+necessary because it is done internally by <code><a
+href="refC.html#commit">commit</a></code> or <code><a
+href="refR.html#rollback">rollback</a></code>.
+
+See also <code><a
href="refK.html#key">key</a></code> and <code><a
href="refW.html#wait">wait</a></code>.
diff --git a/doc/refT.html b/doc/refT.html
@@ -209,8 +209,10 @@ href="refF.html#format">format</a></code>.
members (i.e. all children of the current process, and all other children of the
parent process, see <code><a href="refF.html#fork">fork</a></code>) for
automatic execution. <code>tell</code> can also be used by <code><a
-href="refC.html#commit">commit</a></code> to notify about database changes. See
-also <code><a href="refH.html#hear">hear</a></code>, <code><a
+href="refC.html#commit">commit</a></code> to notify about database changes. When
+called without arguments, no message is actually sent, and the parent process
+may grant <code><a href="refS.html#sync">sync</a></code> to the next waiting
+process. See also <code><a href="refH.html#hear">hear</a></code>, <code><a
href="refP.html#pid">pid</a></code> and <code><a
href="refR.html#rpc">rpc</a></code>.
diff --git a/lib/tags b/lib/tags
@@ -29,7 +29,7 @@ adr (613 . "@src64/main.l")
alarm (487 . "@src64/main.l")
all (772 . "@src64/sym.l")
and (1643 . "@src64/flow.l")
-any (3801 . "@src64/io.l")
+any (3841 . "@src64/io.l")
append (1329 . "@src64/subr.l")
apply (597 . "@src64/apply.l")
arg (2243 . "@src64/main.l")
@@ -82,11 +82,11 @@ cdddr (245 . "@src64/subr.l")
cddr (79 . "@src64/subr.l")
cdr (17 . "@src64/subr.l")
chain (1132 . "@src64/subr.l")
-char (3283 . "@src64/io.l")
+char (3323 . "@src64/io.l")
chop (1093 . "@src64/sym.l")
circ (816 . "@src64/subr.l")
clip (1786 . "@src64/subr.l")
-close (4189 . "@src64/io.l")
+close (4229 . "@src64/io.l")
cmd (2846 . "@src64/main.l")
cnt (1297 . "@src64/apply.l")
co (2566 . "@src64/flow.l")
@@ -97,11 +97,11 @@ cond (1938 . "@src64/flow.l")
connect (201 . "@src64/net.l")
cons (747 . "@src64/subr.l")
copy (1216 . "@src64/subr.l")
-ctl (4129 . "@src64/io.l")
+ctl (4169 . "@src64/io.l")
ctty (2644 . "@src64/main.l")
cut (1797 . "@src64/sym.l")
date (2358 . "@src64/main.l")
-dbck (2100 . "@src64/db.l")
+dbck (2102 . "@src64/db.l")
de (549 . "@src64/flow.l")
dec (2323 . "@src64/big.l")
def (473 . "@src64/flow.l")
@@ -114,13 +114,13 @@ dir (2777 . "@src64/main.l")
dm (561 . "@src64/flow.l")
do (2158 . "@src64/flow.l")
e (2932 . "@src64/flow.l")
-echo (4220 . "@src64/io.l")
+echo (4260 . "@src64/io.l")
env (625 . "@src64/main.l")
-eof (3360 . "@src64/io.l")
-eol (3351 . "@src64/io.l")
+eof (3400 . "@src64/io.l")
+eol (3391 . "@src64/io.l")
errno (1358 . "@src64/main.l")
eval (208 . "@src64/flow.l")
-ext (4949 . "@src64/io.l")
+ext (4989 . "@src64/io.l")
ext? (1034 . "@src64/sym.l")
extern (900 . "@src64/sym.l")
extra (1284 . "@src64/flow.l")
@@ -135,13 +135,13 @@ find (1206 . "@src64/apply.l")
fish (1497 . "@src64/apply.l")
flg? (2419 . "@src64/subr.l")
flip (1686 . "@src64/subr.l")
-flush (4924 . "@src64/io.l")
+flush (4964 . "@src64/io.l")
fold (3343 . "@src64/sym.l")
for (2247 . "@src64/flow.l")
fork (3276 . "@src64/flow.l")
format (2089 . "@src64/big.l")
-free (2042 . "@src64/db.l")
-from (3379 . "@src64/io.l")
+free (2044 . "@src64/db.l")
+from (3419 . "@src64/io.l")
full (1066 . "@src64/subr.l")
fun? (734 . "@src64/sym.l")
gc (439 . "@src64/gc.l")
@@ -153,14 +153,14 @@ glue (1234 . "@src64/sym.l")
gt0 (2702 . "@src64/big.l")
head (1807 . "@src64/subr.l")
heap (542 . "@src64/main.l")
-hear (3082 . "@src64/io.l")
+hear (3116 . "@src64/io.l")
host (184 . "@src64/net.l")
id (1027 . "@src64/db.l")
idx (2037 . "@src64/sym.l")
if (1824 . "@src64/flow.l")
if2 (1843 . "@src64/flow.l")
ifn (1884 . "@src64/flow.l")
-in (4025 . "@src64/io.l")
+in (4065 . "@src64/io.l")
inc (2256 . "@src64/big.l")
index (2611 . "@src64/subr.l")
info (2681 . "@src64/main.l")
@@ -169,21 +169,21 @@ ipid (3221 . "@src64/flow.l")
isa (978 . "@src64/flow.l")
job (1448 . "@src64/flow.l")
journal (970 . "@src64/db.l")
-key (3210 . "@src64/io.l")
+key (3250 . "@src64/io.l")
kill (3253 . "@src64/flow.l")
last (2031 . "@src64/subr.l")
length (2687 . "@src64/subr.l")
let (1498 . "@src64/flow.l")
let? (1559 . "@src64/flow.l")
lieu (1156 . "@src64/db.l")
-line (3535 . "@src64/io.l")
-lines (3688 . "@src64/io.l")
+line (3575 . "@src64/io.l")
+lines (3728 . "@src64/io.l")
link (1163 . "@src64/subr.l")
lisp (1921 . "@src64/main.l")
list (887 . "@src64/subr.l")
listen (151 . "@src64/net.l")
lit (183 . "@src64/flow.l")
-load (4002 . "@src64/io.l")
+load (4042 . "@src64/io.l")
lock (1184 . "@src64/db.l")
loop (2190 . "@src64/flow.l")
low? (3215 . "@src64/sym.l")
@@ -200,7 +200,7 @@ mapcar (871 . "@src64/apply.l")
mapcon (925 . "@src64/apply.l")
maplist (817 . "@src64/apply.l")
maps (674 . "@src64/apply.l")
-mark (1960 . "@src64/db.l")
+mark (1962 . "@src64/db.l")
match (3062 . "@src64/subr.l")
max (2314 . "@src64/subr.l")
maxi (1395 . "@src64/apply.l")
@@ -233,31 +233,31 @@ offset (2651 . "@src64/subr.l")
on (1583 . "@src64/sym.l")
onOff (1613 . "@src64/sym.l")
one (1646 . "@src64/sym.l")
-open (4151 . "@src64/io.l")
+open (4191 . "@src64/io.l")
opid (3237 . "@src64/flow.l")
opt (2967 . "@src64/main.l")
or (1659 . "@src64/flow.l")
-out (4045 . "@src64/io.l")
+out (4085 . "@src64/io.l")
pack (1144 . "@src64/sym.l")
pair (2381 . "@src64/subr.l")
pass (638 . "@src64/apply.l")
pat? (720 . "@src64/sym.l")
-path (1200 . "@src64/io.l")
-peek (3267 . "@src64/io.l")
+path (1221 . "@src64/io.l")
+peek (3307 . "@src64/io.l")
pick (1253 . "@src64/apply.l")
pid (157 . "@src64/flow.l")
-pipe (4066 . "@src64/io.l")
-poll (3154 . "@src64/io.l")
+pipe (4106 . "@src64/io.l")
+poll (3194 . "@src64/io.l")
pool (648 . "@src64/db.l")
pop (1773 . "@src64/sym.l")
port (5 . "@src64/net.l")
-pr (5040 . "@src64/io.l")
+pr (5080 . "@src64/io.l")
pre? (1411 . "@src64/sym.l")
-prin (4848 . "@src64/io.l")
-prinl (4862 . "@src64/io.l")
-print (4888 . "@src64/io.l")
-println (4919 . "@src64/io.l")
-printsp (4904 . "@src64/io.l")
+prin (4888 . "@src64/io.l")
+prinl (4902 . "@src64/io.l")
+print (4928 . "@src64/io.l")
+println (4959 . "@src64/io.l")
+printsp (4944 . "@src64/io.l")
prog (1779 . "@src64/flow.l")
prog1 (1787 . "@src64/flow.l")
prog2 (1804 . "@src64/flow.l")
@@ -276,15 +276,15 @@ rand (2959 . "@src64/big.l")
range (988 . "@src64/subr.l")
rank (2970 . "@src64/subr.l")
raw (465 . "@src64/main.l")
-rd (4966 . "@src64/io.l")
-read (2532 . "@src64/io.l")
+rd (5006 . "@src64/io.l")
+read (2553 . "@src64/io.l")
replace (1490 . "@src64/subr.l")
rest (2272 . "@src64/main.l")
reverse (1665 . "@src64/subr.l")
-rewind (4932 . "@src64/io.l")
-rollback (1886 . "@src64/db.l")
+rewind (4972 . "@src64/io.l")
+rollback (1887 . "@src64/db.l")
rot (848 . "@src64/subr.l")
-rpc (5073 . "@src64/io.l")
+rpc (5113 . "@src64/io.l")
run (331 . "@src64/flow.l")
sect (2515 . "@src64/subr.l")
seed (2944 . "@src64/big.l")
@@ -295,31 +295,31 @@ set (1482 . "@src64/sym.l")
setq (1515 . "@src64/sym.l")
sigio (503 . "@src64/main.l")
size (2752 . "@src64/subr.l")
-skip (3337 . "@src64/io.l")
+skip (3377 . "@src64/io.l")
sort (3869 . "@src64/subr.l")
sp? (711 . "@src64/sym.l")
-space (4866 . "@src64/io.l")
+space (4906 . "@src64/io.l")
split (1579 . "@src64/subr.l")
stack (571 . "@src64/main.l")
state (2028 . "@src64/flow.l")
stem (1976 . "@src64/subr.l")
-str (3855 . "@src64/io.l")
+str (3895 . "@src64/io.l")
str? (1013 . "@src64/sym.l")
strip (1563 . "@src64/subr.l")
sub? (1444 . "@src64/sym.l")
sum (1344 . "@src64/apply.l")
super (1237 . "@src64/flow.l")
-sym (3841 . "@src64/io.l")
+sym (3881 . "@src64/io.l")
sym? (2408 . "@src64/subr.l")
-sync (3044 . "@src64/io.l")
+sync (3076 . "@src64/io.l")
sys (3073 . "@src64/flow.l")
t (1770 . "@src64/flow.l")
tail (1898 . "@src64/subr.l")
-tell (3114 . "@src64/io.l")
+tell (3148 . "@src64/io.l")
text (1272 . "@src64/sym.l")
throw (2510 . "@src64/flow.l")
tick (3189 . "@src64/flow.l")
-till (3446 . "@src64/io.l")
+till (3486 . "@src64/io.l")
time (2491 . "@src64/main.l")
touch (1049 . "@src64/sym.l")
trim (1746 . "@src64/subr.l")
@@ -336,12 +336,12 @@ use (1592 . "@src64/flow.l")
usec (2596 . "@src64/main.l")
val (1463 . "@src64/sym.l")
version (2981 . "@src64/main.l")
-wait (3006 . "@src64/io.l")
+wait (3038 . "@src64/io.l")
when (1903 . "@src64/flow.l")
while (2080 . "@src64/flow.l")
wipe (3090 . "@src64/sym.l")
with (1349 . "@src64/flow.l")
-wr (5057 . "@src64/io.l")
+wr (5097 . "@src64/io.l")
xchg (1538 . "@src64/sym.l")
xor (1720 . "@src64/flow.l")
x| (2871 . "@src64/big.l")
diff --git a/src/io.c b/src/io.c
@@ -1,4 +1,4 @@
-/* 21sep10abu
+/* 23sep10abu
* (c) Software Lab. Alexander Burger
*/
@@ -19,6 +19,7 @@ static char Delim[] = " \t\n\r\"'(),[]`~{}";
static int StrI;
static cell StrCell, *StrP;
static bool Sync;
+static pid_t Talking;
static byte *PipeBuf, *PipePtr;
static void (*PutSave)(int);
static byte TBuf[] = {INTERN+4, 'T'};
@@ -185,6 +186,14 @@ bool wrBytes(int fd, byte *p, int cnt) {
}
}
+static void clsChild(int i) {
+ if (Child[i].pid == Talking)
+ Talking = 0;
+ Child[i].pid = 0;
+ close(Child[i].hear), close(Child[i].tell);
+ free(Child[i].buf);
+}
+
static void wrChild(int i, byte *p, int cnt) {
int n;
@@ -198,9 +207,7 @@ static void wrChild(int i, byte *p, int cnt) {
else if (errno == EAGAIN)
break;
else if (errno == EPIPE || errno == ECONNRESET) {
- Child[i].pid = 0;
- close(Child[i].hear), close(Child[i].tell);
- free(Child[i].buf);
+ clsChild(i);
return;
}
else if (errno != EINTR)
@@ -461,6 +468,14 @@ static void tellEnd(ptr *pb, ptr *pp) {
PipePtr = *pp, PipeBuf = *pb;
}
+static void unsync(void) {
+ int n = 0;
+
+ if (Tell && !wrBytes(Tell, (byte*)&n, sizeof(int)))
+ close(Tell), Tell = 0;
+ Sync = NO;
+}
+
static any rdHear(void) {
any x;
inFile *iSave = InFile;
@@ -1300,7 +1315,6 @@ long waitFd(any ex, int fd, long ms) {
cell c1, c2, c3;
int i, j, m, n;
long t;
- bool flg;
fd_set rdSet, wrSet;
struct timeval *tp, tv;
#ifndef __linux__
@@ -1354,16 +1368,16 @@ long waitFd(any ex, int fd, long ms) {
FD_SET(Spkr, &rdSet);
if (Spkr > m)
m = Spkr;
- }
- for (i = 0; i < Children; ++i) {
- if (Child[i].pid) {
- FD_SET(Child[i].hear, &rdSet);
- if (Child[i].hear > m)
- m = Child[i].hear;
- if (Child[i].cnt) {
- FD_SET(Child[i].tell, &wrSet);
- if (Child[i].tell > m)
- m = Child[i].tell;
+ for (i = 0; i < Children; ++i) {
+ if (Child[i].pid) {
+ FD_SET(Child[i].hear, &rdSet);
+ if (Child[i].hear > m)
+ m = Child[i].hear;
+ if (Child[i].cnt) {
+ FD_SET(Child[i].tell, &wrSet);
+ if (Child[i].tell > m)
+ m = Child[i].tell;
+ }
}
}
}
@@ -1393,48 +1407,58 @@ long waitFd(any ex, int fd, long ms) {
if (ms > 0 && (ms -= t) < 0)
ms = 0;
}
- for (flg = NO, i = 0; i < Children; ++i) {
- if (Child[i].pid) {
- if (FD_ISSET(Child[i].hear, &rdSet)) {
- if ((m = rdBytes(Child[i].hear, (byte*)&n, sizeof(int), YES)) >= 0) {
- byte buf[PIPE_BUF - sizeof(int)];
-
- if (m && rdBytes(Child[i].hear, buf, n, NO)) {
- for (flg = YES, j = 0; j < Children; ++j)
- if (j != i && Child[j].pid)
- wrChild(j, buf, n);
- }
- else {
- Child[i].pid = 0;
- close(Child[i].hear), close(Child[i].tell);
- free(Child[i].buf);
- continue;
+ if (Spkr) {
+ ++Env.protect;
+ for (i = 0; i < Children; ++i) {
+ if (Child[i].pid) {
+ if (FD_ISSET(Child[i].hear, &rdSet)) {
+ if ((m = rdBytes(Child[i].hear, (byte*)&n, sizeof(int), YES)) >= 0) {
+ byte buf[PIPE_BUF - sizeof(int)];
+
+ if (m == 0) {
+ clsChild(i);
+ continue;
+ }
+ if (n == 0) {
+ if (Child[i].pid == Talking)
+ Talking = 0;
+ }
+ else if (rdBytes(Child[i].hear, buf, n, NO)) {
+ for (j = 0; j < Children; ++j)
+ if (j != i && Child[j].pid)
+ wrChild(j, buf, n);
+ }
+ else {
+ clsChild(i);
+ continue;
+ }
}
}
- }
- if (FD_ISSET(Child[i].tell, &wrSet)) {
- n = *(int*)(Child[i].buf + Child[i].ofs);
- if (wrBytes(Child[i].tell, Child[i].buf + Child[i].ofs + sizeof(int), n)) {
- Child[i].ofs += sizeof(int) + n;
- if (2 * Child[i].ofs >= Child[i].cnt) {
- if (Child[i].cnt -= Child[i].ofs) {
- memcpy(Child[i].buf, Child[i].buf + Child[i].ofs, Child[i].cnt);
- Child[i].buf = alloc(Child[i].buf, Child[i].cnt);
+ if (FD_ISSET(Child[i].tell, &wrSet)) {
+ n = *(int*)(Child[i].buf + Child[i].ofs);
+ if (wrBytes(Child[i].tell, Child[i].buf + Child[i].ofs + sizeof(int), n)) {
+ Child[i].ofs += sizeof(int) + n;
+ if (2 * Child[i].ofs >= Child[i].cnt) {
+ if (Child[i].cnt -= Child[i].ofs) {
+ memcpy(Child[i].buf, Child[i].buf + Child[i].ofs, Child[i].cnt);
+ Child[i].buf = alloc(Child[i].buf, Child[i].cnt);
+ }
+ Child[i].ofs = 0;
}
- Child[i].ofs = 0;
}
- }
- else {
- Child[i].pid = 0;
- close(Child[i].hear), close(Child[i].tell);
- free(Child[i].buf);
+ else
+ clsChild(i);
}
}
}
+ if (!Talking && FD_ISSET(Spkr,&rdSet) &&
+ rdBytes(Spkr, (byte*)&m, sizeof(int), YES) > 0 &&
+ Child[m].pid ) {
+ Talking = Child[m].pid;
+ wrChild(m, TBuf, sizeof(TBuf));
+ }
+ --Env.protect;
}
- if (!flg && Spkr && FD_ISSET(Spkr,&rdSet) &&
- rdBytes(Spkr, (byte*)&m, sizeof(int), YES) > 0 && Child[m].pid )
- wrChild(m, TBuf, sizeof(TBuf));
if (Hear && Hear != fd && isSet(Hear, &rdSet)) {
if ((data(c3) = rdHear()) == NULL)
close(Hear), closeInFile(Hear), closeOutFile(Hear), Hear = 0;
@@ -1494,6 +1518,8 @@ any doSync(any ex) {
if (!Mic || !Hear)
return Nil;
+ if (Sync)
+ return T;
p = (byte*)&Slot;
cnt = sizeof(int);
for (;;) {
@@ -1538,10 +1564,14 @@ any doTell(any x) {
if (!Tell && !Children)
return Nil;
+ if (!isCell(x = cdr(x))) {
+ unsync();
+ return Nil;
+ }
tellBeg(&pbSave, &ppSave, buf);
do
- x = cdr(x), prTell(y = EVAL(car(x)));
- while (isCell(cdr(x)));
+ prTell(y = EVAL(car(x)));
+ while (isCell(x = cdr(x)));
tellEnd(&pbSave, &ppSave);
return y;
}
@@ -3426,6 +3456,7 @@ any doCommit(any ex) {
truncErr(ex);
}
rwUnlock(0); // Unlock all
+ unsync();
if (!Log)
--Env.protect;
for (F = 0; F < Files; ++F)
@@ -3453,6 +3484,7 @@ any doRollback(any x) {
if (isCell(x = val(Zap)))
car(x) = Nil;
rwUnlock(0); // Unlock all
+ unsync();
return T;
}
diff --git a/src/pico.h b/src/pico.h
@@ -1,4 +1,4 @@
-/* 21jul10abu
+/* 23sep10abu
* (c) Software Lab. Alexander Burger
*/
@@ -63,7 +63,7 @@ typedef struct heap {
} heap;
typedef struct child {
- int pid;
+ pid_t pid;
int hear, tell;
int ofs, cnt;
byte *buf;
diff --git a/src64/db.l b/src64/db.l
@@ -1,4 +1,4 @@
-# 15sep10abu
+# 23sep10abu
# (c) Software Lab. Alexander Burger
# 6 bytes in little endian format
@@ -1864,6 +1864,7 @@
end
ld A 0 # Length
call rwUnlockDbA # Unlock all
+ call unsync # Release sync
null (DbLog) # Transaction log?
if z # No
dec (EnvProtect) # Unprotect
@@ -1951,6 +1952,7 @@
end
ld A 0 # Length
call rwUnlockDbA # Unlock all
+ call unsync # Release sync
pop Y
pop X
ld E TSym # Return T
diff --git a/src64/glob.l b/src64/glob.l
@@ -1,4 +1,4 @@
-# 06sep10abu
+# 23sep10abu
# (c) Software Lab. Alexander Burger
(data 'Globals 0)
@@ -37,6 +37,7 @@
: Hear word 0 # RPC listener
: Tell word 0 # RPC broadcaster
: TellBuf word 0 # RPC buffer
+: Talking word 0 # Active child
: Children word 0 # Scaled number of children
: Child word 0 # Child array
: ExtN word 0 # External symbol offset
diff --git a/src64/io.l b/src64/io.l
@@ -1,4 +1,4 @@
-# 17sep10abu
+# 23sep10abu
# (c) Software Lab. Alexander Burger
# Close file descriptor
@@ -335,6 +335,10 @@
loop
(code 'clsChildY 0)
+ cmp (Y) (Talking) # Currently active?
+ if eq # Yes
+ ld (Talking) 0 # Clear
+ end
ld (Y) 0 # Clear 'pid'
cc close((Y I)) # Close 'hear'
cc close((Y II)) # and 'tell'
@@ -1028,6 +1032,23 @@
pop X
ret
+(code 'unsync 0) # X
+ ld C (Tell) # File descriptor
+ null C # Any?
+ if nz # Yes
+ push 0 # Send zero
+ ld X S # Get buffer
+ ld E 2 # Size
+ call wrBytesCEX_F # Write buffer to pipe
+ if nz # Not successful
+ cc close(C) # Close 'Tell'
+ ld (Tell) 0 # Clear 'Tell'
+ end
+ add S I # Drop buffer
+ end
+ set (Sync) 0 # Clear sync flag
+ ret
+
(code 'rdHear_FE)
push Z
ld A (Hear) # Get 'hear' fd
@@ -2645,7 +2666,7 @@
push C # <L -I> File descriptor
push E # <L -II> Milliseconds
push E # <L -III> Timeout
- sub S (+ II FD_SET FD_SET) # <L -IV> Microseconds, Drain
+ sub S (+ II FD_SET FD_SET) # <L -IV> Microseconds
# <L -V> Seconds
# <L - (V + FD_SET)> RdSet
# <L - (V + FD_SET - FD_SET)> WrSet
@@ -2727,24 +2748,24 @@
null C
if nz # Yes
call fdRdSetCZL
- end
- ld Y (Child) # Iterate children
- ld E (Children) # Count
- do
- sub E VI # More?
- while ge # Yes
- null (Y) # 'pid'?
- if nz # Yes
- ld C (Y I) # Child's 'hear' fd
- call fdRdSetCZL
- null (Y IV) # Child's buffer count?
+ ld Y (Child) # Iterate children
+ ld E (Children) # Count
+ do
+ sub E VI # More?
+ while ge # Yes
+ null (Y) # 'pid'?
if nz # Yes
- ld C (Y II) # Child's 'tell' fd
- call fdWrSetCZL
+ ld C (Y I) # Child's 'hear' fd
+ call fdRdSetCZL
+ null (Y IV) # Child's buffer count?
+ if nz # Yes
+ ld C (Y II) # Child's 'tell' fd
+ call fdWrSetCZL
+ end
end
- end
- add Y VI # Increment by sizeof(child)
- loop
+ add Y VI # Increment by sizeof(child)
+ loop
+ end
pop X # Restore context
inc Z # Maximum fd + 1
ld C 0 # Timeval structure pointer
@@ -2778,108 +2799,116 @@
call msec_A # Get milliseconds
sub A E # Time difference
ld (L -III) A # Save it
- set (L -IV) 0 # Guarantee drained pipes
- ld Y (Child) # Iterate children
- ld Z (Children) # Count
- push X # Save context again
- do
- sub Z VI # More?
- while ge # Yes
- null (Y) # 'pid'?
- if nz # Yes
- push Z # Outer loop count
- ld C (Y I) # Get child's 'hear' fd
- call rdSetCL_F # Ready?
+ null (Spkr) # Speaker open?
+ if nz # Yes
+ inc (EnvProtect) # Protect child communication
+ ld Y (Child) # Iterate children
+ ld Z (Children) # Count
+ push X # Save context again
+ do
+ sub Z VI # More?
+ while ge # Yes
+ null (Y) # 'pid'?
if nz # Yes
- ld C (Y I) # Get 'hear' fd again
- ld E 2 # Size of count
- ld X Buf # Buffer pointer
- call rdBytesNbCEX_F # Read count?
- if ge # Yes
- if z
- call clsChildY # Close child
- jmp 20 # Continue
- end
- sub S PIPE_BUF # <S I> Pipe buffer
- push Y # <S> Outer child index
+ push Z # Outer loop count
+ ld C (Y I) # Get child's 'hear' fd
+ call rdSetCL_F # Ready?
+ if nz # Yes
ld C (Y I) # Get 'hear' fd again
- ld2 (Buf) # Get size
- ld E A
- lea X (S I) # Buffer pointer
- call rdBytesCEX_F # Read data?
- if nz # Yes
- set (L -IV) 1 # Still got data from pipe
- ld Y (Child) # Iterate children
- ld Z (Children) # Count
- do
- cmp Y (S) # Same as outer loop child?
- if ne # No
- null (Y) # 'pid'?
- if nz # Yes
- ld2 (Buf) # Get size
- ld C A
- lea X (S I) # and data
- call wrChildCXY # Write to child
- end
+ ld E 2 # Size of count
+ ld X Buf # Buffer pointer
+ call rdBytesNbCEX_F # Read count?
+ if ge # Yes
+ if z
+ call clsChildY # Close child
+ jmp 20 # Continue
+ end
+ ld2 (Buf) # Size?
+ null A
+ if z # No
+ cmp (Y) (Talking) # Currently active?
+ if eq # Yes
+ ld (Talking) 0 # Clear
end
- add Y VI # Increment by sizeof(child)
- sub Z VI # More?
- until z # No
- else
- call clsChildY # Close child
- pop Y
- add S PIPE_BUF # Drop 'tell' buffer
- jmp 20 # Continue
+ else
+ sub S PIPE_BUF # <S I> Pipe buffer
+ push Y # <S> Outer child index
+ ld C (Y I) # Get 'hear' fd again
+ ld2 (Buf) # Get size
+ ld E A
+ lea X (S I) # Buffer pointer
+ call rdBytesCEX_F # Read data?
+ if nz # Yes
+ ld Y (Child) # Iterate children
+ ld Z (Children) # Count
+ do
+ cmp Y (S) # Same as outer loop child?
+ if ne # No
+ null (Y) # 'pid'?
+ if nz # Yes
+ ld2 (Buf) # Get size
+ ld C A
+ lea X (S I) # and data
+ call wrChildCXY # Write to child
+ end
+ end
+ add Y VI # Increment by sizeof(child)
+ sub Z VI # More?
+ until z # No
+ else
+ call clsChildY # Close child
+ pop Y
+ add S PIPE_BUF # Drop 'tell' buffer
+ jmp 20 # Continue
+ end
+ pop Y
+ add S PIPE_BUF # Drop 'tell' buffer
+ end
end
- pop Y
- add S PIPE_BUF # Drop 'tell' buffer
end
- end
- ld C (Y II) # Get child's 'tell' fd
- call wrSetCL_F # Ready?
- if nz # Yes
- ld C (Y II) # Get 'tell' fd again
- ld X (Y V) # Get buffer pointer
- add X (Y III) # plus buffer offset
- ld2 (X) # Get size
- ld E A
- add X 2 # Point to data (beyond size)
- push E # Keep size
- call wrBytesCEX_F # Write data?
- pop E
- if z # Yes
- add E (Y III) # Add size to buffer offset
- add E 2 # plus size of size
- ld (Y III) E # New buffer offset
- add E E # Twice the offset
- cmp E (Y IV) # greater or equal to buffer count?
- if ge # Yes
- sub (Y IV) (Y III) # Decrement count by offset
- if nz
- ld X (Y V) # Get buffer pointer
- add X (Y III) # Add buffer offset
- movn ((Y V)) (X) (Y IV) # Copy data
- ld A (Y V) # Get buffer pointer
- ld E (Y IV) # and new count
- call allocAE_A # Shrink buffer
- ld (Y V) A # Store
+ ld C (Y II) # Get child's 'tell' fd
+ call wrSetCL_F # Ready?
+ if nz # Yes
+ ld C (Y II) # Get 'tell' fd again
+ ld X (Y V) # Get buffer pointer
+ add X (Y III) # plus buffer offset
+ ld2 (X) # Get size
+ ld E A
+ add X 2 # Point to data (beyond size)
+ push E # Keep size
+ call wrBytesCEX_F # Write data?
+ pop E
+ if z # Yes
+ add E (Y III) # Add size to buffer offset
+ add E 2 # plus size of size
+ ld (Y III) E # New buffer offset
+ add E E # Twice the offset
+ cmp E (Y IV) # greater or equal to buffer count?
+ if ge # Yes
+ sub (Y IV) (Y III) # Decrement count by offset
+ if nz
+ ld X (Y V) # Get buffer pointer
+ add X (Y III) # Add buffer offset
+ movn ((Y V)) (X) (Y IV) # Copy data
+ ld A (Y V) # Get buffer pointer
+ ld E (Y IV) # and new count
+ call allocAE_A # Shrink buffer
+ ld (Y V) A # Store
+ end
+ ld (Y III) 0 # Clear buffer offset
end
- ld (Y III) 0 # Clear buffer offset
+ else
+ call clsChildY # Close child
end
- else
- call clsChildY # Close child
end
+20 pop Z
end
-20 pop Z
- end
- add Y VI # Increment by sizeof(child)
- loop
- nul (L -IV) # All pipes drained?
- if z # Yes
- ld C (Spkr) # Speaker open?
- null C
- if nz # Yes
- call rdSetCL_F # Ready?
+ add Y VI # Increment by sizeof(child)
+ loop
+ null (Talking) # Ready to sync?
+ if z # Yes
+ ld C (Spkr) # Get speaker
+ call rdSetCL_F # Anybody?
if nz # Yes
ld C (Spkr) # Get fd
ld E I # Size of slot
@@ -2888,8 +2917,10 @@
if gt # Yes
ld Y (Child) # Get child
add Y (Buf) # in slot
- null (Y) # 'pid'?
+ ld A (Y) # 'pid'?
+ null A
if nz # Yes
+ ld (Talking) A # Set to talking
ld C 2 # Size of 'TBuf'
ld X TBuf # Buffer pointer
call wrChildCXY # Write to child
@@ -2897,6 +2928,7 @@
end
end
end
+ dec (EnvProtect)
end
ld C (Hear) # RPC listener?
null C
@@ -3046,6 +3078,8 @@
jz retNil # Yes
null (Hear) # No 'hear' channel?
jz retNil # Yes
+ nul (Sync) # Already synchronized?
+ jnz retT # Yes
push X
ld X E
ld E Slot # Buffer pointer
@@ -3118,23 +3152,29 @@
push X
push Y
push Z
- push (TellBuf) # Save current 'tell' env
- sub S PIPE_BUF # New 'tell' buffer
- ld Z S # Buffer pointer
- call tellBegZ_Z # Start 'tell' message
ld X (E CDR) # Args
- do
- ld E (X) # Eval next
- eval
- ld Y E # Keep result
- call prTellEZ # Print to 'tell'
- ld X (X CDR) # More args?
- atom X
- until nz # No
- call tellEndZ # Close 'tell'
- ld E Y # Get result
- add S PIPE_BUF # Drop 'tell' buffer
- pop (TellBuf)
+ atom X # Any?
+ if nz # No
+ call unsync # Release sync
+ ld E Nil # Return NIL
+ else
+ push (TellBuf) # Save current 'tell' env
+ sub S PIPE_BUF # New 'tell' buffer
+ ld Z S # Buffer pointer
+ call tellBegZ_Z # Start 'tell' message
+ do
+ ld E (X) # Eval next
+ eval
+ ld Y E # Keep result
+ call prTellEZ # Print to 'tell'
+ ld X (X CDR) # More args?
+ atom X
+ until nz # No
+ call tellEndZ # Close 'tell'
+ add S PIPE_BUF # Drop 'tell' buffer
+ pop (TellBuf)
+ ld E Y # Get result
+ end
pop Z
pop Y
pop X
diff --git a/src64/version.l b/src64/version.l
@@ -1,6 +1,6 @@
-# 21sep10abu
+# 23sep10abu
# (c) Software Lab. Alexander Burger
-(de *Version 3 0 3 23)
+(de *Version 3 0 3 24)
# vi:et:ts=3:sw=3
