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 c6390a85d49211bff5f9b0d14b34c5ee0b2d7e1b
parent 87318d11b07e03ed99a046e3aa60dcd60f7eba97
Author: Commit-Bot <unknown>
Date:   Tue, 25 Jan 2011 15:04:57 +0000

Automatic commit from picoLisp.tgz, From: Tue, 25 Jan 2011 15:04:57 GMT
Diffstat:
D.hgignore | 6------
MCHANGES | 11++++++++++-
MINSTALL | 39+++++++++++++++++++++------------------
MReleaseNotes | 43+++++++++++++++++++++++++++++--------------
Mdbg | 2+-
Mdbg.l | 8+-------
Mdoc/app.html | 11+++--------
Mdoc/faq.html | 7+++----
Mdoc/ref.html | 127++++++++++++++++++++++++++++++++++++++++++-------------------------------------
Mdoc/refA.html | 8++++----
Mdoc/refB.html | 17+++++++++++++++++
Mdoc/refC.html | 5+++--
Mdoc/refD.html | 6++++--
Mdoc/refF.html | 17++++++++++++++---
Mdoc/refG.html | 10++++++----
Mdoc/refH.html | 34++++++++++++++++++----------------
Mdoc/refI.html | 1+
Mdoc/refJ.html | 2+-
Mdoc/refK.html | 4++--
Mdoc/refL.html | 28+++++++++++++++++++++++-----
Mdoc/refN.html | 1+
Mdoc/refO.html | 12++++++++----
Mdoc/refP.html | 4++--
Mdoc/refQ.html | 2+-
Mdoc/refR.html | 7+++++--
Mdoc/refW.html | 22+++++++++++-----------
Mdoc/ref_.html | 1+
Mdoc/select.html | 2+-
Mdoc/tinymce | 9+++++----
Mdoc/tut.html | 17+++++++----------
Mersatz/README | 9+++++++--
Mersatz/fun.src | 6+++++-
Mersatz/lib.l | 663++++++++++++++++++++++++++++++++++++++++---------------------------------------
Mersatz/picolisp.jar | 0
Mersatz/sys.src | 61++++++++++++++++++++++++++++++++++++++-----------------------
Mlib.l | 65++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++-
Mlib/debug.l | 20+-------------------
Mlib/form.l | 4++--
Mlib/frac.l | 6++----
Mlib/http.l | 11+++++++----
Mlib/led.l | 4++--
Mlib/misc.l | 104++++++++++++++++++++++++++++++-------------------------------------------------
Mlib/pilog.l | 5++++-
Mlib/tags | 169++++++++++++++++++++++++++++++++++++++++---------------------------------------
Mlib/test.l | 6++----
Alib/tsm.l | 10++++++++++
Mplmod | 2+-
Mplmod.l | 6+++---
Msrc/big.c | 8+++++++-
Msrc/io.c | 53+++++++++++++++++++++++++++--------------------------
Msrc/main.c | 23++++++++++-------------
Msrc/pico.h | 3++-
Msrc/subr.c | 30++++++++++++++++++++----------
Msrc/tab.c | 3++-
Msrc64/apply.l | 10+++++-----
Msrc64/arch/x86-64.l | 17+++++------------
Msrc64/big.l | 16+++++++++++++++-
Msrc64/flow.l | 21++++++++++++++++++---
Msrc64/glob.l | 3++-
Msrc64/io.l | 97++++++++++++++++++++++++++++++++++++++++++-------------------------------------
Msrc64/main.l | 55++++++++++++++++++++++++-------------------------------
Msrc64/subr.l | 40+++++++++++++++++++++++++++++++++++-----
Msrc64/version.l | 4++--
Mtest/lib/misc.l | 12+++++++++++-
Mtest/src/big.l | 8+++++++-
Mtest/src/subr.l | 6+++++-
66 files changed, 1128 insertions(+), 895 deletions(-)

