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:
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
<body>Hello World!</body>
</html>
-> </html>
-: # (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
- (<h2> NIL <u>Hello</u>)
+(html 0 "Hello" "lib.css" NIL
+ (<h2> NIL "Hello")
(here) )
<p>Hello!</p>
<p>This is a test.</p>
@@ -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))))
