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 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:
MCHANGES | 1+
MReleaseNotes | 10+++++++---
Mdoc/faq.html | 25+++++++++++++++++++------
Mdoc/refS.html | 11++++++++++-
Mdoc/refT.html | 6++++--
Mlib/tags | 90++++++++++++++++++++++++++++++++++++++++----------------------------------------
Msrc/io.c | 134+++++++++++++++++++++++++++++++++++++++++++++++++------------------------------
Msrc/pico.h | 4++--
Msrc64/db.l | 4+++-
Msrc64/glob.l | 3++-
Msrc64/io.l | 296+++++++++++++++++++++++++++++++++++++++++++++----------------------------------
Msrc64/version.l | 4++--
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