diff --git a/.hgignore b/.hgignore @@ -1,6 +0,0 @@ -syntax: glob -*.s -*~ -\#*\# -.\#* -*.o diff --git a/CHANGES b/CHANGES @@ -1,4 +1,13 @@ -* XXdec10 picoLisp-3.0.5 +* XXmar11 picoLisp-3.0.6 + 'fill' handles '^' + 'le0' function + Interpreter not exited upon <enter> + '*Tsm' by default off, moved to "lib/tsm.l" + Command line '+' debug flag + 'round' defaults to 3 + +* 31dec10 picoLisp-3.0.5 + 'bin' function 'prior' function 'circ?' function Ersatz PicoLisp (Java) version diff --git a/INSTALL b/INSTALL @@ -1,4 +1,4 @@ -17nov10abu +21jan11abu (c) Software Lab. Alexander Burger @@ -63,20 +63,32 @@ Please follow these steps: # ln -s /<installdir> /usr/lib/picolisp # ln -s /usr/lib/picolisp/bin/picolisp /usr/bin/picolisp - In that case, you might also copy the script bin/pil to /usr/bin, for a - convenient global invocation. + and a copy of the startup script + + # cp /<installdir>/bin/pil /usr/bin + + for a convenient global invocation. 'pil' can also serve as a template for + your own stand-alone scripts. Invocation ---------- -The shell script 'dbg' is usually called to start up PicoLisp in interactive -debugging mode +The shell script 'dbg' is usually called to start up a local PicoLisp in +interactive debugging mode $ ./dbg : -The colon ':' is PicoLisp's prompt. You may enter some Lisp expression, +In a global installation, the equivalent call is + + $ pil + + : + +(Note the trailing '+' for the debugging mode) + +In both cases, the colon ':' is PicoLisp's prompt. You may enter some Lisp +expression, : (+ 1 2 3) -> 6 @@ -85,25 +97,16 @@ To exit the interpreter, enter : (bye) -or simply type an empy line (Return). +or just type Ctrl-D. If you just want to test the ready-to-run Ersatz PicoLisp (it needs a Java runtime system), use - $ ersatz/picolisp + $ ersatz/picolisp + : -instead of 'dbg'. - - - Console Underlines - ================== - -In case that your console (terminal) does not support underlining, you might -want to remove or replace the first statement int "ext.l" which uses the -terminfo database to initialize the global variable '*Tsm' (transient symbol -markup). Unfortunately, the VGA text mode does not properly support underlines. +instead of 'dbg' (or 'pil +'). Documentation diff --git a/ReleaseNotes b/ReleaseNotes @@ -1,23 +1,38 @@ -02dec10abu +25jan11abu (c) Software Lab. Alexander Burger - Release Notes for picoLisp-3.0.5 + Release Notes for picoLisp-3.0.6 ================================ -A. The 'pid' function was removed. This was announced in the previous version, - and in the mailing list in +1. On the command line, debug mode can now enabled by appending a single '+' as + the very last argument. This '+' will not be seen by the application, but + switches on '*Dbg' before any other command line argument is processed. - http://www.mail-archive.com/picolisp@software-lab.de/msg01949.html + So the following three commands are equivalent: -B. "Ersatz PicoLisp" (written in Java) was included for a first evaluation. For - further informations, please look at "ersatz/README". + $ ./dbg myApp.l -main -C. The pre-generated "*.s" files for the 64-bit version are no longer part of - the release. They are rather large, and would multiply when further - architectures and operating systems are supported. Instead, they may - initially be generated with Ersatz PicoLisp, or downloaded from - "http://software-lab.de/x86-64.linux.tgz". + $ ./p myApp.l -main + -D. The 'easter' function in "lib/cal.l" is no longer restricted to the years - 1900 through 2099. + $ pil myApp.l -main + + + The last line works only if "bin/pil" was copied to "/usr/bin", as + recommended in the INSTALL file. + + The debug switch is also available for Ersatz PicoLisp: + + $ ersatz/picolisp myApp.l -main + + +2. *Tsm, the transient symbol markup (the underlining of transient symbols) is + now off by default. "lib/tsm.l" can be loaded to switch it on. + +3. The interpreter does not exit automatically any more when an empty line is + entered on the top level. To exit the interpreter, either Ctrl-D or and + explicit call to (bye) is needed. + +4. The 'fill' function now handles '^' symbols in the pattern specially. An + expression following that symbol should evaluate to a list, which is then + (destructively) spliced into the result. As before, if 'fill' is passed a + second argument (a symbol or a list of symbols), then only those symbols are + replaced in the pattern without any further treatment. diff --git a/dbg b/dbg @@ -1,2 +1,2 @@ #!/bin/sh -exec ${0%/*}/bin/picolisp -"on *Dbg" ${0%/*}/lib.l @ext.l @dbg.l "$@" +exec ${0%/*}/bin/picolisp ${0%/*}/lib.l @ext.l "$@" + diff --git a/dbg.l b/dbg.l @@ -1,14 +1,8 @@ -# 14apr10abu +# 18jan11abu # (c) Software Lab. Alexander Burger (on *Dbg) -(when (sys "TERM") - (setq *Tsm - (cons - (in '("tput" "smul") (line T)) - (in '("tput" "rmul") (line T)) ) ) ) - (load "@lib/debug.l" "@lib/led.l" "@lib/edit.l" "@lib/lint.l" "@lib/sq.l") (noLint 'later (loc "@Prg" later)) diff --git a/doc/app.html b/doc/app.html @@ -32,11 +32,6 @@ All examples were also tested using the w3m text browser. href="ref.html">PicoLisp Reference</a> and the <a href="tut.html">PicoLisp Tutorial</a>. Knowledge of HTML, and a bit of CSS and HTTP is assumed. -<p>Throughout this document, transient symbols will be displayed with <code><a -href="refT.html#*Tsm">*Tsm</a></code> turned off, i.e. as "Name" (double-quoted) -instead of <u>Name</u> (underlined), to make it easier to copy/paste the -examples. - <p><ul> <li><a href="#static">Static Pages</a> <ul> @@ -347,7 +342,7 @@ Content-Type: text/html; charset=utf-8 &lt;body&gt;Hello World!&lt;/body&gt; &lt;/html&gt; -&gt; &lt;/html&gt; -: # (type ENTER here to terminate the PicoLisp Shell) +: # (type Ctrl-D here to terminate PicoLisp) </code></pre> <p>These are the arguments to <code>html</code>: @@ -800,8 +795,8 @@ variable, client. <p>You can terminate this process (like any interactive PicoLisp) by hitting -ENTER on an empty line. Otherwise, it will terminate by itself if no other -browser requests arrive within a default timeout period of 5 minutes. +<code>Ctrl-D</code> on an empty line. Otherwise, it will terminate by itself if +no other browser requests arrive within a default timeout period of 5 minutes. <p>To start a (non-debug) production version, the server is commonly started not as 'dbg' but with a 'p', and with <code>-wait</code> diff --git a/doc/faq.html b/doc/faq.html @@ -444,8 +444,8 @@ break if we call it as <code>(double 'Var)</code>. Therefore, the correct implementation of <code>double</code> should be: <pre><code> -(de double (<u>Var</u>) - (set <u>Var</u> (* 2 (val <u>Var</u>))) ) +(de double ("Var") + (set "Var" (* 2 (val "Var"))) ) </code></pre> <p>If <code>double</code> is defined that way in a separate source file, and/or @@ -462,8 +462,7 @@ is safe to use them even when not necessary, it will take more space then and be more difficult to debug. <li>The string-like syntax of transient symbols as variables may look strange to -alumni of other languages. Therefore, the use of <a -href="refT.html#*Tsm">transient symbol markup</a> is recommended. +alumni of other languages. </ol> diff --git a/doc/ref.html b/doc/ref.html @@ -176,7 +176,7 @@ bit-representation will look like: xxxxxxxxxxxxxxxxxxxxxxxxxxxxx000 </code></pre> -<p>(the <code>'x'</code> means "don't care"). For the individual data types, the +<p>(the '<code>x</code>' means "don't care"). For the individual data types, the pointer is adjusted to point to other parts of a cell, in effect setting some of the lower three bits to non-zero values. These bits are then used by the interpreter to determine the data type. @@ -277,7 +277,7 @@ a symbol consists of a single cell, and has no name or properties: </code></pre> <p>That is, the symbol's tail is empty (points to <code>NIL</code>, as indicated -by the '/' character). +by the '<code>/</code>' character). <p>The pointer to a symbol points to the CDR of the cell, with an offset of 4 from the cell's start address. Therefore, the bit pattern of a symbol will be: @@ -445,7 +445,7 @@ arrays, trees, stacks or queues. <p>Typically, the CDR of each cell in a list points to the following cell, except for the last cell which points to <code>NIL</code>. If, however, the CDR of the last cell points to an atom, that cell is called a "dotted pair" (because of -its I/O syntax with a dot '.' between the two values). +its I/O syntax with a dot '<code>.</code>' between the two values). <p><hr> @@ -494,18 +494,23 @@ and environment are described. arguments may follow the command name. <p>By default, each argument is the name of a file to be executed by the -interpreter. If, however, the argument's first character is a hyphen '-', then -the rest of that argument is taken as a Lisp function call (without the -surrounding parentheses), and a hyphen by itself as an argument stops evaluation -of the rest of the command line (it may be processed later using the <code><a -href="refA.html#argv">argv</a></code> and <code><a +interpreter. If, however, the argument's first character is a hyphen +'<code>-</code>', then the rest of that argument is taken as a Lisp function +call (without the surrounding parentheses), and a hyphen by itself as an +argument stops evaluation of the rest of the command line (it may be processed +later using the <code><a href="refA.html#argv">argv</a></code> and <code><a href="refO.html#opt">opt</a></code> functions). This whole mechanism corresponds to calling <code>(<a href="refL.html#load">load</a> T)</code>. +<p>A special case is if the last argument is a single '<code>+</code>'. This +will switch on debug mode (the <code><a href="refD.html#*Dbg">*Dbg</a></code> +global variable) and discard the '<code>+</code>'. + <p>As a convention, PicoLisp source files have the extension "<code>.l</code>". <p>Note that the PicoLisp executable itself does not expect or accept any -command line flags or options. They are reserved for application programs. +command line flags or options (except the '<code>+</code>', see above). They are +reserved for application programs. <p>The simplest and shortest invocation of PicoLisp does nothing, and exits immediately by calling <code><a href="refB.html#bye">bye</a></code>: @@ -516,13 +521,12 @@ $ </code></pre> <p>In interactive mode, the PicoLisp interpreter (see <code><a -href="refL.html#load">load</a></code>) will also exit when an empty line is -entered: +href="refL.html#load">load</a></code>) will also exit when <code>Ctrl-D</code> +is entered: <pre><code> $ bin/picolisp -: # Typed ENTER -$ +: $ # Typed Ctrl-D </code></pre> <p>To start up the standard PicoLisp environment, several files should be @@ -542,14 +546,29 @@ would look like: $ ./p myProject.l -main </code></pre> -<p>For interactive development and debugging it is recommended also to load -"dbg.l" (or use './dbg' instead of './p'), to get the vi-style command line -editor, single-stepping, tracing and other debugging utilities. +<p>For interactive development it is recommended to enable debugging mode, to +get the vi-style command line editor, single-stepping, tracing and other +debugging utilities. + +<pre><code> +$ ./p myProject.l -main + +</code></pre> + +<p>This is equivalent to <pre><code> $ ./dbg myProject.l -main </code></pre> +<p>or + +<pre><code> +$ pil myProject.l -main + +</code></pre> + +if PicoLisp is globally installed in "/usr/bin/" and "/usr/lib/" as recommended +in the INSTALL file. + <p>In any case, the directory part of the first file name supplied on the command line (normally, the path to "lib.l") is remembered internally as the <i>PicoLisp Home Directory</i>. This path is later automatically substituted for @@ -589,9 +608,9 @@ symbols and lists) and for read-macros: <p><hr> <h4><a name="num-io">Numbers</a></h4> -<p>A number consists of an arbitrary number of digits (<code>'0'</code> through -<code>'9'</code>), optionally preceded by a sign character (<code>'+'</code> or -<code>'-'</code>). Legal number input is: +<p>A number consists of an arbitrary number of digits ('<code>0</code>' through +'<code>9</code>'), optionally preceded by a sign character ('<code>+</code>' or +'<code>-</code>'). Legal number input is: <pre><code> : 7 @@ -601,7 +620,7 @@ symbols and lists) and for read-macros: </code></pre> <p>Fixed-point numbers can be input by embedding a decimal point -<code>'.'</code>, and setting the global variable <code><a +'<code>.</code>', and setting the global variable <code><a href="refS.html#*Scl">*Scl</a></code> appropriately: <pre><code> @@ -689,40 +708,26 @@ returned as an internal symbol. <p><hr> <h5><a name="transient-io">Transient Symbols</a></h5> -<p>In an interactive environment (console), transient symbols should appear as -an <u>underlined</u> sequence of characters. Where this is not possible (e.g. -for representation in files), or inconvenient (while editing), double quotes -'<code>"</code>' are used instead of underlining. - -<p>The underlining of transient symbols is controlled by the global variable -<code><a href="refT.html#*Tsm">*Tsm</a></code>, and can be switched off -completely with - -<pre><code> -: (off *Tsm) -</code></pre> - -<p>Keyboard input of transient symbols is always done via the double quote key. - -<p>A transient symbol may be used (and, in double quote representation, also -look) like a string constant in other languages. However, it is a real symbol, -and may be assigned a value or a function definition, and properties. +<p>A transient symbol is anything surrounded by double quotes '<code>"</code>'. +With that, it looks - and can be used - like a string constant in other +languages. However, it is a real symbol, and may be assigned a value or a +function definition, and properties. <p>Initially, a transient symbol's value is that symbol itself, so that it does not need to be quoted for evaluation: -<pre><code> -: <u>This is a string</u> # Would be "This is a string" if *Tsm were off --> <u>This is a string</u> +<p><pre><code> +: "This is a string" +-> "This is a string" </code></pre> <p>However, care must be taken when assigning a value to a transient symbol. This may cause unexpected behavior: -<pre><code> -: (setq <u>This is a string</u> 12345) # (setq "This is a string" 12345) +<p><pre><code> +: (setq "This is a string" 12345) -> 12345 -: <u>This is a string</u> +: "This is a string" -> 12345 </code></pre> @@ -732,11 +737,11 @@ null-byte. A double quote character can be escaped with a backslash backslash. Control characters can be written with a preceding hat '<code>^</code>' character. -<pre><code> -: <u>We^Ird\\Str\"ing</u> --> <u>We^Ird\\Str"ing</u> +<p><pre><code> +: "We^Ird\\Str\"ing" +-> "We^Ird\\Str\"ing" : (chop @) --> (<u>W</u> <u>e</u> <u>^I</u> <u>r</u> <u>d</u> <u>\\</u> <u>S</u> <u>t</u> <u>r</u> <u>"</u> <u>i</u> <u>n</u> <u>g</u>) +-> ("W" "e" "^I" "r" "d" "\\" "S" "t" "r" "\"" "i" "n" "g") </code></pre> <p>The index for transient symbols is cleared automatically before and after @@ -752,15 +757,12 @@ href="refN.html#new">new</a></code>). They print as a dollar sign (<code>$</code>) followed by a decimal digit string (actually their machine address). -<p>To allow an easier copy/paste of the examples, most of the documentation uses -the double quote notation for transient symbols. - <p><hr> <h5><a name="external-io">External Symbols</a></h5> -<p>External symbol names are surrounded by braces (<code>'{'</code> and -<code>'}'</code>). The characters of the symbol's name itself identify the +<p>External symbol names are surrounded by braces ('<code>{</code>' and +'<code>}</code>'). The characters of the symbol's name itself identify the physical location of the external object. This is <ul> @@ -771,9 +773,10 @@ base-64 notation (characters '<code>0</code>' through '<code>9</code>', and '<code>a</code>' through '<code>z</code>'). <li>in the 64-bit version: The number of the database file minus 1 in "hax" -notation (i.e. hexadecimal/alpha notation, where '@' is zero, 'A' is 1 and 'O' -is 15 (from "alpha" to "omega")), immediately followed (without a hyphen) the -starting block in octal ('0' through '7'). +notation (i.e. hexadecimal/alpha notation, where '<code>@</code>' is zero, +'<code>A</code>' is 1 and '<code>O</code>' is 15 (from "alpha" to "omega")), +immediately followed (without a hyphen) the starting block in octal +('<code>0</code>' through '<code>7</code>'). </ul> @@ -783,7 +786,7 @@ first (default) file. <p><hr> <h4><a name="lst-io">Lists</a></h4> -<p>Lists are surrounded by parentheses (<code>'('</code> and <code>')'</code>). +<p>Lists are surrounded by parentheses ('<code>(</code>' and '<code>)</code>'). <p><code>(A)</code> is a list consisting of a single cell, with the symbol <code>A</code> in its CAR, and <code>NIL</code> in its CDR. @@ -844,7 +847,8 @@ item into an <code><a href="refI.html#idx">idx</a></code> tree in the global variable <code><a href="refU.html#*Uni">*Uni</a></code>, and to return a previously inserted equal item if present. This makes it possible to create a unique list of references to data which do normally not follow the rules of -pointer equality. +pointer equality. If the value of <code>*Uni</code> is <code>T</code>, the +comma read macro mechanism is disabled. <p>A single backquote character <code>`</code> will cause the reader to evaluate the following expression, and return the result. @@ -855,14 +859,15 @@ the following expression, and return the result. </code></pre> <p>A tilde character <code>~</code> inside a list will cause the reader to -evaluate the following expression, and splice the result into the list. +evaluate the following expression, and (destructively) splice the result into +the list. <pre><code> : '(a b c ~(list 'd 'e 'f) g h i) -> (a b c d e f g h i) </code></pre> -<p>Brackets (<code>'['</code> and <code>']'</code>) can be used as super +<p>Brackets ('<code>[</code>' and '<code>]</code>') can be used as super parentheses. A closing bracket will match the innermost opening bracket, or all currently open parentheses. @@ -1926,6 +1931,7 @@ abbreviations: <a href="refD.html#dec">dec</a> <a href="ref_.html#>>">>></a> <a href="refL.html#lt0">lt0</a> + <a href="refL.html#le0">le0</a> <a href="refG.html#ge0">ge0</a> <a href="refG.html#gt0">gt0</a> <a href="refA.html#abs">abs</a> @@ -1945,6 +1951,7 @@ abbreviations: <a href="refP.html#pad">pad</a> <a href="refM.html#money">money</a> <a href="refR.html#round">round</a> + <a href="refB.html#bin">bin</a> <a href="refO.html#oct">oct</a> <a href="refH.html#hex">hex</a> <a href="refH.html#hax">hax</a> diff --git a/doc/refA.html b/doc/refA.html @@ -389,10 +389,10 @@ T <dd>If called without arguments, <code>argv</code> returns a list of strings containing all remaining command line arguments. Otherwise, the <code>var/sym</code> arguments are subsequently bound to the command line -arguments. A hyphen "<code>-</code>" can be used to stop <code>load</code>ing -further arguments. See also <code><a href="refC.html#cmd">cmd</a></code>, -<code><a href="ref.html#invoc">Invocation</a></code> and <code><a -href="refO.html#opt">opt</a></code>. +arguments. A hyphen "<code>-</code>" can be used to inhibit the automatic +<code>load</code>ing further arguments. See also <code><a +href="refC.html#cmd">cmd</a></code>, <a href="ref.html#invoc">Invocation</a> and +<code><a href="refO.html#opt">opt</a></code>. <pre><code> $ ./p -"println 'OK" - abc 123 diff --git a/doc/refB.html b/doc/refB.html @@ -155,6 +155,23 @@ returns the result. See also <code><a href="refU.html#usec">usec</a></code>. -> NIL </code></pre> +<dt><a name="bin"><code>(bin 'num) -> sym</code></a> +<dt><code>(bin 'sym) -> num</code> +<dd>Converts a number <code>num</code> to a binary string, or a binary string +<code>sym</code> to a number. See also <code><a +href="refO.html#oct">oct</a></code>, <code><a +href="refH.html#hex">hex</a></code>, <code><a +href="refF.html#fmt64">fmt64</a></code>, <code><a +href="refH.html#hax">hax</a></code> and <code><a +href="refF.html#format">format</a></code>. + +<pre><code> +: (bin 73) +-> "1001001" +: (bin "1001001") +-> 73 +</code></pre> + <dt><a name="bind"><code>(bind 'sym|lst . prg) -> any</code></a> <dd>Binds value(s) to symbol(s). The first argument must evaluate to a symbol, or a list of symbols or symbol-value pairs. The values of these symbols are diff --git a/doc/refC.html b/doc/refC.html @@ -383,6 +383,7 @@ href="refT.html#trim">trim</a></code>. <dd>Closes a file descriptor <code>cnt</code>, and returns it when successful. Should not be called inside an <code><a href="refO.html#out">out</a></code> body for that descriptor. See also <code><a href="refO.html#open">open</a></code>, +<code><a href="refP.html#poll">poll</a></code>, <code><a href="refL.html#listen">listen</a></code> and <code><a href="refC.html#connect">connect</a></code>. @@ -396,8 +397,8 @@ href="refC.html#connect">connect</a></code>. picolisp interpreter is returned. Otherwise, the command name is set to <code>any</code>. Setting the name may not work on some operating systems. Note that the new name must not be longer than the original one. See also <code><a -href="refA.html#argv">argv</a></code> and <code><a -href="ref.html#invoc">Invocation</a></code>. +href="refA.html#argv">argv</a></code> and <a +href="ref.html#invoc">Invocation</a>. <pre><code> $ ./dbg diff --git a/doc/refD.html b/doc/refD.html @@ -38,8 +38,10 @@ the program). </code></pre> <dt><a name="*Dbg"><code>*Dbg</code></a> -<dd>A boolean variable indicating "debug mode". When non-<code>NIL</code>, the -<code><a href="ref_.html#$">$</a></code> (tracing) and <code><a +<dd>A boolean variable indicating "debug mode". It can be conveniently switched +on with a trailing <code>+</code> command line argument (see <a +href="ref.html#invoc">Invocation</a>). When non-<code>NIL</code>, the <code><a +href="ref_.html#$">$</a></code> (tracing) and <code><a href="ref_.html#!">!</a></code> (breakpoint) functions are enabled, and the current line number and file name will be stored in symbol properties by <code><a href="refD.html#de">de</a></code>, <code><a diff --git a/doc/refF.html b/doc/refF.html @@ -104,8 +104,10 @@ href="refL.html#load">load</a></code>. <dd>Fills a pattern <code>any</code>, by substituting <code>sym</code>, or all symbols in <code>lst</code>, or - if no second argument is given - each pattern symbol in <code>any</code> (see <code><a href="refP.html#pat?">pat?</a></code>), -with its current value. In that case, <code>@</code> itself is not considered a -pattern symbol. See also <code><a href="refM.html#match">match</a></code>. +with its current value. <code>@</code> itself is not considered a pattern symbol +here. In any case, expressions following the symbol <code>^</code> should +evaluate to a list which is then (destructively) spliced into the result. See +also <code><a href="refM.html#match">match</a></code>. <pre><code> : (setq @X 1234 @Y (1 2 3 4)) @@ -116,6 +118,14 @@ pattern symbol. See also <code><a href="refM.html#match">match</a></code>. -> (a b (c 1234) (((1 2 3 4) . d) e)) : (let X 2 (fill (1 X 3) 'X)) -> (1 2 3) + +: (fill (1 ^ (list 'a 'b 'c) 9)) +-> (1 a b c 9) + +: (match '(This is @X) '(This is a pen)) +-> T +: (fill '(Got ^ @X)) +-> (Got a pen) </code></pre> <dt><a name="filter"><code>(filter 'fun 'lst ..) -> lst</code></a> @@ -257,7 +267,8 @@ characters <code>0</code> - <code>9</code>, <code>:</code>, <code>;</code>, is used internally for the names of <code><a href="ref.html#external-io">external symbols</a></code> in the 32-bit version. See also <code><a href="refH.html#hax">hax</a></code>, <code><a -href="refH.html#hex">hex</a></code> and <code><a +href="refH.html#hex">hex</a></code>, <code><a +href="refB.html#bin">bin</a></code> and <code><a href="refO.html#oct">oct</a></code>. <pre><code> diff --git a/doc/refG.html b/doc/refG.html @@ -32,8 +32,9 @@ href="refH.html#heap">heap</a></code>. <dt><a name="ge0"><code>(ge0 'any) -> num | NIL</code></a> <dd>Returns <code>num</code> when the argument is a number and greater or equal zero, otherwise <code>NIL</code>. See also <code><a -href="refG.html#gt0">gt0</a></code>, <code><a -href="refL.html#lt0">lt0</a></code>, <code><a href="ref_.html#=0">=0</a></code> +href="refL.html#lt0">lt0</a></code>, <code><a +href="refL.html#le0">le0</a></code>, <code><a +href="refG.html#gt0">gt0</a></code>, <code><a href="ref_.html#=0">=0</a></code> and <code><a href="refN.html#n0">n0</a></code>. <pre><code> @@ -171,8 +172,9 @@ href="refU.html#uniq">uniq</a></code>. <dt><a name="gt0"><code>(gt0 'any) -> num | NIL</code></a> <dd>Returns <code>num</code> when the argument is a number and greater than zero, otherwise <code>NIL</code>. See also <code><a -href="refG.html#ge0">ge0</a></code>, <code><a -href="refL.html#lt0">lt0</a></code>, <code><a href="ref_.html#=0">=0</a></code> +href="refL.html#lt0">lt0</a></code>, <code><a +href="refL.html#le0">le0</a></code>, <code><a +href="refG.html#ge0">ge0</a></code>, <code><a href="ref_.html#=0">=0</a></code> and <code><a href="refN.html#n0">n0</a></code>. <pre><code> diff --git a/doc/refH.html b/doc/refH.html @@ -44,17 +44,18 @@ represented with the characters <code>@</code> - <code>O</code> (from "alpha" to "omega"). This format is used internally for the names of <code><a href="ref.html#external-io">external symbols</a></code> in the 64-bit version. See also <code><a href="refF.html#fmt64">fmt64</a></code>, <code><a -href="refH.html#hex">hex</a></code> and <code><a +href="refH.html#hex">hex</a></code>, <code><a +href="refB.html#bin">bin</a></code> and <code><a href="refO.html#oct">oct</a></code>. <pre><code> : (hax 7) --> <u>G</u> +-> "G" : (hax 16) --> <u>A@</u> +-> "A@" : (hax 255) --> <u>OO</u> -: (hax <u>A</u>) +-> "OO" +: (hax "A") -> 1 </code></pre> @@ -110,15 +111,15 @@ href="refT.html#tolr/3">tolr/3</a></code>. <pre><code> : (? - @Nm <u>Muller</u> - @Tel <u>37</u> + @Nm "Muller" + @Tel "37" (select (@CuSu) ((nm +CuSu @Nm) (tel +CuSu @Tel)) (tolr @Nm @CuSu nm) (head @Tel @CuSu tel) ) (val @Name @CuSu nm) (val @Phone @CuSu tel) ) - @Nm=<u>Muller</u> @Tel=<u>37</u> @CuSu={2-3} @Name=<u>Miller</u> @Phone=<u>37 4773 82534</u> + @Nm="Muller" @Tel="37" @CuSu={2-3} @Name="Miller" @Phone="37 4773 82534" -> NIL </code></pre> @@ -145,9 +146,9 @@ background. As this mechanism is also used for inter-family communication (see only called explicitly by a top level parent process. <pre><code> -: (call 'mkfifo <u>fifo/cmd</u>) +: (call 'mkfifo "fifo/cmd") -> T -: (hear (open <u>fifo/cmd</u>)) +: (hear (open "fifo/cmd")) -> 3 </code></pre> @@ -157,8 +158,8 @@ until end of file. See also <code><a href="refE.html#echo">echo</a></code>. <pre><code> $ cat hello.l -(html 0 <u>Hello</u> <u>lib.css</u> NIL - (&lt;h2&gt; NIL <u>Hello</u>) +(html 0 "Hello" "lib.css" NIL + (&lt;h2&gt; NIL "Hello") (here) ) &lt;p&gt;Hello!&lt;/p&gt; &lt;p&gt;This is a test.&lt;/p&gt; @@ -188,6 +189,7 @@ Content-Type: text/html; charset=utf-8 <dt><code>(hex 'sym) -> num</code> <dd>Converts a number <code>num</code> to a hexadecimal string, or a hexadecimal string <code>sym</code> to a number. See also <code><a +href="refB.html#bin">bin</a></code>, <code><a href="refO.html#oct">oct</a></code>, <code><a href="refF.html#fmt64">fmt64</a></code>, <code><a href="refH.html#hax">hax</a></code> @@ -197,8 +199,8 @@ href="refF.html#format">format</a></code>. <pre><code> : (hex 273) --> <u>111</u> -: (hex <u>111</u>) +-> "111" +: (hex "111") -> 273 </code></pre> @@ -207,8 +209,8 @@ href="refF.html#format">format</a></code>. <code><a href="refA.html#*Adr">*Adr</a></code>. <pre><code> -: (host <u>80.190.158.9</u>) --> <u>www.leo.org</u> +: (host "80.190.158.9") +-> "www.leo.org" </code></pre> </dl> diff --git a/doc/refI.html b/doc/refI.html @@ -168,6 +168,7 @@ href="refC.html#call">call</a></code>, <code><a href="refL.html#load">load</a></code>, <code><a href="refF.html#file">file</a></code>, <code><a href="refO.html#out">out</a></code>, <code><a +href="refP.html#poll">poll</a></code>, <code><a href="refP.html#pipe">pipe</a></code> and <code><a href="refC.html#ctl">ctl</a></code>. diff --git a/doc/refJ.html b/doc/refJ.html @@ -71,7 +71,7 @@ writes all changes to the database. See also <code><a href="refP.html#pool">pool</a></code>. <pre><code> -: (journal <u>db.log</u>) +: (journal "db.log") -> T </code></pre> diff --git a/doc/refK.html b/doc/refK.html @@ -34,8 +34,8 @@ href="refR.html#raw">raw</a></code> and <code><a href="refW.html#wait">wait</a></code>. <pre><code> -: (key) # Wait for a key --> <u>a</u> # 'a' pressed +: (key) # Wait for a key +-> "a" # 'a' pressed </code></pre> <dt><a name="kill"><code>(kill 'pid ['cnt]) -> flg</code></a> diff --git a/doc/refL.html b/doc/refL.html @@ -81,6 +81,23 @@ href="refP.html#pipe">pipe</a></code>'ed child process. The return value of -> go </code></pre> +<dt><a name="le0"><code>(le0 'any) -> num | NIL</code></a> +<dd>Returns <code>num</code> when the argument is a number less or equal zero, +otherwise <code>NIL</code>. See also <code><a +href="refL.html#lt0">lt0</a></code>, <code><a +href="refG.html#ge0">ge0</a></code>, <code><a +href="refG.html#gt0">gt0</a></code>, <code><a href="ref_.html#=0">=0</a></code> +and <code><a href="refN.html#n0">n0</a></code>. + +<pre><code> +: (le0 -2) +-> -2 +: (le0 0) +-> 0 +: (le0 3) +-> NIL +</code></pre> + <dt><a name="leaf"><code>(leaf 'tree) -> any</code></a> <dd>Returns the first leaf (i.e. the value of the smallest key) in a database tree. See also <code><a href="refT.html#tree">tree</a></code>, <code><a @@ -242,11 +259,11 @@ href="refM.html#made">made</a></code>. <dt><code>(lint 'sym 'cls) -> lst</code> <dt><code>(lint '(sym . cls)) -> lst</code> <dd>Checks the function definition or file contents (in the first form), or the -method body of sym (second and third form), for possible pitfalls. Returns a -list of diagnoses, where <code>var</code> indicates improper variables, -<code>dup</code> duplicate parameters, <code>def</code> an undefined function, -<code>bnd</code> an unbound variable, and <code>use</code> unused variables. See -also <code><a href="refN.html#noLint">noLint</a></code>, <code><a +method body of sym (second and third form), for possible pitfalls. Returns an +association list of diagnoses, where <code>var</code> indicates improper +variables, <code>dup</code> duplicate parameters, <code>def</code> an undefined +function, <code>bnd</code> an unbound variable, and <code>use</code> unused +variables. See also <code><a href="refN.html#noLint">noLint</a></code>, <code><a href="refL.html#lintAll">lintAll</a></code>, <code><a href="refD.html#debug">debug</a></code>, <code><a href="refT.html#trace">trace</a></code> and <code><a @@ -511,6 +528,7 @@ href="refL.html#low?">low?</a></code>. <dt><a name="lt0"><code>(lt0 'any) -> num | NIL</code></a> <dd>Returns <code>num</code> when the argument is a number and less than zero, otherwise <code>NIL</code>. See also <code><a +href="refL.html#le0">le0</a></code>, <code><a href="refG.html#ge0">ge0</a></code>, <code><a href="refG.html#gt0">gt0</a></code>, <code><a href="ref_.html#=0">=0</a></code> and <code><a href="refN.html#n0">n0</a></code>. diff --git a/doc/refN.html b/doc/refN.html @@ -49,6 +49,7 @@ href="ref.html#cmp">Comparing</a>. <dd>Returns <code>T</code> when <code>any</code> is not a number with value zero. See also <code><a href="ref_.html#=0">=0</a></code>, <code><a href="refL.html#lt0">lt0</a></code>, <code><a +href="refL.html#le0">le0</a></code>, <code><a href="refG.html#ge0">ge0</a></code> and <code><a href="refG.html#gt0">gt0</a></code>. diff --git a/doc/refO.html b/doc/refO.html @@ -66,6 +66,7 @@ Obj (+A +B +C) <dt><code>(oct 'sym) -> num</code> <dd>Converts a number <code>num</code> to an octal string, or an octal string <code>sym</code> to a number. See also <code><a +href="refB.html#bin">bin</a></code>, <code><a href="refH.html#hex">hex</a></code>, <code><a href="refF.html#fmt64">fmt64</a></code>, <code><a href="refH.html#hax">hax</a></code> and <code><a @@ -179,7 +180,8 @@ leading "<code>@</code>" character in <code>any</code> is substituted with the If the file does not exist, it is created. The file descriptor can be used in subsequent calls to <code><a href="refI.html#in">in</a></code> and <code><a href="refO.html#out">out</a></code>. See also <code><a -href="refC.html#close">close</a></code>. +href="refC.html#close">close</a></code> and <code><a +href="refP.html#poll">poll</a></code>. <pre><code> : (open "x") @@ -200,9 +202,10 @@ href="refO.html#out">out</a></code>. </code></pre> <dt><a name="opt"><code>(opt) -> sym</code></a> -<dd>Return the next command line argument (option) as a string, and remove it -from the remaining command line arguments. See also <code><a -href="ref.html#invoc">Invocation</a></code> and <code><a +<dd>Return the next command line argument ("option", as would be processed by +<code><a href="refL.html#load">load</a></code>) as a string, and remove it from +the remaining command line arguments. See also <a +href="ref.html#invoc">Invocation</a> and <code><a href="refA.html#argv">argv</a></code>. <pre><code> @@ -248,6 +251,7 @@ list), it is taken as a command with arguments, and a pipe is opened for output. See also <code><a href="refO.html#opid">opid</a></code>, <code> <a href="refC.html#call">call</a></code>, <code><a href="refI.html#in">in</a></code>, <code> <a +href="refP.html#poll">poll</a></code>, <code> <a href="refP.html#pipe">pipe</a></code>, <code> <a href="refC.html#ctl">ctl</a></code>, <code><a href="refC.html#close">close</a></code> and <code><a diff --git a/doc/refP.html b/doc/refP.html @@ -176,8 +176,8 @@ argument with the <u>PicoLisp Home Directory</u>, as it was remembered during interpreter startup. Optionally, the name may be preceded by a "<code>+</code>" character (as used by <code><a href="refI.html#in">in</a></code> and <code><a href="refO.html#out">out</a></code>). This mechanism is used internally by all -I/O functions. See also <code><a href="ref.html#invoc">Invocation</a></code>, -<code><a href="refB.html#basename">basename</a></code>. and <code><a +I/O functions. See also <a href="ref.html#invoc">Invocation</a>, <code><a +href="refB.html#basename">basename</a></code>. and <code><a href="refD.html#dirname">dirname</a></code>. <pre><code> diff --git a/doc/refQ.html b/doc/refQ.html @@ -91,7 +91,7 @@ be the reason for the error. See also <code><a href="ref.html#errors">Error Handling</a></code>. <pre><code> -: (de foo (X) (quit <u>Sorry, my error</u> X)) +: (de foo (X) (quit "Sorry, my error" X)) -> foo : (foo 123) # 'X' is bound to '123' 123 -- Sorry, my error # Error entered diff --git a/doc/refR.html b/doc/refR.html @@ -30,7 +30,7 @@ timeout occurred. See also <code><a href="refT.html#task">task</a></code>. : 2sec # Prints "2sec" every 2 seconds 2sec 2sec - # (Enter) Exit + # (Ctrl-D) Exit $ </code></pre> @@ -667,12 +667,15 @@ href="refF.html#flip">flip</a></code> . <dt><a name="round"><code>(round 'num1 'num2) -> sym</code></a> <dd>Formats a number <code>num1</code> with <code>num2</code> decimal places, according to the current scale <code><a href="refS.html#*Scl">*Scl</a></code>. -See also <code><a href="refF.html#format">format</a></code> and <code><a +<code>num2</code> defaults to 3. See also <code><a +href="refF.html#format">format</a></code> and <code><a href="ref.html#num-io">Numbers</a></code>. <pre><code> : (scl 4) # Set scale to 4 -> 4 +: (round 123456) # Format with three decimal places +-> "12.346" : (round 123456 2) # Format with two decimal places -> "12.35" : (format 123456 *Scl) # Format with full precision diff --git a/doc/refW.html b/doc/refW.html @@ -50,7 +50,7 @@ href="refS.html#strDat">strDat</a></code>. <pre><code> : (datStr (date)) --> <u>2007-06-01</u> +-> "2007-06-01" : (week (date)) -> 22 </code></pre> @@ -93,7 +93,7 @@ NIL href="refC.html#can">can</a></code>. <pre><code> -: (what <u>cd@dr</u>) +: (what "cd@dr") -> (cdaddr cdaadr cddr cddddr cdddr cddadr cdadr) </code></pre> @@ -108,15 +108,15 @@ href="refC.html#can">can</a></code>. : (who 'caddr) # Who is using 'caddr'? -> ($dat lint1 expDat datStr $tim tim$ mail _gen dat$ datSym) -: (who <u>Type error</u>) +: (who "Type error") -> ((mis> . +Link) *Uni (mis> . +Joint)) -: (more (who <u>Type error</u>) pp) # Pretty print all results +: (more (who "Type error") pp) # Pretty print all results (dm (mis> . +Link) (Val Obj) (and Val (nor (isa (: type) Val) (canQuery Val)) - <u>Type error</u> ) ) + "Type error" ) ) . # Stop -> T </code></pre> @@ -170,9 +170,9 @@ channel. See also <code><a href="refR.html#rd">rd</a></code> and <code><a href="refP.html#pr">pr</a></code>. <pre><code> -: (out <u>x</u> (wr 1 255 257)) # Write to "x" +: (out "x" (wr 1 255 257)) # Write to "x" -> 257 -: (hd <u>x</u>) +: (hd "x") 00000000 01 FF 01 ... -> NIL </code></pre> @@ -185,10 +185,10 @@ href="refP.html#pack">pack</a></code>ed in lines with a maximal length of href="refC.html#center">center</a></code>. <pre><code> -: (wrap 20 (chop <u>The quick brown fox jumps over the lazy dog</u>)) --> <u>The quick brown fox^Jjumps over the lazy^Jdog</u> -: (wrap 8 (chop <u>The quick brown fox jumps over the lazy dog</u>)) --> <u>The^Jquick^Jbrown^Jfox^Jjumps^Jover the^Jlazy dog</u> +: (wrap 20 (chop "The quick brown fox jumps over the lazy dog")) +-> "The quick brown fox^Jjumps over the lazy^Jdog" +: (wrap 8 (chop "The quick brown fox jumps over the lazy dog")) +-> "The^Jquick^Jbrown^Jfox^Jjumps^Jover the^Jlazy dog" </code></pre> </dl> diff --git a/doc/ref_.html b/doc/ref_.html @@ -346,6 +346,7 @@ non-decreasing order. See also <a href="ref.html#cmp">Comparing</a>. <dd>Returns <code>0</code> when <code>any</code> is a number with value zero. See also <code><a href="refN.html#n0">n0</a></code>, <code><a href="refL.html#lt0">lt0</a></code>, <code><a +href="refL.html#le0">le0</a></code>, <code><a href="refG.html#ge0">ge0</a></code> and <code><a href="refG.html#gt0">gt0</a></code>. diff --git a/doc/select.html b/doc/select.html @@ -64,7 +64,7 @@ $ ./dbg app/main.l -main : </code></pre> -<p>As ever, you can terminate the interpreter by hitting ENTER. +<p>As ever, you can terminate the interpreter by hitting <code>Ctrl-D</code>. <p>For a first, typical example, let's write a complete call to <a href="refS.html#solve">solve</a> that returns a list of articles with numbers diff --git a/doc/tinymce b/doc/tinymce @@ -14,16 +14,17 @@ Using the TinyMCE Javascript/HTML WYSIWYG editor in PicoLisp applications (allowed ("myApp/" "img/" "tinymce/") ... ) -4. On each page where you want to use tinymce in textareas, insert somewhere at - the beginning, but before the first text field, e.g.: +4. On each page where you want to use tinymce in textareas, insert two calls to + 'javascript' somewhere at the beginning, but before the first textarea, + e.g.: (action (html 0 "Title" "lib.css" NIL - (javascript "tinymce/tiny_mce.js") + (javascript "tinymce/tiny_mce.js") # Insert two lines (javascript "lib/tinymce.js") (form NIL ... - (gui '(+BlobField) '(txt : home obj) 60 8 "Memo") + (gui '(+BlobField) '(txt : home obj) 60 8 "Memo") # Use textareas 5. Normally, you would use an application-specific configuration. In that case, copy "lib/tinymce.js" to "myApp/tinymce.js", modify the plugins, diff --git a/doc/tut.html b/doc/tut.html @@ -37,8 +37,8 @@ $ ./dbg <p>It loads the PicoLisp base system and the debugging environment, and waits for you to enter input lines at the interpreter prompt (<code>:</code>). You can terminate the interpreter and return to the shell at any time, by either hitting -the ENTER key (i.e. by entering an empty line), or by executing the function -<code><a href="refB.html#bye">(bye)</a></code>. +the <code>Ctrl-D</code> key, or by executing the function <code><a +href="refB.html#bye">(bye)</a></code>. <p>Please note that special handling is done during character input. This one is incompatible with <code>rlwrap</code> for example but is more powerful. @@ -195,9 +195,7 @@ directory. The length of the history is limited to 1000 lines. <p><ul> -<li><code>Ctrl-D</code> will immediately terminate the current process, and also -all of its sister processes (i.e. children of the same parent process, typically -an application server during debugging). +<li><code>Ctrl-D</code> will immediately terminate the current process. <li><code>Ctrl-X</code> discards all input, abandons further processing, and returns to the interpreter's top level (equivalent to invoking <code><a @@ -1143,9 +1141,8 @@ work: via command line arguments, or as a stand-alone script. <h3>Command line arguments for the PicoLisp interpreter</h3> <p>The command line can specify either files for execution, or arbitrary Lisp -expressions for direct evaluation (see <code><a -href="ref.html#invoc">Invocation</a></code>): if an argument starts with a -hyphen, it is evaluated, otherwise it is <code><a +expressions for direct evaluation (see <a href="ref.html#invoc">Invocation</a>): +if an argument starts with a hyphen, it is evaluated, otherwise it is <code><a href="refL.html#load">load</a></code>ed as a file. A typical invocation might look like: @@ -2139,8 +2136,8 @@ $ ./p doc/family.l -main -go -wait process which will continue to run until it is killed. The other is a child process holding the state of the GUI in the browser. It will terminate some time after the browser is closed, or when <code>(<a -href="refB.html#bye">bye</a>)</code> or a plain ENTER is entered at the PicoLisp -prompt. +href="refB.html#bye">bye</a>)</code> or a <code>Ctrl-D</code> is entered at the +PicoLisp prompt. <p>Now back to the explanation of the GUI function <code>person</code>: diff --git a/ersatz/README b/ersatz/README @@ -1,4 +1,4 @@ -03dec10abu +19jan11abu (c) Software Lab. Alexander Burger @@ -34,7 +34,12 @@ Ersatz PicoLisp can be started - analog to 'bin/picolisp' - as $ ersatz/picolisp This already includes slighly simplfied versions of the standard libraries as -loaded by './dbg' (without database, but with Pilog and XML support). +loaded by './p' (without database, but with Pilog and XML support). + +To start it in debug mode, use + + $ ersatz/picolisp + + On non-Unix systems, you might start 'java' directly, e.g.: diff --git a/ersatz/fun.src b/ersatz/fun.src @@ -1,4 +1,4 @@ -# 13dec10abu +# 23jan11abu # (c) Software Lab. Alexander Burger # Ersatz PicoLisp Functions @@ -3110,6 +3110,10 @@ dec (x y) lt0 (x) return (x = ex.Cdr.Car.eval()) instanceof Number && x.compare(Zero) < 0? x : Nil; +# (le0 'any) -> num | NIL +le0 (x) + return (x = ex.Cdr.Car.eval()) instanceof Number && x.compare(Zero) <= 0? x : Nil; + # (ge0 'any) -> num | NIL ge0 (x) return (x = ex.Cdr.Car.eval()) instanceof Number && x.compare(Zero) >= 0? x : Nil; diff --git a/ersatz/lib.l b/ersatz/lib.l @@ -1,8 +1,6 @@ -# 29nov10abu +# 19jan11abu # (c) Software Lab. Alexander Burger -(on *Dbg) - ############ lib.l ############ (de task (Key . Prg) @@ -143,6 +141,13 @@ (unless (idx '*Once (file) T) (run Prg 1) ) ) +# Temporary Files +(de tmp @ + (unless *Tmp + (push '*Bye '(call 'rm "-r" *Tmp)) + (call 'mkdir "-p" (setq *Tmp (pack "tmp/" *Pid "/"))) ) + (pass pack *Tmp) ) + ### List ### (de insert (N Lst X) (conc @@ -213,6 +218,40 @@ (de var: X (apply meta X This) ) +### Math ### +(de sqrt (N F) + (cond + ((lt0 N) (quit "Bad argument" N)) + (N + (let (A 1 B 0) + (while (>= N A) + (setq A (>> -2 A)) ) + (loop + (if (> (inc 'B A) N) + (dec 'B A) + (dec 'N B) + (inc 'B A) ) + (setq B (>> 1 B) A (>> 2 A)) + (T (=0 A)) ) + (and F (> N B) (inc 'B)) + B ) ) ) ) + +# (Knuth Vol.2, p.442) +(de ** (X N) # N th power of X + (let Y 1 + (loop + (when (bit? 1 N) + (setq Y (* Y X)) ) + (T (=0 (setq N (>> 1 N))) + Y ) + (setq X (* X X)) ) ) ) + +(de accu (Var Key Val) + (when Val + (if (assoc Key (val Var)) + (con @ (+ Val (cdr @))) + (push Var (cons Key Val)) ) ) ) + ### Pretty Printing ### (de *PP T NIL if ifn when unless while until do case state for @@ -335,6 +374,14 @@ (println '|) (mapc prin Y) ) ) ) ) ) +### Assertions ### +(de assert Prg + (when *Dbg + (cons + (list 'unless + (if (cdr Prg) (cons 'and Prg) (car Prg)) + (list 'quit "'assert' failed" (lit (car Prg))) ) ) ) ) + ############ lib/misc.l ############ # *Allow *Tmp @@ -375,40 +422,6 @@ ("loc" (read)) (set (link @) (name (read))) ) ) ) ) ) -### Math ### -(de sqrt (N F) - (cond - ((lt0 N) (quit "Bad argument" N)) - (N - (let (A 1 B 0) - (while (>= N A) - (setq A (>> -2 A)) ) - (loop - (if (> (inc 'B A) N) - (dec 'B A) - (dec 'N B) - (inc 'B A) ) - (setq B (>> 1 B) A (>> 2 A)) - (T (=0 A)) ) - (and F (> N B) (inc 'B)) - B ) ) ) ) - -# (Knuth Vol.2, p.442) -(de ** (X N) # N th power of X - (let Y 1 - (loop - (when (bit? 1 N) - (setq Y (* Y X)) ) - (T (=0 (setq N (>> 1 N))) - Y ) - (setq X (* X X)) ) ) ) - -(de accu (Var Key Val) - (when Val - (if (assoc Key (val Var)) - (con @ (+ Val (cdr @))) - (push Var (cons Key Val)) ) ) ) - ### String ### (de align (X . @) (pack @@ -458,27 +471,38 @@ (format N 2 *Sep0 *Sep3) ) ) (de round (N D) - (if (>= *Scl D) + (if (>= *Scl (default D 3)) (format (*/ N (** 10 (- *Scl D))) D *Sep0 *Sep3) (format N *Scl *Sep0 *Sep3) ) ) +# Binary notation +(de bin (X) + (cond + ((num? X) + (let (S (and (lt0 X) '-) L (& 1 X)) + (until (=0 (setq X (>> 1 X))) + (push 'L (& 1 X)) ) + (pack S L) ) ) + ((setq X (chop X)) + (let (S (and (= '- (car X)) (pop 'X)) N 0) + (for C X + (setq N (| (format C) (>> -1 N))) ) + (if S (- N) N) ) ) ) ) + # Octal notation (de oct (X) (cond ((num? X) - (let (S (and (lt0 X) '-) L (oct1 X)) + (let (S (and (lt0 X) '-) L (& 7 X)) (until (=0 (setq X (>> 3 X))) - (push 'L (oct1 X)) ) + (push 'L (& 7 X)) ) (pack S L) ) ) ((setq X (chop X)) (let (S (and (= '- (car X)) (pop 'X)) N 0) (for C X - (setq N (+ (format C) (>> -3 N))) ) + (setq N (| (format C) (>> -3 N))) ) (if S (- N) N) ) ) ) ) -(de oct1 (N) - (char (+ (& N 7) `(char "0"))) ) - # Hexadecimal notation (de hex (X) (cond @@ -493,7 +517,7 @@ (setq C (- (char C) `(char "0"))) (and (> C 9) (dec 'C 7)) (and (> C 22) (dec 'C 32)) - (setq N (+ C (>> -4 N))) ) + (setq N (| C (>> -4 N))) ) (if S (- N) N) ) ) ) ) (de hex1 (N) @@ -689,14 +713,6 @@ (de basename (F) (pack (stem (chop F) '/)) ) -# Temporary Files -(de tmp @ - (unless *Tmp - (push '*Bye '(call 'rm "-r" *Tmp)) - (call 'mkdir "-p" (setq *Tmp (pack "tmp/" *Pid "/"))) ) - (pass pack *Tmp) ) - - # Print or eval (de prEval (Prg Ofs) (default Ofs 1) @@ -710,15 +726,7 @@ (line) (echo S) ) - -### Assertions ### -(de assert Prg - (when *Dbg - (cons - (list 'unless - (if (cdr Prg) (cons 'and Prg) (car Prg)) - (list 'quit "'assert' failed" (lit (car Prg))) ) ) ) ) - +# Unit tests (de test (Pat . Prg) (bind (fish pat? Pat) (unless (match Pat (run Prg 1)) @@ -1061,65 +1069,279 @@ (repeat) -############ lib/debug.l ############ +############ lib/xm.l ############ -# Browsing -(de doc (Sym Browser) - (let (L (chop Sym) C (car L)) - (and - (member C '("*" "+")) - (cadr L) - (setq C @) ) - (cond - ((>= "Z" C "A")) - ((>= "z" C "a") (setq C (uppc C))) - (T (setq C "_")) ) - (call (or Browser (sys "BROWSER") 'w3m) - (pack - "file:" - (and (= `(char '/) (char (path "@"))) "//") - (path "@doc/ref") - C ".html#" Sym ) ) ) ) +# Check or write header +(de xml? (Flg) + (if Flg + (prinl "<?xml version=\"1.0\" encoding=\"utf-8\"?>") + (skip) + (prog1 + (head '("<" "?" "x" "m" "l") (till ">")) + (char) ) ) ) -(de more ("M" "Fun") - (let *Dbg NIL - (if (pair "M") - ((default "Fun" print) (pop '"M")) - (println (type "M")) - (setq - "Fun" (list '(X) (list 'pp 'X (lit "M"))) - "M" (mapcar car (filter pair (val "M"))) ) ) - (loop - (flush) - (T (atom "M") (prinl)) - (T (line) T) - ("Fun" (pop '"M")) ) ) ) +# Generate/Parse XML data +(de xml (Lst N) + (if Lst + (let Tag (pop 'Lst) + (space (default N 0)) + (prin "<" Tag) + (for X (pop 'Lst) + (prin " " (car X) "=\"") + (escXml (cdr X)) + (prin "\"") ) + (nond + (Lst (prinl "/>")) + ((or (cdr Lst) (pair (car Lst))) + (prin ">") + (escXml (car Lst)) + (prinl "</" Tag ">") ) + (NIL + (prinl ">") + (for X Lst + (if (pair X) + (xml X (+ 3 N)) + (space (+ 3 N)) + (escXml X) + (prinl) ) ) + (space N) + (prinl "</" Tag ">") ) ) ) + (skip) + (unless (= "<" (char)) + (quit "Bad XML") ) + (_xml (till " /<>" T)) ) ) -(de depth (Idx) #> (max . average) - (let (C 0 D 0 N 0) - (cons - (recur (Idx N) - (ifn Idx - 0 - (inc 'C) - (inc 'D (inc 'N)) - (inc - (max - (recurse (cadr Idx) N) - (recurse (cddr Idx) N) ) ) ) ) - (or (=0 C) (*/ D C)) ) ) ) +(de _xml (Tok) + (use X + (make + (link (intern Tok)) + (let L + (make + (loop + (NIL (skip) (quit "XML parse error")) + (T (member @ '`(chop "/>"))) + (NIL (setq X (intern (till "=" T)))) + (char) + (unless (= "\"" (char)) + (quit "XML parse error" X) ) + (link (cons X (pack (xmlEsc (till "\""))))) + (char) ) ) + (if (= "/" (char)) + (prog (char) (and L (link L))) + (link L) + (loop + (NIL (skip) (quit "XML parse error" Tok)) + (T (and (= "<" (setq X (char))) (= "/" (peek))) + (char) + (unless (= Tok (till " /<>" T)) + (quit "Unbalanced XML" Tok) ) + (char) ) + (if (= "<" X) + (and (_xml (till " /<>" T)) (link @)) + (link + (pack (xmlEsc (trim (cons X (till "^J<"))))) ) ) ) ) ) ) ) ) -(de what (S) - (let *Dbg NIL - (setq S (chop S)) - (filter - '(("X") (match S (chop "X"))) - (all) ) ) ) +(de xmlEsc (L) + (use (@X @Z) + (make + (while L + (ifn (match '("&" @X ";" @Z) L) + (link (pop 'L)) + (link + (cond + ((= @X '`(chop "quot")) "\"") + ((= @X '`(chop "amp")) "&") + ((= @X '`(chop "lt")) "<") + ((= @X '`(chop "gt")) ">") + ((= @X '`(chop "apos")) "'") + ((= "#" (car @X)) + (char + (if (= "x" (cadr @X)) + (hex (cddr @X)) + (format (cdr @X)) ) ) ) + (T @X) ) ) + (setq L @Z) ) ) ) ) ) +(de escXml (X) + (for C (chop X) + (if (member C '`(chop "\"&<")) + (prin "&#" (char C) ";") + (prin C) ) ) ) -(de who ("X" . "*Prg") - (let (*Dbg NIL "Who" '("Who" @ @@ @@@)) - (make (mapc "who" (all))) ) ) + +# Access functions +(de body (Lst . @) + (while (and (setq Lst (cddr Lst)) (args)) + (setq Lst (assoc (next) Lst)) ) + Lst ) + +(de attr (Lst Key . @) + (while (args) + (setq + Lst (assoc Key (cddr Lst)) + Key (next) ) ) + (cdr (assoc Key (cadr Lst))) ) + +############ lib/xmlrpc.l ############ + +# (xmlrpc "localhost" 8080 "foo.bar" 'int 41 'string "abc" ..) +(de xmlrpc (Host Port Meth . @) + (let? Sock (connect Host Port) + (let Xml (tmp 'xmlrpc) + (out Xml + (xml? T) + (xml + (list 'methodCall NIL + (list 'methodName NIL Meth) + (make + (link 'params NIL) + (while (args) + (link + (list 'param NIL + (list 'value NIL (list (next) NIL (next))) ) ) ) ) ) ) ) + (prog1 + (out Sock + (prinl "POST /RPC2 HTTP/1.0^M") + (prinl "Host: " Host "^M") + (prinl "User-Agent: PicoLisp^M") + (prinl "Content-Type: text/xml^M") + (prinl "Accept-Charset: utf-8^M") + (prinl "Content-Length: " (car (info Xml)) "^M") + (prinl "^M") + (in Xml (echo)) + (flush) + (in Sock + (while (line)) + (let? L (and (xml?) (xml)) + (when (== 'methodResponse (car L)) + (xmlrpcValue + (car (body L 'params 'param 'value)) ) ) ) ) ) + (close Sock) ) ) ) ) + +(de xmlrpcKey (Str) + (or (format Str) (intern Str)) ) + +(de xmlrpcValue (Lst) + (let X (caddr Lst) + (case (car Lst) + (string X) + ((i4 int) (format X)) + (boolean (= "1" X)) + (double (format X *Scl)) + (array + (when (== 'data (car X)) + (mapcar + '((L) + (and (== 'value (car L)) (xmlrpcValue (caddr L))) ) + (cddr X) ) ) ) + (struct + (extract + '((L) + (when (== 'member (car L)) + (cons + (xmlrpcKey (caddr (assoc 'name L))) + (xmlrpcValue (caddr (assoc 'value L))) ) ) ) + (cddr Lst) ) ) ) ) ) + +############ lib/http.l ############ + +### HTTP-Client ### +(de client (Host Port How . Prg) + (let? Sock (connect Host Port) + (prog1 + (out Sock + (if (atom How) + (prinl "GET /" How " HTTP/1.0^M") + (prinl "POST /" (car How) " HTTP/1.0^M") + (prinl "Content-Length: " (size (cdr How)) "^M") ) + (prinl "User-Agent: PicoLisp^M") + (prinl "Host: " Host "^M") + (prinl "Accept-Charset: utf-8^M") + (prinl "^M") + (and (pair How) (prin (cdr @))) + (flush) + (in Sock (run Prg 1)) ) + (close Sock) ) ) ) + +############ Native Java ############ + +(de javac (Cls Ext Impl . @) + (let (J (pack "tmp/" Cls ".java") C (pack "tmp/" Cls ".class")) + (call 'mkdir "-p" "tmp/") + (out J + (while (args) + (prinl "import " (next) ";") ) + (prinl "public class " Cls + (and Ext (pack " extends " @)) + (and Impl (pack " implements " (glue ", " Impl))) + " {" ) + (here "/**/") + (prinl "}") ) + (call "javac" "-O" "-g:none" J) + (push1 '*Bye (list 'call "rm" J C)) ) ) + +### Debug ### +`*Dbg + +############ lib/debug.l ############ + +# Browsing +(de doc (Sym Browser) + (let (L (chop Sym) C (car L)) + (and + (member C '("*" "+")) + (cadr L) + (setq C @) ) + (cond + ((>= "Z" C "A")) + ((>= "z" C "a") (setq C (uppc C))) + (T (setq C "_")) ) + (call (or Browser (sys "BROWSER") 'w3m) + (pack + "file:" + (and (= `(char '/) (char (path "@"))) "//") + (path "@doc/ref") + C ".html#" Sym ) ) ) ) + +(de more ("M" "Fun") + (let *Dbg NIL + (if (pair "M") + ((default "Fun" print) (pop '"M")) + (println (type "M")) + (setq + "Fun" (list '(X) (list 'pp 'X (lit "M"))) + "M" (mapcar car (filter pair (val "M"))) ) ) + (loop + (flush) + (T (atom "M") (prinl)) + (T (line) T) + ("Fun" (pop '"M")) ) ) ) + +(de depth (Idx) #> (max . average) + (let (C 0 D 0 N 0) + (cons + (recur (Idx N) + (ifn Idx + 0 + (inc 'C) + (inc 'D (inc 'N)) + (inc + (max + (recurse (cadr Idx) N) + (recurse (cddr Idx) N) ) ) ) ) + (or (=0 C) (*/ D C)) ) ) ) + +(de what (S) + (let *Dbg NIL + (setq S (chop S)) + (filter + '(("X") (match S (chop "X"))) + (all) ) ) ) + + +(de who ("X" . "*Prg") + (let (*Dbg NIL "Who" '("Who" @ @@ @@@)) + (make (mapc "who" (all))) ) ) (de "who" ("Y") (unless (or (ext? "Y") (memq "Y" "Who")) @@ -1630,215 +1852,4 @@ (while (args) (and (lint (next)) (link (cons (arg) @))) ) ) ) ) -############ lib/xm.l ############ - -# Check or write header -(de xml? (Flg) - (if Flg - (prinl "<?xml version=\"1.0\" encoding=\"utf-8\"?>") - (skip) - (prog1 - (head '("<" "?" "x" "m" "l") (till ">")) - (char) ) ) ) - -# Generate/Parse XML data -(de xml (Lst N) - (if Lst - (let Tag (pop 'Lst) - (space (default N 0)) - (prin "<" Tag) - (for X (pop 'Lst) - (prin " " (car X) "=\"") - (escXml (cdr X)) - (prin "\"") ) - (nond - (Lst (prinl "/>")) - ((or (cdr Lst) (pair (car Lst))) - (prin ">") - (escXml (car Lst)) - (prinl "</" Tag ">") ) - (NIL - (prinl ">") - (for X Lst - (if (pair X) - (xml X (+ 3 N)) - (space (+ 3 N)) - (escXml X) - (prinl) ) ) - (space N) - (prinl "</" Tag ">") ) ) ) - (skip) - (unless (= "<" (char)) - (quit "Bad XML") ) - (_xml (till " /<>" T)) ) ) - -(de _xml (Tok) - (use X - (make - (link (intern Tok)) - (let L - (make - (loop - (NIL (skip) (quit "XML parse error")) - (T (member @ '`(chop "/>"))) - (NIL (setq X (intern (till "=" T)))) - (char) - (unless (= "\"" (char)) - (quit "XML parse error" X) ) - (link (cons X (pack (xmlEsc (till "\""))))) - (char) ) ) - (if (= "/" (char)) - (prog (char) (and L (link L))) - (link L) - (loop - (NIL (skip) (quit "XML parse error" Tok)) - (T (and (= "<" (setq X (char))) (= "/" (peek))) - (char) - (unless (= Tok (till " /<>" T)) - (quit "Unbalanced XML" Tok) ) - (char) ) - (if (= "<" X) - (and (_xml (till " /<>" T)) (link @)) - (link - (pack (xmlEsc (trim (cons X (till "^J<"))))) ) ) ) ) ) ) ) ) - -(de xmlEsc (L) - (use (@X @Z) - (make - (while L - (ifn (match '("&" @X ";" @Z) L) - (link (pop 'L)) - (link - (cond - ((= @X '`(chop "quot")) "\"") - ((= @X '`(chop "amp")) "&") - ((= @X '`(chop "lt")) "<") - ((= @X '`(chop "gt")) ">") - ((= @X '`(chop "apos")) "'") - ((= "#" (car @X)) - (char - (if (= "x" (cadr @X)) - (hex (cddr @X)) - (format (cdr @X)) ) ) ) - (T @X) ) ) - (setq L @Z) ) ) ) ) ) - -(de escXml (X) - (for C (chop X) - (if (member C '`(chop "\"&<")) - (prin "&#" (char C) ";") - (prin C) ) ) ) - - -# Access functions -(de body (Lst . @) - (while (and (setq Lst (cddr Lst)) (args)) - (setq Lst (assoc (next) Lst)) ) - Lst ) - -(de attr (Lst Key . @) - (while (args) - (setq - Lst (assoc Key (cddr Lst)) - Key (next) ) ) - (cdr (assoc Key (cadr Lst))) ) - -############ lib/xmlrpc.l ############ - -# (xmlrpc "localhost" 8080 "foo.bar" 'int 41 'string "abc" ..) -(de xmlrpc (Host Port Meth . @) - (let? Sock (connect Host Port) - (let Xml (tmp 'xmlrpc) - (out Xml - (xml? T) - (xml - (list 'methodCall NIL - (list 'methodName NIL Meth) - (make - (link 'params NIL) - (while (args) - (link - (list 'param NIL - (list 'value NIL (list (next) NIL (next))) ) ) ) ) ) ) ) - (prog1 - (out Sock - (prinl "POST /RPC2 HTTP/1.0^M") - (prinl "Host: " Host "^M") - (prinl "User-Agent: PicoLisp^M") - (prinl "Content-Type: text/xml^M") - (prinl "Accept-Charset: utf-8^M") - (prinl "Content-Length: " (car (info Xml)) "^M") - (prinl "^M") - (in Xml (echo)) - (flush) - (in Sock - (while (line)) - (let? L (and (xml?) (xml)) - (when (== 'methodResponse (car L)) - (xmlrpcValue - (car (body L 'params 'param 'value)) ) ) ) ) ) - (close Sock) ) ) ) ) - -(de xmlrpcKey (Str) - (or (format Str) (intern Str)) ) - -(de xmlrpcValue (Lst) - (let X (caddr Lst) - (case (car Lst) - (string X) - ((i4 int) (format X)) - (boolean (= "1" X)) - (double (format X *Scl)) - (array - (when (== 'data (car X)) - (mapcar - '((L) - (and (== 'value (car L)) (xmlrpcValue (caddr L))) ) - (cddr X) ) ) ) - (struct - (extract - '((L) - (when (== 'member (car L)) - (cons - (xmlrpcKey (caddr (assoc 'name L))) - (xmlrpcValue (caddr (assoc 'value L))) ) ) ) - (cddr Lst) ) ) ) ) ) - -############ lib/http.l ############ - -### HTTP-Client ### -(de client (Host Port How . Prg) - (let? Sock (connect Host Port) - (prog1 - (out Sock - (if (atom How) - (prinl "GET /" How " HTTP/1.0^M") - (prinl "POST /" (car How) " HTTP/1.0^M") - (prinl "Content-Length: " (size (cdr How)) "^M") ) - (prinl "User-Agent: PicoLisp^M") - (prinl "Host: " Host "^M") - (prinl "Accept-Charset: utf-8^M") - (prinl "^M") - (and (pair How) (prin (cdr @))) - (flush) - (in Sock (run Prg 1)) ) - (close Sock) ) ) ) - -############ Native Java ############ - -(de javac (Cls Ext Impl . @) - (let (J (pack "tmp/" Cls ".java") C (pack "tmp/" Cls ".class")) - (call 'mkdir "-p" "tmp/") - (out J - (while (args) - (prinl "import " (next) ";") ) - (prinl "public class " Cls - (and Ext (pack " extends " @)) - (and Impl (pack " implements " (glue ", " Impl))) - " {" ) - (here "/**/") - (prinl "}") ) - (call "javac" "-O" "-g:none" J) - (push1 '*Bye (list 'call "rm" J C)) ) ) - # vi:et:ts=3:sw=3 diff --git a/ersatz/picolisp.jar b/ersatz/picolisp.jar Binary files differ. diff --git a/ersatz/sys.src b/ersatz/sys.src @@ -1,4 +1,4 @@ -// 28nov10abu +// 25jan11abu // (c) Software Lab. Alexander Burger import java.util.*; @@ -73,8 +73,8 @@ public class PicoLisp { try { if (first) loadAll(null); - load(null, ':', Nil); - bye(0); + for (;;) + load(null, ':', Nil); } catch (Control e) {} catch (Throwable e) {error(null, null, e.toString());} @@ -82,14 +82,17 @@ public class PicoLisp { } final static void init() { + int i; String s; Home = ""; - for (int i = 0; i < Argv.length; ++i) - if ((s = Argv[i]).charAt(0) != '-') { - if ((i = s.lastIndexOf('/')) >= 0 && !(i == 1 && s.charAt(0) == '.')) - Home = s.substring(0, i+1); - break; - } + if (Argv.length > 0 && Argv[Argv.length-1].equals("+")) { + Dbg.Car = T; + String[] a = new String[Argv.length-1]; + System.arraycopy(Argv, 0, a, 0, a.length); + Argv = a; + } + if (Argv.length > 0 && (s = Argv[0]).charAt(0) != '-' && ((i = s.lastIndexOf('/')) >= 0 && !(i == 1 && s.charAt(0) == '.'))) + Home = s.substring(0, i+1); try { if (Term != null) { final Pipe p = Pipe.open(); @@ -99,12 +102,12 @@ public class PicoLisp { public void run() { for (;;) { String s = Term.readLine(); - if (s == null) - Line.append('\0'); - else { - Line.append(s); - Line.append('\n'); + if (s == null) { + StdOut.newline(); + bye(0); } + Line.append(s); + Line.append('\n'); try {p.sink().write(ByteBuffer.allocate(1));} catch (IOException e) {giveup(e);} } @@ -469,8 +472,11 @@ public class PicoLisp { if (InFile.Chr == '\n') InFile.Chr = 0; } - if (y == Nil) - break; + if (y == Nil) { + Env.popInFiles(); + Transient.clear(); + return x; + } if (InFile.Name != null || InFile.Chr != 0 || pr == '\0') x = y.eval(); else { @@ -484,9 +490,6 @@ public class PicoLisp { OutFile.newline(); } } - Env.popInFiles(); - Transient.clear(); - return x; } final static String opt() { @@ -728,7 +731,17 @@ public class PicoLisp { if (x instanceof Number || x == Nil) return null; if (x instanceof Symbol) - return (s==Nil? x!=At && firstChar(x)=='@' : memq(x,s)!=null)? x.Car : null; + return x != x.Car && (s==Nil? x!=At && firstChar(x)=='@' : memq(x,s)!=null)? x.Car : null; + if (x.Car == Up) { + x = x.Cdr; + if (!((y = x.Car.eval()) instanceof Cell)) + return (z = fill(x.Cdr, s)) == null? x.Cdr : z; + Any w = y; + while (y.Cdr instanceof Cell) + y = y.Cdr; + y.Cdr = (z = fill(x.Cdr, s)) == null? x.Cdr : z; + return w; + } if ((y = fill(x.Car, s)) != null) { z = fill(x.Cdr, s); return new Cell(y, z == null? x.Cdr : z); @@ -1339,8 +1352,7 @@ public class PicoLisp { waitFd(null, 0, -1); ((Pipe.SourceChannel)StdIn.Chan).read(ByteBuffer.allocate(1)); } - if ((Chr = Line.charAt(0)) == '\0') - Chr = -1; + Chr = Line.charAt(0); Line.deleteCharAt(0); } if (Chr < 0) { @@ -1518,7 +1530,10 @@ public class PicoLisp { } if (Chr == ',') { get(); - return (y = idx(Uni, x = read0(false), 1)) instanceof Cell? y.Car : x; + x = read0(false); + if (Uni.Car != T) + x = (y = idx(Uni, x, 1)) instanceof Cell? y.Car : x; + return x; } if (Chr == '`') { get(); diff --git a/lib.l b/lib.l @@ -1,4 +1,4 @@ -# 23nov10abu +# 18jan11abu # (c) Software Lab. Alexander Burger (de task (Key . Prg) @@ -181,6 +181,14 @@ (de release (File) (ctl File (out File)) ) +# Temporary Files +(de tmp @ + (unless *Tmp + (push '*Bye '(call 'rm "-r" *Tmp)) + (push '*Fork '(off *Tmp) '(del '(call 'rm "-r" *Tmp) '*Bye)) + (call 'mkdir "-p" (setq *Tmp (pack "tmp/" *Pid "/"))) ) + (pass pack *Tmp) ) + ### List ### (de insert (N Lst X) (conc @@ -251,6 +259,40 @@ (de var: X (apply meta X This) ) +### Math ### +(de sqrt (N F) + (cond + ((lt0 N) (quit "Bad argument" N)) + (N + (let (A 1 B 0) + (while (>= N A) + (setq A (>> -2 A)) ) + (loop + (if (> (inc 'B A) N) + (dec 'B A) + (dec 'N B) + (inc 'B A) ) + (setq B (>> 1 B) A (>> 2 A)) + (T (=0 A)) ) + (and F (> N B) (inc 'B)) + B ) ) ) ) + +# (Knuth Vol.2, p.442) +(de ** (X N) # N th power of X + (let Y 1 + (loop + (when (bit? 1 N) + (setq Y (* Y X)) ) + (T (=0 (setq N (>> 1 N))) + Y ) + (setq X (* X X)) ) ) ) + +(de accu (Var Key Val) + (when Val + (if (assoc Key (val Var)) + (con @ (+ Val (cdr @))) + (push Var (cons Key Val)) ) ) ) + ### Pretty Printing ### (de *PP T NIL if ifn when unless while until do case state for @@ -373,4 +415,25 @@ (println '|) (mapc prin Y) ) ) ) ) ) +### Check ### +# Assertions +(de assert Prg + (when *Dbg + (cons + (list 'unless + (if (cdr Prg) (cons 'and Prg) (car Prg)) + (list 'quit "'assert' failed" (lit (car Prg))) ) ) ) ) + +# Unit tests +(de test (Pat . Prg) + (bind (fish pat? Pat) + (unless (match Pat (run Prg 1)) + (msg Prg) + (quit "'test' failed" Pat) ) ) ) + +### Debug ### +`*Dbg +(load "@lib/debug.l" "@lib/led.l" "@lib/edit.l" "@lib/lint.l") +(noLint 'later (loc "@Prg" later)) + # vi:et:ts=3:sw=3 diff --git a/lib/debug.l b/lib/debug.l @@ -1,4 +1,4 @@ -# 11nov10abu +# 17jan11abu # (c) Software Lab. Alexander Burger # Browsing @@ -333,24 +333,6 @@ (make (while (args) (link "-C" (next)))) 'ps "-H" "-o" "pid,ppid,start,size,pcpu,wchan,cmd" ) ) -# Hex Dump -(de hd (File Cnt) - (in File - (let Pos 0 - (while - (and - (nand Cnt (lt0 (dec 'Cnt))) - (make (do 16 (and (rd 1) (link @)))) ) - (let L @ - (prin (pad 8 (hex Pos)) " ") - (inc 'Pos 16) - (for N L - (prin (pad 2 (hex N)) " ") ) - (space (inc (* 3 (- 16 (length L))))) - (for N L - (prin (if (<= 32 N 127) (char N) ".")) ) - (prinl) ) ) ) ) ) - # Benchmarking (de bench Prg (let U (usec) diff --git a/lib/form.l b/lib/form.l @@ -1,4 +1,4 @@ -# 15nov10abu +# 24jan11abu # (c) Software Lab. Alexander Burger # *PRG *Top *Gui *Btn *Get *Got *Form *Evt *Lock *Spans @@ -184,7 +184,7 @@ ((match '("-" @X "." "h" "t" "m" "l") Url) (try 'html> (extern (ht:Pack @X))) ) ((disallowed) - (msg *Url " not allowed") + (notAllowed *Url) (http404) ) ((= '@ (car Url)) ((intern (pack (cdr Url)))) ) diff --git a/lib/frac.l b/lib/frac.l @@ -1,4 +1,4 @@ -# 25jun10abu +# 23jan11abu # (c) Software Lab. Alexander Burger (de gcd (A B) @@ -41,9 +41,7 @@ (de f- (A B) (if B - (prog1 - (f+ A B) - (set @ (- (car A))) ) + (f+ A (f- B)) (cons (- (car A)) (cdr A)) ) ) (de f* (A B) diff --git a/lib/http.l b/lib/http.l @@ -1,4 +1,4 @@ -# 08dec10abu +# 24jan11abu # (c) Software Lab. Alexander Burger # *Home *Gate *Host *Port *Port1 *Port% *Http1 *Chunked @@ -118,6 +118,9 @@ (and *Tmp (pre? *Tmp *Url)) (find pre? (cdr *Allow) (circ *Url)) ) ) ) ) +(de notAllowed (X S) + (msg X S " [" *Adr "] not allowed") ) + # Application startup (de app () (unless *SesId @@ -207,11 +210,11 @@ (try 'html> (extern (ht:Pack @X))) ) ((= '@ (car @U)) (if (disallowed) - (prog (msg *Url " not allowed") (http404)) + (prog (notAllowed *Url) (http404)) (and *SesId (timeout *Timeout)) (apply (val (intern (ht:Pack (cdr @U)))) L) ) ) ((disallowed) - (msg *Url " not allowed") + (notAllowed *Url) (http404) ) ((tail '("." "l") @U) (and *SesId (timeout *Timeout)) @@ -314,7 +317,7 @@ (T (msg @Z " bad suffix") (throw "http")) ) ) ) (cond ((and *Allow (not (idx *Allow "Var"))) - (msg "Var" ': " not allowed") + (notAllowed "Var" ':) (throw "http") ) ((not @N) (nond diff --git a/lib/led.l b/lib/led.l @@ -1,4 +1,4 @@ -# 26apr10abu +# 18jan11abu # (c) Software Lab. Alexander Burger # Line editor @@ -363,7 +363,7 @@ '("^J" "^M") ) (case "C" (NIL (bye)) - ("^D" (prinl) (tell 'bye) (bye)) + ("^D" (prinl) (bye)) ("^X" (prin (cdr *Tsm)) (prinl) (quit)) ) ((if "Insert" insMode cmdMode) "C") ) ) ) diff --git a/lib/misc.l b/lib/misc.l @@ -1,4 +1,4 @@ -# 30aug10abu +# 17jan11abu # (c) Software Lab. Alexander Burger # *Allow *Tmp @@ -39,40 +39,6 @@ ("loc" (read)) (set (link @) (name (read))) ) ) ) ) ) -### Math ### -(de sqrt (N F) - (cond - ((lt0 N) (quit "Bad argument" N)) - (N - (let (A 1 B 0) - (while (>= N A) - (setq A (>> -2 A)) ) - (loop - (if (> (inc 'B A) N) - (dec 'B A) - (dec 'N B) - (inc 'B A) ) - (setq B (>> 1 B) A (>> 2 A)) - (T (=0 A)) ) - (and F (> N B) (inc 'B)) - B ) ) ) ) - -# (Knuth Vol.2, p.442) -(de ** (X N) # N th power of X - (let Y 1 - (loop - (when (bit? 1 N) - (setq Y (* Y X)) ) - (T (=0 (setq N (>> 1 N))) - Y ) - (setq X (* X X)) ) ) ) - -(de accu (Var Key Val) - (when Val - (if (assoc Key (val Var)) - (con @ (+ Val (cdr @))) - (push Var (cons Key Val)) ) ) ) - ### String ### (de align (X . @) (pack @@ -122,27 +88,38 @@ (format N 2 *Sep0 *Sep3) ) ) (de round (N D) - (if (>= *Scl D) + (if (>= *Scl (default D 3)) (format (*/ N (** 10 (- *Scl D))) D *Sep0 *Sep3) (format N *Scl *Sep0 *Sep3) ) ) +# Binary notation +(de bin (X) + (cond + ((num? X) + (let (S (and (lt0 X) '-) L (& 1 X)) + (until (=0 (setq X (>> 1 X))) + (push 'L (& 1 X)) ) + (pack S L) ) ) + ((setq X (chop X)) + (let (S (and (= '- (car X)) (pop 'X)) N 0) + (for C X + (setq N (| (format C) (>> -1 N))) ) + (if S (- N) N) ) ) ) ) + # Octal notation (de oct (X) (cond ((num? X) - (let (S (and (lt0 X) '-) L (oct1 X)) + (let (S (and (lt0 X) '-) L (& 7 X)) (until (=0 (setq X (>> 3 X))) - (push 'L (oct1 X)) ) + (push 'L (& 7 X)) ) (pack S L) ) ) ((setq X (chop X)) (let (S (and (= '- (car X)) (pop 'X)) N 0) (for C X - (setq N (+ (format C) (>> -3 N))) ) + (setq N (| (format C) (>> -3 N))) ) (if S (- N) N) ) ) ) ) -(de oct1 (N) - (char (+ (& N 7) `(char "0"))) ) - # Hexadecimal notation (de hex (X) (cond @@ -157,7 +134,7 @@ (setq C (- (char C) `(char "0"))) (and (> C 9) (dec 'C 7)) (and (> C 22) (dec 'C 32)) - (setq N (+ C (>> -4 N))) ) + (setq N (| C (>> -4 N))) ) (if S (- N) N) ) ) ) ) (de hex1 (N) @@ -397,15 +374,6 @@ (de basename (F) (pack (stem (chop F) '/)) ) -# Temporary Files -(de tmp @ - (unless *Tmp - (push '*Bye '(call 'rm "-r" *Tmp)) - (push '*Fork '(off *Tmp) '(del '(call 'rm "-r" *Tmp) '*Bye)) - (call 'mkdir "-p" (setq *Tmp (pack "tmp/" *Pid "/"))) ) - (pass pack *Tmp) ) - - # Print or eval (de prEval (Prg Ofs) (default Ofs 1) @@ -480,18 +448,24 @@ (out S (prinl "RCPT TO:" To "^M")) (pre? "250 " (in S (line T))) ) -### Assertions ### -(de assert Prg - (when *Dbg - (cons - (list 'unless - (if (cdr Prg) (cons 'and Prg) (car Prg)) - (list 'quit "'assert' failed" (lit (car Prg))) ) ) ) ) - -(de test (Pat . Prg) - (bind (fish pat? Pat) - (unless (match Pat (run Prg 1)) - (msg Prg) - (quit "'test' failed" Pat) ) ) ) +`*Dbg + +# Hex Dump +(de hd (File Cnt) + (in File + (let Pos 0 + (while + (and + (nand Cnt (lt0 (dec 'Cnt))) + (make (do 16 (and (rd 1) (link @)))) ) + (let L @ + (prin (pad 8 (hex Pos)) " ") + (inc 'Pos 16) + (for N L + (prin (pad 2 (hex N)) " ") ) + (space (inc (* 3 (- 16 (length L))))) + (for N L + (prin (if (<= 32 N 127) (char N) ".")) ) + (prinl) ) ) ) ) ) # vi:et:ts=3:sw=3 diff --git a/lib/pilog.l b/lib/pilog.l @@ -1,4 +1,4 @@ -# 28jan10abu +# 17jan11abu # (c) Software Lab. Alexander Burger # *Rule @@ -547,4 +547,7 @@ (repeat) +`*Dbg +(load "@lib/sq.l") + # vi:et:ts=3:sw=3 diff --git a/lib/tags b/lib/tags @@ -1,12 +1,12 @@ ! (2841 . "@src64/flow.l") $ (2943 . "@src64/flow.l") % (2570 . "@src64/big.l") -& (2791 . "@src64/big.l") +& (2805 . "@src64/big.l") * (2389 . "@src64/big.l") */ (2446 . "@src64/big.l") + (2171 . "@src64/big.l") - (2209 . "@src64/big.l") --> (3879 . "@src64/subr.l") +-> (3909 . "@src64/subr.l") / (2511 . "@src64/big.l") : (2898 . "@src64/sym.l") :: (2922 . "@src64/sym.l") @@ -23,25 +23,25 @@ $ (2943 . "@src64/flow.l") > (2263 . "@src64/subr.l") >= (2293 . "@src64/subr.l") >> (2625 . "@src64/big.l") -abs (2715 . "@src64/big.l") +abs (2729 . "@src64/big.l") accept (139 . "@src64/net.l") -adr (613 . "@src64/main.l") -alarm (487 . "@src64/main.l") +adr (606 . "@src64/main.l") +alarm (480 . "@src64/main.l") all (772 . "@src64/sym.l") and (1621 . "@src64/flow.l") -any (3870 . "@src64/io.l") +any (3877 . "@src64/io.l") append (1338 . "@src64/subr.l") apply (591 . "@src64/apply.l") -arg (2274 . "@src64/main.l") -args (2250 . "@src64/main.l") -argv (2895 . "@src64/main.l") +arg (2267 . "@src64/main.l") +args (2243 . "@src64/main.l") +argv (2888 . "@src64/main.l") as (146 . "@src64/flow.l") asoq (3001 . "@src64/subr.l") assoc (2966 . "@src64/subr.l") at (2106 . "@src64/flow.l") atom (2381 . "@src64/subr.l") bind (1359 . "@src64/flow.l") -bit? (2732 . "@src64/big.l") +bit? (2746 . "@src64/big.l") bool (1721 . "@src64/flow.l") box (822 . "@src64/flow.l") box? (999 . "@src64/sym.l") @@ -65,7 +65,7 @@ call (3074 . "@src64/flow.l") car (5 . "@src64/subr.l") case (1962 . "@src64/flow.l") catch (2462 . "@src64/flow.l") -cd (2650 . "@src64/main.l") +cd (2643 . "@src64/main.l") cdaaar (464 . "@src64/subr.l") cdaadr (487 . "@src64/subr.l") cdaar (179 . "@src64/subr.l") @@ -82,13 +82,13 @@ cdddr (245 . "@src64/subr.l") cddr (79 . "@src64/subr.l") cdr (17 . "@src64/subr.l") chain (1141 . "@src64/subr.l") -char (3352 . "@src64/io.l") +char (3359 . "@src64/io.l") chop (1093 . "@src64/sym.l") circ (816 . "@src64/subr.l") circ? (2398 . "@src64/subr.l") clip (1795 . "@src64/subr.l") -close (4258 . "@src64/io.l") -cmd (2877 . "@src64/main.l") +close (4265 . "@src64/io.l") +cmd (2870 . "@src64/main.l") cnt (1291 . "@src64/apply.l") co (2544 . "@src64/flow.l") commit (1496 . "@src64/db.l") @@ -98,10 +98,10 @@ cond (1916 . "@src64/flow.l") connect (201 . "@src64/net.l") cons (747 . "@src64/subr.l") copy (1225 . "@src64/subr.l") -ctl (4198 . "@src64/io.l") -ctty (2675 . "@src64/main.l") +ctl (4205 . "@src64/io.l") +ctty (2668 . "@src64/main.l") cut (1797 . "@src64/sym.l") -date (2389 . "@src64/main.l") +date (2382 . "@src64/main.l") dbck (2105 . "@src64/db.l") de (531 . "@src64/flow.l") dec (2323 . "@src64/big.l") @@ -111,23 +111,23 @@ del (1852 . "@src64/sym.l") delete (1401 . "@src64/subr.l") delq (1452 . "@src64/subr.l") diff (2585 . "@src64/subr.l") -dir (2808 . "@src64/main.l") +dir (2801 . "@src64/main.l") dm (543 . "@src64/flow.l") do (2136 . "@src64/flow.l") e (2904 . "@src64/flow.l") -echo (4289 . "@src64/io.l") -env (625 . "@src64/main.l") -eof (3429 . "@src64/io.l") -eol (3420 . "@src64/io.l") -errno (1385 . "@src64/main.l") +echo (4296 . "@src64/io.l") +env (618 . "@src64/main.l") +eof (3436 . "@src64/io.l") +eol (3427 . "@src64/io.l") +errno (1378 . "@src64/main.l") eval (182 . "@src64/flow.l") -ext (5019 . "@src64/io.l") +ext (5026 . "@src64/io.l") ext? (1034 . "@src64/sym.l") extern (900 . "@src64/sym.l") extra (1263 . "@src64/flow.l") extract (1096 . "@src64/apply.l") fifo (1963 . "@src64/sym.l") -file (2755 . "@src64/main.l") +file (2748 . "@src64/main.l") fill (3236 . "@src64/subr.l") filter (1039 . "@src64/apply.l") fin (2029 . "@src64/subr.l") @@ -136,55 +136,56 @@ find (1200 . "@src64/apply.l") fish (1491 . "@src64/apply.l") flg? (2441 . "@src64/subr.l") flip (1695 . "@src64/subr.l") -flush (4994 . "@src64/io.l") +flush (5001 . "@src64/io.l") fold (3343 . "@src64/sym.l") for (2225 . "@src64/flow.l") fork (3248 . "@src64/flow.l") format (2089 . "@src64/big.l") free (2047 . "@src64/db.l") -from (3448 . "@src64/io.l") +from (3455 . "@src64/io.l") full (1075 . "@src64/subr.l") fun? (734 . "@src64/sym.l") gc (429 . "@src64/gc.l") -ge0 (2691 . "@src64/big.l") +ge0 (2705 . "@src64/big.l") get (2750 . "@src64/sym.l") getd (742 . "@src64/sym.l") getl (3032 . "@src64/sym.l") glue (1234 . "@src64/sym.l") -gt0 (2702 . "@src64/big.l") +gt0 (2716 . "@src64/big.l") head (1816 . "@src64/subr.l") -heap (542 . "@src64/main.l") -hear (3131 . "@src64/io.l") +heap (535 . "@src64/main.l") +hear (3140 . "@src64/io.l") host (184 . "@src64/net.l") id (1027 . "@src64/db.l") idx (2037 . "@src64/sym.l") if (1802 . "@src64/flow.l") if2 (1821 . "@src64/flow.l") ifn (1862 . "@src64/flow.l") -in (4094 . "@src64/io.l") +in (4101 . "@src64/io.l") inc (2256 . "@src64/big.l") index (2633 . "@src64/subr.l") -info (2712 . "@src64/main.l") +info (2705 . "@src64/main.l") intern (875 . "@src64/sym.l") ipid (3193 . "@src64/flow.l") isa (959 . "@src64/flow.l") job (1426 . "@src64/flow.l") journal (970 . "@src64/db.l") -key (3279 . "@src64/io.l") +key (3288 . "@src64/io.l") kill (3225 . "@src64/flow.l") last (2040 . "@src64/subr.l") +le0 (2691 . "@src64/big.l") length (2737 . "@src64/subr.l") let (1476 . "@src64/flow.l") let? (1537 . "@src64/flow.l") lieu (1156 . "@src64/db.l") -line (3604 . "@src64/io.l") -lines (3757 . "@src64/io.l") +line (3611 . "@src64/io.l") +lines (3764 . "@src64/io.l") link (1172 . "@src64/subr.l") -lisp (1952 . "@src64/main.l") +lisp (1945 . "@src64/main.l") list (887 . "@src64/subr.l") listen (151 . "@src64/net.l") lit (157 . "@src64/flow.l") -load (4071 . "@src64/io.l") +load (4078 . "@src64/io.l") lock (1184 . "@src64/db.l") loop (2168 . "@src64/flow.l") low? (3215 . "@src64/sym.l") @@ -219,10 +220,10 @@ n== (2083 . "@src64/subr.l") nT (2194 . "@src64/subr.l") name (499 . "@src64/sym.l") nand (1656 . "@src64/flow.l") -native (1393 . "@src64/main.l") +native (1386 . "@src64/main.l") need (919 . "@src64/subr.l") new (833 . "@src64/flow.l") -next (2257 . "@src64/main.l") +next (2250 . "@src64/main.l") nil (1739 . "@src64/flow.l") nond (1939 . "@src64/flow.l") nor (1677 . "@src64/flow.l") @@ -234,120 +235,120 @@ offset (2673 . "@src64/subr.l") on (1583 . "@src64/sym.l") onOff (1613 . "@src64/sym.l") one (1646 . "@src64/sym.l") -open (4220 . "@src64/io.l") +open (4227 . "@src64/io.l") opid (3209 . "@src64/flow.l") -opt (2998 . "@src64/main.l") +opt (2991 . "@src64/main.l") or (1637 . "@src64/flow.l") -out (4114 . "@src64/io.l") +out (4121 . "@src64/io.l") pack (1144 . "@src64/sym.l") pair (2390 . "@src64/subr.l") pass (632 . "@src64/apply.l") pat? (720 . "@src64/sym.l") -path (1230 . "@src64/io.l") -peek (3336 . "@src64/io.l") +path (1238 . "@src64/io.l") +peek (3343 . "@src64/io.l") pick (1247 . "@src64/apply.l") -pipe (4135 . "@src64/io.l") -poll (3223 . "@src64/io.l") +pipe (4142 . "@src64/io.l") +poll (3232 . "@src64/io.l") pool (648 . "@src64/db.l") pop (1773 . "@src64/sym.l") port (5 . "@src64/net.l") -pr (5102 . "@src64/io.l") +pr (5109 . "@src64/io.l") pre? (1411 . "@src64/sym.l") -prin (4918 . "@src64/io.l") -prinl (4932 . "@src64/io.l") -print (4958 . "@src64/io.l") -println (4989 . "@src64/io.l") -printsp (4974 . "@src64/io.l") +prin (4925 . "@src64/io.l") +prinl (4939 . "@src64/io.l") +print (4965 . "@src64/io.l") +println (4996 . "@src64/io.l") +printsp (4981 . "@src64/io.l") prior (2709 . "@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 (3493 . "@src64/subr.l") +protect (525 . "@src64/main.l") +prove (3523 . "@src64/subr.l") push (1688 . "@src64/sym.l") push1 (1724 . "@src64/sym.l") put (2698 . "@src64/sym.l") putl (2950 . "@src64/sym.l") -pwd (2639 . "@src64/main.l") +pwd (2632 . "@src64/main.l") queue (1920 . "@src64/sym.l") -quit (1102 . "@src64/main.l") +quit (1095 . "@src64/main.l") quote (141 . "@src64/flow.l") -rand (2959 . "@src64/big.l") +rand (2973 . "@src64/big.l") range (997 . "@src64/subr.l") rank (3029 . "@src64/subr.l") -raw (465 . "@src64/main.l") -rd (5036 . "@src64/io.l") -read (2562 . "@src64/io.l") +raw (458 . "@src64/main.l") +rd (5043 . "@src64/io.l") +read (2571 . "@src64/io.l") replace (1499 . "@src64/subr.l") -rest (2303 . "@src64/main.l") +rest (2296 . "@src64/main.l") reverse (1674 . "@src64/subr.l") -rewind (5002 . "@src64/io.l") +rewind (5009 . "@src64/io.l") rollback (1890 . "@src64/db.l") rot (848 . "@src64/subr.l") -rpc (5135 . "@src64/io.l") +rpc (5142 . "@src64/io.l") run (313 . "@src64/flow.l") sect (2537 . "@src64/subr.l") -seed (2944 . "@src64/big.l") +seed (2958 . "@src64/big.l") seek (1153 . "@src64/apply.l") send (1131 . "@src64/flow.l") seq (1083 . "@src64/db.l") set (1482 . "@src64/sym.l") setq (1515 . "@src64/sym.l") -sigio (503 . "@src64/main.l") +sigio (496 . "@src64/main.l") size (2802 . "@src64/subr.l") -skip (3406 . "@src64/io.l") -sort (3928 . "@src64/subr.l") +skip (3413 . "@src64/io.l") +sort (3958 . "@src64/subr.l") sp? (711 . "@src64/sym.l") -space (4936 . "@src64/io.l") +space (4943 . "@src64/io.l") split (1588 . "@src64/subr.l") -stack (571 . "@src64/main.l") +stack (564 . "@src64/main.l") state (2006 . "@src64/flow.l") stem (1985 . "@src64/subr.l") -str (3924 . "@src64/io.l") +str (3931 . "@src64/io.l") str? (1013 . "@src64/sym.l") strip (1572 . "@src64/subr.l") sub? (1444 . "@src64/sym.l") sum (1338 . "@src64/apply.l") super (1218 . "@src64/flow.l") -sym (3910 . "@src64/io.l") +sym (3917 . "@src64/io.l") sym? (2430 . "@src64/subr.l") -sync (3091 . "@src64/io.l") +sync (3100 . "@src64/io.l") sys (3045 . "@src64/flow.l") t (1748 . "@src64/flow.l") tail (1907 . "@src64/subr.l") -tell (3163 . "@src64/io.l") +tell (3172 . "@src64/io.l") text (1272 . "@src64/sym.l") throw (2488 . "@src64/flow.l") tick (3161 . "@src64/flow.l") -till (3515 . "@src64/io.l") -time (2522 . "@src64/main.l") +till (3522 . "@src64/io.l") +time (2515 . "@src64/main.l") touch (1049 . "@src64/sym.l") trim (1755 . "@src64/subr.l") try (1172 . "@src64/flow.l") type (912 . "@src64/flow.l") udp (268 . "@src64/net.l") -unify (3901 . "@src64/subr.l") +unify (3931 . "@src64/subr.l") unless (1898 . "@src64/flow.l") until (2082 . "@src64/flow.l") -up (716 . "@src64/main.l") +up (709 . "@src64/main.l") upp? (3230 . "@src64/sym.l") uppc (3294 . "@src64/sym.l") use (1570 . "@src64/flow.l") -usec (2627 . "@src64/main.l") +usec (2620 . "@src64/main.l") val (1463 . "@src64/sym.l") -version (3012 . "@src64/main.l") -wait (3053 . "@src64/io.l") +version (3005 . "@src64/main.l") +wait (3062 . "@src64/io.l") when (1881 . "@src64/flow.l") while (2058 . "@src64/flow.l") wipe (3090 . "@src64/sym.l") with (1327 . "@src64/flow.l") -wr (5119 . "@src64/io.l") +wr (5126 . "@src64/io.l") xchg (1538 . "@src64/sym.l") xor (1698 . "@src64/flow.l") -x| (2871 . "@src64/big.l") +x| (2885 . "@src64/big.l") yield (2699 . "@src64/flow.l") yoke (1196 . "@src64/subr.l") zap (1063 . "@src64/sym.l") zero (1631 . "@src64/sym.l") -| (2831 . "@src64/big.l") +| (2845 . "@src64/big.l") diff --git a/lib/test.l b/lib/test.l @@ -1,10 +1,8 @@ -# 18may10abu +# 18jan11abu # (c) Software Lab. Alexander Burger ### Unit Tests ### -# $(/bin/pwd)/p lib/test.l -bye - -(load "dbg.l") +# $(/bin/pwd)/p lib/test.l -bye + (test T (pool (tmp "db"))) diff --git a/lib/tsm.l b/lib/tsm.l @@ -0,0 +1,10 @@ +# 18jan11abu +# (c) Software Lab. Alexander Burger + +(when (sys "TERM") + (setq *Tsm + (cons + (in '("tput" "smul") (line T)) + (in '("tput" "rmul") (line T)) ) ) ) + +# vi:et:ts=3:sw=3 diff --git a/plmod b/plmod @@ -1,2 +1,2 @@ #!/bin/sh -exec ${0%/*}/bin/picolisp -"on *Dbg" ${0%/*}/lib.l @ext.l @plmod.l "$@" +exec ${0%/*}/bin/picolisp ${0%/*}/lib.l -"on *Dbg" @ext.l @plmod.l "$@" diff --git a/plmod.l b/plmod.l @@ -1,9 +1,9 @@ -# 16feb10abu +# 17jan11abu # (c) Software Lab. Alexander Burger (on *Dbg) -(off *Tsm) -(load "@lib/debug.l" "@lib/edit.l" "@lib/lint.l" "@lib/sq.l") + +(load "@lib/debug.l" "@lib/edit.l" "@lib/lint.l") (noLint 'later (loc "@Prg" later)) diff --git a/src/big.c b/src/big.c @@ -1,4 +1,4 @@ -/* 03oct10abu +/* 23jan11abu * (c) Software Lab. Alexander Burger */ @@ -961,6 +961,12 @@ any doLt0(any x) { return isNum(x = EVAL(car(x))) && isNeg(x)? x : Nil; } +// (le0 'any) -> num | NIL +any doLe0(any x) { + x = cdr(x); + return isNum(x = EVAL(car(x))) && (isNeg(x) || IsZero(x))? x : Nil; +} + // (ge0 'any) -> num | NIL any doGe0(any x) { x = cdr(x); diff --git a/src/io.c b/src/io.c @@ -1,4 +1,4 @@ -/* 14oct10abu +/* 19jan11abu * (c) Software Lab. Alexander Burger */ @@ -122,8 +122,12 @@ int slow(inFile *p, bool nb) { n = read(p->fd, p->buf, BUFSIZ); if (nb) fcntl(p->fd, F_SETFL, f); - if (n >= 0) + if (n > 0) return p->cnt = n; + if (n == 0) { + p->ix = p->cnt = -1; + return 0; + } if (errno == EAGAIN) return -1; if (errno != EINTR) @@ -242,13 +246,13 @@ void flushAll(void) { static int stdinByte(void) { inFile *p; - if (!(p = InFiles[STDIN_FILENO]) || p->ix == p->cnt && !slow(p,NO)) - return -1; + if (!(p = InFiles[STDIN_FILENO]) || p->ix == p->cnt && (p->ix < 0 || !slow(p,NO))) + bye(0); return p->buf[p->ix++]; } static int getBinary(void) { - if (!InFile || InFile->ix == InFile->cnt && !slow(InFile,NO)) + if (!InFile || InFile->ix == InFile->cnt && (InFile->ix < 0 || !slow(InFile,NO))) return -1; return InFile->buf[InFile->ix++]; } @@ -831,7 +835,7 @@ void getStdin(void) { if (!InFile) Chr = -1; else if (InFile != InFiles[STDIN_FILENO]) { - if (InFile->ix == InFile->cnt && !slow(InFile,NO)) { + if (InFile->ix == InFile->cnt && (InFile->ix < 0 || !slow(InFile,NO))) { Chr = -1; return; } @@ -1139,10 +1143,13 @@ static any read0(bool top) { } if (Chr == ',') { Env.get(); - Push(c1, x = read0(NO)); - if (isCell(y = idx(Uni, data(c1), 1))) - x = car(y); - drop(c1); + x = read0(NO); + if (val(Uni) != T) { + Push(c1, x); + if (isCell(y = idx(Uni, data(c1), 1))) + x = car(y); + drop(c1); + } return x; } if (Chr == '`') { @@ -1617,27 +1624,21 @@ any doPoll(any ex) { // (key ['cnt]) -> sym any doKey(any ex) { any x; - int c, d, e; + int c, d; flushAll(); setRaw(); x = cdr(ex); if (!waitFd(ex, STDIN_FILENO, isNil(x = EVAL(car(x)))? -1 : xCnt(ex,x))) return Nil; - if ((c = stdinByte()) < 0) - return Nil; - if (c == 0xFF) + if ((c = stdinByte()) == 0xFF) c = TOP; else if (c & 0x80) { - if ((d = stdinByte()) < 0) - return Nil; + d = stdinByte(); if ((c & 0x20) == 0) c = (c & 0x1F) << 6 | d & 0x3F; - else { - if ((e = stdinByte()) < 0) - return Nil; - c = ((c & 0xF) << 6 | d & 0x3F) << 6 | e & 0x3F; - } + else + c = ((c & 0xF) << 6 | d & 0x3F) << 6 | stdinByte() & 0x3F; } return mkChar(c); } @@ -2001,8 +2002,11 @@ any load(any ex, int pr, any x) { if (Chr == '\n') Chr = 0; } - if (isNil(data(c1))) - break; + if (isNil(data(c1))) { + popInFiles(); + doHide(Nil); + return x; + } Save(c1); if (InFile != InFiles[STDIN_FILENO] || Chr || !pr) x = EVAL(data(c1)); @@ -2015,9 +2019,6 @@ any load(any ex, int pr, any x) { } drop(c1); } - popInFiles(); - doHide(Nil); - return x; } // (load 'any ..) -> any diff --git a/src/main.c b/src/main.c @@ -1,4 +1,4 @@ -/* 07dec10abu +/* 18jan11abu * (c) Software Lab. Alexander Burger */ @@ -1163,23 +1163,20 @@ any loadAll(any ex) { /*** Main ***/ static void init(int ac, char *av[]) { - int i; char *p; sigset_t sigs; - for (i = 1; i < ac; ++i) - if (*av[i] != '-') { - if ((p = strrchr(av[i], '/')) && !(p == av[i]+1 && *av[i] == '.')) { - Home = malloc(p - av[i] + 2); - memcpy(Home, av[i], p - av[i] + 1); - Home[p - av[i] + 1] = '\0'; - } - break; - } AV0 = *av++; AV = av; heapAlloc(); initSymbols(); + if (strcmp(av[ac-2], "+") == 0) + val(Dbg) = T, av[ac-2] = NULL; + if (av[0] && *av[0] != '-' && (p = strrchr(av[0], '/')) && !(p == av[0]+1 && *av[0] == '.')) { + Home = malloc(p - av[0] + 2); + memcpy(Home, av[0], p - av[0] + 1); + Home[p - av[0] + 1] = '\0'; + } Env.get = getStdin; InFile = initInFile(STDIN_FILENO, NULL); Env.put = putStdout; @@ -1214,6 +1211,6 @@ int MAIN(int ac, char *av[]) { ++Repl; iSignal(SIGINT, sig); } - load(NULL, ':', Nil); - bye(0); + for (;;) + load(NULL, ':', Nil); } diff --git a/src/pico.h b/src/pico.h @@ -1,4 +1,4 @@ -/* 25nov10abu +/* 23jan11abu * (c) Software Lab. Alexander Burger */ @@ -557,6 +557,7 @@ any doKey(any); any doKill(any); any doLast(any); any doLe(any); +any doLe0(any); any doLength(any); any doLet(any); any doLetQ(any); diff --git a/src/subr.c b/src/subr.c @@ -1,4 +1,4 @@ -/* 13dec10abu +/* 25jan11abu * (c) Software Lab. Alexander Burger */ @@ -678,7 +678,7 @@ any doSplit(any x) { y = data(sub) = cons(car(data(c1)), Nil); else y = cdr(y) = cons(car(data(c1)), Nil); - spl1: ; +spl1: ; } while (isCell(data(c1) = cdr(data(c1)))); y = cons(data(sub), Nil); drop(c1); @@ -1386,13 +1386,23 @@ static any fill(any x, any s) { if (isNum(x)) return NULL; if (isSym(x)) - return (isNil(s)? x!=At && firstByte(x)=='@' : memq(x,s)!=NULL)? val(x) : NULL; - if (y = fill(car(x),s)) { + return x != val(x) && (isNil(s)? x!=At && firstByte(x)=='@' : memq(x,s)!=NULL)? val(x) : NULL; + if (car(x) == Up) { + x = cdr(x); + if (!isCell(y = EVAL(car(x)))) + return fill(cdr(x), s) ?: cdr(x); + Push(c1, y); + while (isCell(cdr(y))) + y = cdr(y); + cdr(y) = fill(cdr(x), s) ?: cdr(x); + return Pop(c1); + } + if (y = fill(car(x), s)) { Push(c1,y); - y = fill(cdr(x),s); + y = fill(cdr(x), s); return cons(Pop(c1), y ?: cdr(x)); } - if (y = fill(cdr(x),s)) + if (y = fill(cdr(x), s)) return cons(car(x), y); return NULL; } @@ -1403,7 +1413,7 @@ any doFill(any x) { x = cdr(x), Push(c1, EVAL(car(x))); x = cdr(x), Push(c2, EVAL(car(x))); - if (x = fill(data(c1),data(c2))) { + if (x = fill(data(c1), data(c2))) { drop(c1); return x; } @@ -1416,7 +1426,7 @@ cell *Penv, *Pnl; static bool unify(any n1, any x1, any n2, any x2) { any x, env; - lookup1: +lookup1: if (isSym(x1) && firstByte(x1) == '@') for (x = data(*Penv); isCell(car(x)); x = cdr(x)) if (unDig(n1) == unDig(caaar(x)) && x1 == cdaar(x)) { @@ -1424,7 +1434,7 @@ static bool unify(any n1, any x1, any n2, any x2) { x1 = cddar(x); goto lookup1; } - lookup2: +lookup2: if (isSym(x2) && firstByte(x2) == '@') for (x = data(*Penv); isCell(car(x)); x = cdr(x)) if (unDig(n2) == unDig(caaar(x)) && x2 == cdaar(x)) { @@ -1461,7 +1471,7 @@ static any lup(any n, any x) { any y; cell c1; - lup: +lup: if (isSym(x) && firstByte(x) == '@') for (y = data(*Penv); isCell(car(y)); y = cdr(y)) if (unDig(n) == unDig(caaar(y)) && x == cdaar(y)) { diff --git a/src/tab.c b/src/tab.c @@ -1,4 +1,4 @@ -/* 25nov10abu +/* 23jan11abu * (c) Software Lab. Alexander Burger */ @@ -171,6 +171,7 @@ static symInit Symbols[] = { {doKill, "kill"}, {doLast, "last"}, {doLe, "<="}, + {doLe0, "le0"}, {doLength, "length"}, {doLet, "let"}, {doLetQ, "let?"}, diff --git a/src64/apply.l b/src64/apply.l @@ -1,4 +1,4 @@ -# 12oct10abu +# 25jan11abu # (c) Software Lab. Alexander Burger (code 'applyXYZ_E 0) @@ -130,7 +130,7 @@ end ld Z (C CDR) # Body in Z prog Z # Run body - null (EnvNext) # VarArgs? + null (EnvArgs) # VarArgs? if nz # Yes drop # Drop varArgs end @@ -266,7 +266,7 @@ end ld Z (C CDR) # Body in Z prog Z # Run body - null (EnvNext) # VarArgs? + null (EnvArgs) # VarArgs? if nz # Yes drop # Drop varArgs end @@ -423,7 +423,7 @@ end ld Z (C CDR) # Body in Z prog Z # Run body - null (EnvNext) # VarArgs? + null (EnvArgs) # VarArgs? if nz # Yes drop # Drop varArgs end @@ -559,7 +559,7 @@ end ld Z (C CDR) # Body in Z prog Z # Run body - null (EnvNext) # VarArgs? + null (EnvArgs) # VarArgs? if nz # Yes drop # Drop varArgs end diff --git a/src64/arch/x86-64.l b/src64/arch/x86-64.l @@ -1,4 +1,4 @@ -# 12oct10abu +# 17jan11abu # (c) Software Lab. Alexander Burger # Byte order @@ -880,17 +880,10 @@ (asm initCode () (prinst "xor" "%r12" "%r12") # Init NULL register - (prinst "mov" "(%rsi)" "%r10") # Get command - (ifn *FPic - (prinst "mov" "%r10" "AV0") - (prinst "mov" "AV0@GOTPCREL(%rip)" "%r11") - (prinst "mov" "%r10" "(%r11)") ) - (prinst "lea" "8(%rsi)" "%r10") # Get argument vector - (ifn *FPic - (prinst "mov" "%r10" "AV") - (prinst "mov" "AV@GOTPCREL(%rip)" "%r11") - (prinst "mov" "%r10" "(%r11)") ) ) - + (prinst "mov" "(%rsi)" "%r13") # Get command in X + (prinst "lea" "8(%rsi)" "%r14") # argument vector in Y + (prinst "dec" "%rdi") # and pointer to last argument in Z + (prinst "lea" "0(%rsi,%rdi,8)" "%r15") ) ### Optimizer ### # Replace the the next 'cnt' elements with 'lst' diff --git a/src64/big.l b/src64/big.l @@ -1,4 +1,4 @@ -# 03jul10abu +# 23jan11abu # (c) Software Lab. Alexander Burger ### Destructive primitives ### @@ -2687,6 +2687,20 @@ jz retNil ret # Yes: Return num +# (le0 'any) -> num | NIL +(code 'doLe0 2) + ld E (E CDR) # Get arg + ld E (E) + eval # Eval it + num E # Number? + jz retNil + zero E # Zero? + if ne # No + test E SIGN # Negative? + jz retNil + end + ret # Yes: Return num + # (ge0 'any) -> num | NIL (code 'doGe0 2) ld E (E CDR) # Get arg diff --git a/src64/flow.l b/src64/flow.l @@ -1,4 +1,4 @@ -# 12oct10abu +# 25jan11abu # (c) Software Lab. Alexander Burger (code 'redefMsgEC) @@ -767,7 +767,7 @@ cmp Y C # End? until eq # Yes prog Z # Run body - null (EnvNext) # VarArgs? + null (EnvArgs) # VarArgs? if nz # Yes drop # Drop varArgs end @@ -3430,6 +3430,21 @@ else call xCntEX_FE end - jmp byeE +# Exit +(code 'byeE) + nul (InBye) # Re-entered? + if z # No + set (InBye) 1 + push E # Save exit code + ld C 0 # Top frame + call unwindC_Z # Unwind + ld E (Bye) # Run exit expression(s) + call execE + pop E # Restore exit code + end + call flushAll # Flush all output channels +(code 'finishE) + call setCooked # Set terminal to cooked mode + cc exit(E) # vi:et:ts=3:sw=3 diff --git a/src64/glob.l b/src64/glob.l @@ -1,4 +1,4 @@ -# 25nov10abu +# 23jan11abu # (c) Software Lab. Alexander Burger (data 'Globals 0) @@ -470,6 +470,7 @@ initSym NIL "%" doRem initSym NIL ">>" doShift initSym NIL "lt0" doLt0 + initSym NIL "le0" doLe0 initSym NIL "ge0" doGe0 initSym NIL "gt0" doGt0 initSym NIL "abs" doAbs diff --git a/src64/io.l b/src64/io.l @@ -1,4 +1,4 @@ -# 16nov10abu +# 19jan11abu # (c) Software Lab. Alexander Burger # Close file descriptor @@ -217,10 +217,15 @@ cc fcntl((C) F_SETFL A) # Restore file status flags pop A # Get 'read' return value null A # OK? - if ns # Yes + if nsz # Yes ld (C II) A # Set new 'cnt' ret # Return 'ge' end + if z # Closed + dec (C I) # 'ix' = 'cnt' = -1 + dec (C II) + ret # z + end call errno_A cmp A EAGAIN # No data available? if eq # Yes @@ -418,24 +423,27 @@ ret ### Low level I/O ### -(code 'stdinByte_FA) +(code 'stdinByte_A) push Z ld Z ((InFiles)) # Get stdin null Z # Open? if nz # Yes call getBinaryZ_FB # Get byte - zxt - pop Z - ret + if nc + zxt + pop Z + ret + end end - setc - pop Z - ret + ld E 0 # Exit OK + jmp byeE (code 'getBinaryZ_FB 0) ld A (Z I) # Get 'ix' cmp A (Z II) # Equals 'cnt'? if eq # Yes + null A # Closed? + js retc # Yes call slowZ_F # Read into buffer jz retc # EOF (c) ld A 0 # 'ix' @@ -1581,7 +1589,7 @@ ld4 (S 4) # Close write pipe call closeAX ld4 (S) # Get read pipe - cmp A 0 # STDIN_FILENO? + null A # STDIN_FILENO? if ne # No cc dup2(A 0) # Dup to STDIN_FILENO ld4 (S) # Close read pipe @@ -1673,6 +1681,8 @@ ld A (Z I) # Get 'ix' cmp A (Z II) # Equals 'cnt'? if eq # Yes + null A # Closed? + js 90 # Return -1 call slowZ_F # Read into buffer jz 90 # Return -1 ld A 0 # 'ix' @@ -1695,10 +1705,7 @@ ld E -1 # No timeout ld X 0 # Runtime expression call waitFdCEX_A # Wait for events - call stdinByte_FA # Get byte? - if c # No - ld A -1 # Return -1 - end + call stdinByte_A # Get byte else ld C (LineC) null C # First call? @@ -2280,8 +2287,10 @@ call (Get_A) # Skip ',' ld A 0 call readA_E # Read expression - ld (L I) E # Save it ld X Uni # Maintain '*Uni' index + cmp (X) TSym # Disabled? + jeq 99 # Yes + ld (L I) E # Else save expression ld Y E call idxPutXY_E atom E # Pair? @@ -3293,40 +3302,38 @@ call waitFdCEX_A # Wait for events null A # Timeout? if nz # No - call stdinByte_FA # First byte? - if nc # Yes - cmp B (hex "FF") # Special "top" character? - if ne # No - cmp B 128 # Single byte? - if ge # No - test B (hex "20") # Two bytes? - if z # Yes - and B (hex "1F") # First byte 110xxxxx - shl A 6 # xxxxx000000 - push A - else # Three bytes - and B (hex "F") # First byte 1110xxxx - shl A 6 # xxxx000000 - push A - call stdinByte_FA # Read second byte - and B (hex "3F") # 10xxxxxx - or A (S) # Combine - shl A 6 # xxxxxxxxxx000000 - ld (S) A - end - call stdinByte_FA # Read last byte + call stdinByte_A # Read first byte + cmp B (hex "FF") # Special "top" character? + if ne # No + cmp B 128 # Single byte? + if ge # No + test B (hex "20") # Two bytes? + if z # Yes + and B (hex "1F") # First byte 110xxxxx + shl A 6 # xxxxx000000 + push A + else # Three bytes + and B (hex "F") # First byte 1110xxxx + shl A 6 # xxxx000000 + push A + call stdinByte_A # Read second byte and B (hex "3F") # 10xxxxxx - or (S) A # Combine - pop A # Get result + or A (S) # Combine + shl A 6 # xxxxxxxxxx000000 + ld (S) A end - else - ld A TOP + call stdinByte_A # Read last byte + and B (hex "3F") # 10xxxxxx + or (S) A # Combine + pop A # Get result end - call mkCharA_A # Return char - ld E A - pop X - ret + else + ld A TOP end + call mkCharA_A # Return char + ld E A + pop X + ret end ld E Nil pop X diff --git a/src64/main.l b/src64/main.l @@ -1,4 +1,4 @@ -# 23dec10abu +# 25jan11abu # (c) Software Lab. Alexander Burger ### Global return labels ### @@ -29,12 +29,23 @@ ### Main entry point ### (code 'main) initCode + ld (AV0) X # Save command + ld (AV) Y # and argument vector + # Check debug mode + ld C (Z) # Last argument + ld B (C) # First byte + cmp B (char "+") # Single plus? + if eq # Yes + nul (C 1) + if z # Yes + ld (Dbg) TSym # Set '*Dbg' + ld (Z) 0 # Clear last argument + end + end # Locate home directory - ld X (AV) # Command line vector - do - ld Y (X) # Next command - null Y # Any? - while nz # Yes + ld Y (Y) # First argument + null Y # Any? + if nz # Yes ld B (Y) # First byte cmp B (char "-") # Dash? if ne # No @@ -63,10 +74,8 @@ set (Z) 0 # Clear it end end - break T end - add X I - loop + end # Initialize globals cc getpid() # PID in A shl A 4 # Make short number @@ -147,23 +156,7 @@ ld E Nil # REPL ld X 0 # Runtime expression call loadBEX_E - ld E 0 -# Exit -(code 'byeE) - nul (InBye) # Re-entered? - if z # No - set (InBye) 1 - push E # Save exit code - ld C 0 # Top frame - call unwindC_Z # Unwind - ld E (Bye) # Run exit expression(s) - call execE - pop E # Restore exit code - end - call flushAll # Flush all output channels -(code 'finishE) - call setCooked # Set terminal to cooked mode - cc exit(E) + jmp restart # Load all remaining arguments (code 'loadAllX_E) @@ -1241,7 +1234,7 @@ cmp Y C # End? until eq # Yes prog Z # Run body - null (EnvNext) # VarArgs? + null (EnvArgs) # VarArgs? if nz # Yes drop # Drop varArgs end @@ -2325,12 +2318,12 @@ ld Z A # Date function (code 'dateXYZ_E 0) - cmp Y 0 # Month <= 0? - jle retNil + null Y # Month <= 0? + jsz retNil cmp Y 12 # Month > 12? jgt retNil - cmp X 0 # Day <= 0? - jle retNil + null X # Day <= 0? + jsz retNil ld B (Y Month) # Max monthly days cmp X B # Day > max? if gt # Yes diff --git a/src64/subr.l b/src64/subr.l @@ -1,4 +1,4 @@ -# 13dec10abu +# 25jan11abu # (c) Software Lab. Alexander Burger # (car 'var) -> any @@ -3256,6 +3256,8 @@ jnz ret # Return 'nz' sym E # Data symbolic? if nz # Yes + cmp E (E) # Auto-quoting? + jeq retnz # Yes cmp X Nil # 'sym|lst'? if eq # No cmp E At # '@'? @@ -3289,6 +3291,38 @@ ld E (E) # Recurse on CAR cmp S (StkLimit) # Stack check jlt stkErr + cmp E Up # Expand expression? + if eq # Yes + pop E # Get pattern + ld E (E CDR) # Skip '^' + push (E CDR) # Save rest + ld E (E) # Eval expression + eval + atom E # List? + if nz # No + pop E # Recurse on rest + call fillE_FE + setz # Set modified + ret + end + pop C # Get pattern + link + push E # <L I> Result + link + ld E C # Recurse on rest + call fillE_FE + ld C (L I) # Result + do + atom (C CDR) # Find last cell + while z + ld C (C CDR) + loop + ld (C CDR) E # Set rest + ld E (L I) # Get result + drop + setz # Modified + ret + end call fillE_FE # Modified? if z # Yes pop C # Get pattern @@ -3296,8 +3330,6 @@ push E # <L I> Modified CAR link ld E (C CDR) # Recurse on CDR - cmp S (StkLimit) # Stack check - jlt stkErr call fillE_FE call consE_A # Cons result ld (A) (L I) @@ -3308,8 +3340,6 @@ ret end ld E ((S) CDR) # Recurse on CDR - cmp S (StkLimit) # Stack check - jlt stkErr call fillE_FE # Modified? if z # Yes call consE_A # Cons result diff --git a/src64/version.l b/src64/version.l @@ -1,6 +1,6 @@ -# 23dec10abu +# 25jan11abu # (c) Software Lab. Alexander Burger -(de *Version 3 0 4 20) +(de *Version 3 0 5 8) # vi:et:ts=3:sw=3 diff --git a/test/lib/misc.l b/test/lib/misc.l @@ -1,4 +1,4 @@ -# 09aug10abu +# 10jan11abu # (c) Software Lab. Alexander Burger ### locale ### @@ -49,9 +49,18 @@ (test "123456789" (pad 5 123456789)) +### bin ### +(test "1001001" (bin (+ 64 8 1))) +(test (+ 64 8 1) (bin "1001001")) +(test "-110110" (bin -54)) +(test -54 (bin "-110110")) + + ### oct ### (test "111" (oct (+ 64 8 1))) (test (+ 64 8 1) (oct "111")) +(test "-66" (oct -54)) +(test -54 (oct "-66")) ### hex ### @@ -73,6 +82,7 @@ (scl 4) (test "12.35" (round 123456 2)) (test "12.3456" (round 123456 6)) +(test "12.346" (round 123456)) ### balance ### diff --git a/test/src/big.l b/test/src/big.l @@ -1,4 +1,4 @@ -# 14may10abu +# 23jan11abu # (c) Software Lab. Alexander Burger ### format ### @@ -100,6 +100,12 @@ (test NIL (lt0 0)) +### le0 ### +(test -7 (le0 -7)) +(test NIL (le0 2)) +(test 0 (le0 0)) + + ### ge0 ### (test 7 (ge0 7)) (test NIL (ge0 -2)) diff --git a/test/src/subr.l b/test/src/subr.l @@ -1,4 +1,4 @@ -# 13dec10abu +# 25jan11abu # (c) Software Lab. Alexander Burger ### c[ad]*r ### @@ -461,6 +461,10 @@ (test 1234 (fill '@X)) (test '(a b (c 1234) (((1 2 3 4) . d) e)) (fill '(a b (c @X) ((@Y . d) e))) ) ) +(test (1 a b c 9) + (fill (1 ^ (list 'a 'b 'c) 9)) ) +(test (1 9) + (fill (1 ^ 7 9)) ) (let X 2 (test (1 2 3) (fill (1 X 3) 'X))) (let X 2 (test (1 2 3) (fill (1 X 3) '(X))))