Repository: picolisp/pil21 Branch: master Commit: 5cf52c58c7dd Files: 202 Total size: 6.6 MB Directory structure: gitextract_pc6i5ihr/ ├── COPYING ├── INSTALL ├── README ├── bin/ │ ├── pil │ ├── psh │ ├── pty │ ├── vip │ └── watchdog ├── doc/ │ ├── ChangeLog │ ├── Tracks │ ├── des.html │ ├── doc.css │ ├── faq.html │ ├── httpGate.html │ ├── man.html │ ├── microTemplates │ ├── native.html │ ├── rc.sample │ ├── ref.html │ ├── refA.html │ ├── refB.html │ ├── refC.html │ ├── refD.html │ ├── refE.html │ ├── refF.html │ ├── refG.html │ ├── refH.html │ ├── refI.html │ ├── refJ.html │ ├── refK.html │ ├── refL.html │ ├── refM.html │ ├── refN.html │ ├── refO.html │ ├── refP.html │ ├── refQ.html │ ├── refR.html │ ├── refS.html │ ├── refT.html │ ├── refU.html │ ├── refV.html │ ├── refW.html │ ├── refX.html │ ├── refY.html │ ├── refZ.html │ ├── ref_.html │ ├── search │ ├── search.html │ ├── select.html │ ├── structures │ ├── tut.html │ └── viprc.sample ├── ext.l ├── lib/ │ ├── adm.l │ ├── app.l │ ├── bash_completion │ ├── btree.l │ ├── canvas.js │ ├── canvas.l │ ├── clang.l │ ├── complete.l │ ├── db.l │ ├── dbgc.l │ ├── debug.l │ ├── form.js │ ├── form.l │ ├── frac.l │ ├── gis.js │ ├── gis.l │ ├── heartbeat.l │ ├── http.l │ ├── json.l │ ├── lint.l │ ├── map │ ├── math.l │ ├── misc.l │ ├── net.l │ ├── pilog.l │ ├── plio.js │ ├── replica.l │ ├── role.l │ ├── select.l │ ├── simul.l │ ├── sq.l │ ├── svg.l │ ├── term.l │ ├── test.l │ ├── too.l │ ├── ulimit.l │ ├── user.l │ ├── vip/ │ │ ├── cal.rc.l │ │ ├── draw.l │ │ ├── html.l │ │ └── load.l │ ├── vip.l │ ├── xhtml/ │ │ ├── area │ │ ├── field │ │ ├── grid │ │ ├── html │ │ ├── input │ │ ├── layout │ │ ├── menu │ │ ├── select │ │ ├── submit │ │ ├── tab │ │ └── table │ ├── xhtml.l │ ├── xm.l │ └── xxhash.l ├── lib.css ├── lib.l ├── loc/ │ ├── AE.l │ ├── AR.l │ ├── CH.l │ ├── CKB.l │ ├── CN.l │ ├── DE.l │ ├── ES.l │ ├── FR.l │ ├── GB.l │ ├── GR.l │ ├── HR.l │ ├── IT.l │ ├── JP.l │ ├── NIL.l │ ├── NO.l │ ├── RU.l │ ├── SE.l │ ├── TR.l │ ├── UA.l │ ├── US.l │ ├── ar │ ├── ca │ ├── ch │ ├── ckb │ ├── cn │ ├── de │ ├── el │ ├── es │ ├── fr │ ├── hr │ ├── it │ ├── ja │ ├── no │ ├── ru │ ├── sv │ ├── tr │ └── uk ├── man/ │ └── man1/ │ ├── picolisp.1 │ └── pil.1 ├── misc/ │ ├── bigtest │ └── stress.l ├── pil ├── soTest.c ├── src/ │ ├── Makefile │ ├── Makefile.macos │ ├── Makefile.openbsd │ ├── apply.l │ ├── balance.c │ ├── base.ll │ ├── big.l │ ├── db.l │ ├── dec.l │ ├── defs.l │ ├── ext.l │ ├── ext.ll │ ├── flow.l │ ├── gc.l │ ├── glob.l │ ├── ht.l │ ├── ht.ll │ ├── httpGate.c │ ├── io.l │ ├── lib/ │ │ ├── ex.l │ │ ├── llvm.l │ │ └── so.l │ ├── lib.c │ ├── lib.so.c │ ├── main.l │ ├── pico.h │ ├── ssl.c │ ├── subr.l │ ├── sym.l │ ├── sysdefs.c │ └── vers.l ├── test/ │ ├── lib/ │ │ ├── db.l │ │ ├── lint.l │ │ ├── math.l │ │ └── misc.l │ ├── lib.l │ └── src/ │ ├── apply.l │ ├── big.l │ ├── db.l │ ├── ext.l │ ├── flow.l │ ├── ht.l │ ├── io.l │ ├── main.l │ ├── net.l │ ├── subr.l │ └── sym.l └── vip ================================================ FILE CONTENTS ================================================ ================================================ FILE: COPYING ================================================ PicoLisp Copyright (c) Software Lab. Alexander Burger Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. ================================================ FILE: INSTALL ================================================ # 23jan26 Software Lab. Alexander Burger PicoLisp Installation ===================== PicoLisp needs a POSIX compatible system and the LLVM infrastructure. It supports two installation strategies: Local and Global. For a global installation, allowing system-wide access to the executable and library/documentation files, you can either install it from a ready-made distribution, or set some symbolic links to one of the local installation directories as described below. Note that you are still free to have local installations along with a global installation, and invoke them explicitly as desired. Local Installation ------------------ The following instructions work on Debian Linux. They should be similar on other systems (for e.g. MacOS see src/Makefile.macos). 1. Install required packages $ sudo apt install binutils make clang llvm libreadline-dev libffi-dev libssl-dev pkg-config 2. Unpack the tarball $ wget https://software-lab.de/pil21.tgz $ tar xfz pil21.tgz 3. Change the directory $ cd pil21 4. Compile the PicoLisp interpreter $ (cd src; make) Global Installation ------------------- The recommended way for a global installation is to use a picolisp package from the OS distribution. If that is not available, you can (as root) create symbolic links from /usr/lib and /usr/bin to a local installation directory: # ln -s //pil21 /usr/lib/picolisp # ln -s /usr/lib/picolisp/bin/picolisp /usr/bin # ln -s /usr/lib/picolisp/bin/pil /usr/bin For additional access to the man pages, utilities and bash completion: # ln -s //pil21/man/man1/picolisp.1 /usr/share/man/man1 # ln -s //pil21/man/man1/pil.1 /usr/share/man/man1 # ln -s //pil21 /usr/share/picolisp # ln -s //pil21/lib/bash_completion /usr/share/bash-completion/completions/pil Invocation ---------- In a global installation, the 'pil' command should be used. You can either start in plain or in debug mode. The difference is that for debug mode the command is followed by single plus ('+') sign. The '+' must be the very last argument on the command line. $ pil # Plain mode : $ pil + # Debug mode : In both cases, the colon ':' is PicoLisp's prompt. You may enter some Lisp expression, : (+ 1 2 3) -> 6 To exit the interpreter, enter : (bye) or just type Ctrl-D. For a local invocation, specify a path name, e.g. $ ./pil # Plain mode : $ ./pil + # Debug mode : or $ /home/app/pil # Invoking a local installation from some other directory Note that 'pil' can also serve as a template for your own stand-alone scripts. Documentation ------------- For further information, please look at "doc/index.html". There you find the PicoLisp Reference Manual ("doc/ref.html"), the PicoLisp tutorial ("doc/tut.html"), and the frequently asked questions ("doc/faq.html"). As always, the most accurate and complete documentation is the source code ;-) Any feedback is welcome! Hope you enjoy :-) -------------------------------------------------------------------------------- Alexander Burger Software Lab. / 7fach GmbH Bahnhofstr. 24a, D-86462 Langweid abu@software-lab.de, https://www.software-lab.de, +49 8230 5060 ================================================ FILE: README ================================================ # 05nov25 Software Lab. Alexander Burger Perfection is attained not when there is nothing left to add but when there is nothing left to take away (Antoine de Saint-Exupery) The PicoLisp System =================== _PI_co Lisp is not _CO_mmon Lisp PicoLisp can be viewed from two different aspects: As a general purpose programming language, and a dedicated application server framework. (1) As a programming language, PicoLisp provides a 1-to-1 mapping of a clean and powerful Lisp derivate, to a simple and efficient virtual machine. It supports persistent objects as a first class data type, resulting in a database system of Entity/Relation classes and a Prolog-like query language tightly integrated into the system. The virtual machine was designed to be Simple The internal data structure should be as simple as possible. Only one single data structure is used to build all higher level constructs. Unlimited There are no limits imposed upon the language due to limitations of the virtual machine architecture. That is, there is no upper bound in symbol name length, number digit counts, or data structure and buffer sizes, except for the total memory size of the host machine. Dynamic Behavior should be as dynamic as possible ("run"-time vs. "compile"-time). All decisions are delayed till runtime where possible. This involves matters like memory management, dynamic symbol binding, and late method binding. Practical PicoLisp is not just a toy of theoretical value. PicoLisp is used since 1988 in actual application development, research and production. The language inherits the major advantages of classical Lisp systems like * Dynamic data types and structures * Formal equivalence of code and data * Functional programming style * An interactive environment PicoLisp is very different from any other Lisp dialect. This is partly due to the above design principles, and partly due to its long development history since 1984. You can download the latest release version at https://software-lab.de/pil21.tgz (2) As an application server framework, PicoLisp provides for NoSQL Database Management Index trees Object local indexes Entity/Relation classes Pilog (PicoLisp Prolog) queries Multi-user synchronization DB Garbage collection Journaling, Replication User Interface Browser GUI (X)HTML/CSS XMLHttpRequest/JavaScript Application Server Process management Process family communication XML I/O Import/export User administration Internationalization Security Object linkage Postscript/Printing PicoLisp is not an IDE. All program development in Software Lab. is done using the console, bash, vip (vi-style editor) and the Lisp interpreter. The only type of GUI supported for applications is through a browser via HTML. This makes the client side completely platform independent. The GUI is created dynamically. Though it uses JavaScript and XMLHttpRequest for speed improvements, it is fully functional also without JavaScript or CSS. The GUI is deeply integrated with - and generated dynamically from - the application's data model. Because the application logic runs on the server, multiple users can view and modify the same database object without conflicts, everyone seeing changes done by other users on her screen immediately due to the internal process and database synchronization. PicoLisp is free software, and you are welcome to use and redistribute it under the conditions of the MIT/X11 License (see "COPYING"). It is based on LLVM and compiles and runs on any 64-bit POSIX system. -------------------------------------------------------------------------------- Alexander Burger Software Lab. / 7fach GmbH Bahnhofstr. 24a, D-86462 Langweid abu@software-lab.de, http://www.software-lab.de ================================================ FILE: bin/pil ================================================ #!/usr/bin/picolisp /usr/lib/picolisp/lib.l (load "@lib/net.l" "@lib/misc.l" "@lib/btree.l" "@lib/db.l" "@lib/pilog.l") `*Dbg (docs "@doc/") ================================================ FILE: bin/psh ================================================ #!/usr/bin/pil # 06aug24 Software Lab. Alexander Burger (load "@lib/net.l" "@lib/misc.l" "@lib/http.l") (let Arg (opt) (client "localhost" (or (format Arg) (client "localhost" 80 (pack Arg "/!psh") (read)) ) (pack (opt) "!psh?" (pw) "&" (in '("tty") (line T)) "&" (sys "TERM") ) (ctty (read)) (line) (line) ) ) (bye) ================================================ FILE: bin/pty ================================================ #!/usr/bin/pil # 05jul24abu # Pseudo Terminal (PilBox) # pty [host] [flg] (load "@lib/term.l") (setq *Host (or (opt) "localhost") *Port 8081 ) # Sync with ~/Port in PilBox (unless (setq *Sock (connect *Host (inc *Port))) (bye) ) (out *Sock (in "~/.pty" (echo)) # Sync with ~/.pty in PilBox (prinl) ) (in *Sock (rd 2)) # Skip "\r\n" (finish (prinl)) (de sendCmd @ (udp *Host `(inc *Port) (cons (in "~/.pty" (line T)) (rest)) ) ) (unless (opt) (task (port (+ *Port 2)) (let? S (accept @) (catch '(NIL) (in S (when (= (rd) (in "~/.pty" (line T))) (let Z (tmp "pty.zip") (casq (rd) (+ (apply call (rd) "zip" "-r" Z) (in Z (out S (echo))) ) (- (out Z (echo)) (call "unzip" "-o" Z) ) ) ) ) ) (off *Msg) ) (close S) (and *Msg (prinl @)) ) ) ) (when (getTerm) (sendCmd (cons 'setTerm (sys "TERM") @) '(off *Err) ) (de *Winch (sendCmd (cons 'setTerm (sys "TERM") (getTerm))) ) ) (raw T) (call "stty" "intr" NIL) (task *Sock (in @ (ifn (rd 1) (bye) (wr @) (flush) ) ) ) (loop (and (key) (out *Sock (prin @))) ) ================================================ FILE: bin/vip ================================================ #!/usr/bin/picolisp /usr/lib/picolisp/lib.l # 30apr26abu (unless *Dbg (load "@lib/vip.l") ) (stack 1024) (bye (if (vip~vi ## [+ | +[]] [+[]] .. (make (while (opt) (let (S @ L (chop S)) (cond ((pre? "+" S) (link (cond ((format S) (cons @ (opt))) ((= "+" S) (cons T (opt))) ((get (any (cdr L)) '*Dbg 1) (symbols (cddr @)) (cons (car @) (cadr @)) ) (T (cons (cdr L) (opt))) ) ) ) ((pre? "-" S) (load S)) (T (link S)) ) ) ) ) ) 0 1 ) ) ================================================ FILE: bin/watchdog ================================================ #!/usr/bin/pil # 13apr23 Software Lab. Alexander Burger # Use: bin/watchdog .. (load "@lib/misc.l") # *MailHost *MailPort *MailFrom *MailTo *Watch (argv *MailHost *MailPort *MailFrom . *MailTo) (setq *MailPort (format *MailPort)) (unless (call 'test "-p" "fifo/beat") (call 'mkdir "-p" "fifo") (call 'rm "-f" "fifo/beat") (call 'mkfifo "fifo/beat") ) (finish (call 'rm "fifo/beat")) (de *Err (prin (stamp)) (space) (println *Watch) ) (task (open "fifo/beat") (in @ (let X (rd) (cond ((not X) (bye)) ((num? X) (let? W (assoc X *Watch) (when (caddr W) (msg (car W) " " (stamp) " bye") ) (del W '*Watch) ) ) ((atom X) # bin/picolisp -"out 'fifo/beat (pr '$(tty))" -bye (let D (+ (* 86400 (date T)) (time T)) (out X (for W *Watch (prinl (align 7 (car W)) " " (- (cadr W) D) " " (or (caddr W) "o") " " (cdddr W) ) ) ) ) ) ((assoc (car X) *Watch) # X = (Pid Tim . Any) (let W @ # W = (Pid Tim Flg . Any) (when (caddr W) (msg (car W) " " (stamp) " resumed") ) (set (cdr W) (cadr X)) (set (cddr W)) (con (cddr W) (or (cddr X) (cdddr W))) ) ) (T (push '*Watch (list (car X) (cadr X) NIL (cddr X)))) ) ) ) ) (task -54321 54321 (let D (+ (* 86400 (date T)) (time T)) (for W *Watch (cond ((>= (cadr W) D)) ((caddr W) (msg (car W) " " (stamp) (if (kill (car W) 15) " killed" " gone") ) (del W '*Watch) ) (T (inc (cdr W) 3600) (set (cddr W) T) (let Sub (pack "Timeout " (car W) " " (cdddr W)) (msg (car W) " " (stamp)) (unless (mail *MailHost *MailPort *MailFrom *MailTo Sub) (msg (cons Sub *MailTo) " mail failed " (stamp)) ) ) ) ) ) ) ) (wait) ================================================ FILE: doc/ChangeLog ================================================ 26.4.30 Re-introduce 'any' (for '+' arguments) bin/vip 26.4.24 Check 'format' before 'get' (Bruno) bin/vip 26.4.12 Bug in 'aux' for hooks (Andreas Rüegger) lib/db.l 26.4.5 Use level 2 in 'not' rule lib/pilog.l 26.4.4 ESC terminates '?' doc/ref.html 26.3.31 Call 'dbFetch' also in 'prove' src/subr.l 26.3.29 Minor comma doc/refP.html ####### 26.3 ####### 26.3.26 Remove "." after content and show whole week lib/vip/cal.rc.l 26.3.21 'for' takes 'cnt', not 'num' doc/refF.html 26.3.17 Use separate '$InChar' and '$OutChar' instead of '$IoChar' src/glob.l src/io.l 26.3.13 Force 'touch *.ll' if bootstrapping src/Makefile 26.2.28 Show terminating "." after content lib/vip/cal.rc.l 26.2.20 Remove '+Init' from radio button in 'bagBag' lib/form.l 26.1.23 Fix MacOS build (Mike Pechkin, Andreas Hauser) INSTALL src/Makefile.macos 26.1.19 Restore "Constant Data" section from 22.5.29 doc/native.html 26.1.13 'iter>' for '+List' to set '*Iter+' lib/db.l Remove "lib/android.l" from distribution (is kept in PilBox) 26.1.12 Define PROT_READ, PROT_WRITE, MAP_SHARED and MAP_FAILED Define "domainSock" (AF_UNIX domain sockets) src/sysdefs.c 26.1.3 GET and POST restriction was removed jul23 doc/httpGate.html 26.1.2 Fix alphabetic order doc/refC.html 26.1.1 Bug in 'dirname' for "/" lib/misc.l test/lib/misc.l ####### 25.12 ####### 25.12.21 Vip ":cal" (calendar) command doc/viprc.sample New file lib/vip/cal.rc.l 25.12.14 Namespace specification "ap~" not needed doc/search.html 25.12.11 'scratch' returns buffer lib/vip.l 25.12.9 Rename 'shift' to 'shiftN' Refactor 'patMatch' to (search> . +Buffer) lib/vip.l 'this' function src/glob.l src/flow.l doc/ref.html doc/refT.html doc/refW.html lib/sq.l lib/vip.l lib/simul.l 'keys' function lib/vip.l 25.12.8 Support initial key sequence in "# VIP " header lib/vip.l 25.12.7 Check for buffer-local command mappings lib/vip.l 25.12.6 Inherit window methods when split 'status>' continued 'drawin' function lib/vip.l 25.12.5 Fix 'any1' and 'any2' for 'init', 'iter' and 'scan' doc/refI.html doc/refS.html 'status>' method for '+Window' lib/vip.l 25.12.4 'delBuf' function lib/vip.l 25.12.3 Check for buffer-local key mappings lib/vip.l 25.12.1 Revert res_init() from 25.11.29 src/ssl.c 25.11.30 Decode "%21", and handle multple header values (Mansur Mamkin) lib/http.l 25.11.29 Reinitialize resolver before getaddrinfo() src/ssl.c 25.11.26 Pointer casts for bufFloat() and bufDouble() src/main.l 25.11.22 Typo loc/RU.l 25.11.21 Add (val> . +Swap/R) lib/form.l 25.11.20 Handle swap symbol replacement in '+Swap' lib/db.l (val> . +Swp) not needed lib/form.l 25.11.14 "%" also matches braces "{" and "}" lib/vip.l 25.11.10 Pointer casts for bufFloat() and bufDouble() src/dec.l src/lib.c 25.11.6 Optionally start 'lsn' listennig processes src/httpGate.c 25.11.5 Remove phone number README Restore 'pkg-config --cflags libffi' src/Makefile Avoid stale 'CliSock' if fork() fails src/httpGate.c Add 'stat' output to 'proc' lib/debug.l 25.11.2 New file lib/xxhash.l 25.10.12 Set initial alarm to 2 seconds lib/http.l 25.10.10 Extend example for 'yield' with 'env' arg doc/refY.html 25.10.8 Optional 'prg' argument to 'yield' src/flow.l doc/refY.html 25.10.5 Bug in 'U' unsigned integer suppport src/main.l 'i64u' type cast src/lib/llvm.l 25.10.1 Use just CONTEXT in 'permit' lib/android.l ####### 25.9 ####### 25.9.28 Import 'U' lib/reflect.l 25.9.27 Support 'U' unsigned integer result specification src/glob.l src/main.l src/pico.h doc/refN.html 25.9.26 Default scale 6 lib/reflect.l 25.9.25 'xCnt64' function src/main.l src/io.l 25.9.20 Recurse on nested structures Remove '*Reflect' lib/reflect.l 25.9.19 Use 'def' instead of 'set' lib/reflect.l 25.9.17 Fix comment for linked libraries soTest.c 25.9.16 New file lib/reflect.l 25.9.15 Re-arrange evaluation in 'picolisp' to preserve stdout src/main.l Recommend (load) for "full" library src/lib/so.l 25.9.13 Shared library continued src/Makefile src/main.l soTest.c 25.9.9 reflect() function src/lib/ex.l src/lib/so.l src/glob.l src/main.l doc/ref.html doc/refR.html evExe() function src/main.l src/io.l src/apply.l 25.9.7 Add comment for "full" library src/lib/so.l Use 'parse' in 'picolisp' src/main.l 25.9.6 Add interactive line input soTest.c Clean up src/Makefile src/dec.l src/main.l src/lib.so.c 25.9.2 New files src/lib.so.c soTest.c 'patch' function src/lib/llvm.l src/lib/so.l 'exclude' continued src/Makefile src/lib/llvm.l src/lib/ex.l src/lib/so.l src/main.l src/pico.h src/big.l src/subr.l 25.8.28 '$StkLimit' related to stack size src/glob.l src/main.l src/flow.l Call ulimStk() to set '$SysStkLimit' src/lib.c lib/ulimit.l Quiche mode src/lib/llvm.l src/gc.l src/sym.l src/db.l src/apply.l 'export' never worked! lib.l doc/refE.html 25.8.22 'dlfun' instruction src/lib/llvm.l src/main.l 25.8.21 'exclude' function src/lib/llvm.l src/lib/ex.l src/lib/so.l 25.8.20 '!!' function src/glob.l src/flow.l doc/ref.html doc/ref_.html 25.8.15 Save position mark on every move lib/vip.l 25.8.13 'stoplisp' function src/main.l 25.8.12 Optionally build as shared library src/Makefile src/lib/llvm.l src/dec.l src/main.l src/lib.c src/io.l New files src/lib/ex.l src/lib/so.l 25.7.29 Pass 'exe' instead of 'prg' to 'event' and 'wake' lib/simul.l doc/des.html 25.7.28 Handle circular lists in 'less' lib.l 25.7.27 'sq' function src/glob.l src/big.l test/src/big.l doc/ref.html doc/refS.html doc/ref_.html 25.7.22 Use 'tco' in 'gcd' lib/frac.l 25.7.19 Remove 'saveCoIO' src/flow.l 25.7.15 Allow to stop main coroutine with (co T) src/flow.l doc/refS.html 25.7.5 'allowed' must be called before any GUI libs and/or 'allow' calls doc/refA.html ####### 25.6 ####### 25.6.27 'recur' signature analog to 'tco' doc/refR.html Return cons pair with hard limit lib/ulimit.l 25.6.26 New file lib/ulimit.l Define RLIMIT_STACK, RLIMIT_NOFILE and RLIMIT_NPROC src/sysdefs.c 25.6.17 Increase '$GcCount' in 'gc' dynamically src/gc.l 25.6.7 Skip comments lib/xm.l 25.6.4 Optional 'sub?' start byte position src/dec.l src/main.l src/sym.l test/src/sym.l doc/refS.html 'flg' argument to 'group' for pre-grouped lists src/subr.l doc/refG.html 25.5.30 New file lib/select.l Deprecate 'db/x' and 'select/3' Pilog predicates, and move to "lib/select.l" lib/pilog.l doc/refB.html doc/refD.html doc/refF.html doc/refH.html doc/refI.html doc/refP.html doc/refR.html doc/refS.html doc/refT.html doc/refV.html doc/select.html Deprecate Pilog GUI functions, and move to "lib/select.l" lib/form.l 25.5.25 'idx' in 'search' also for 'relQs' lib/db.l 25.5.23 Optional index argument to 'accu' lib.l test/lib.l doc/refA.html Minor tuning in 'cache' and 'once' lib.l 25.5.22 Keep all command lines non-unique but longer than 3 in TAB-completion lib/vip.l Optionally return reversed key-value pairs from 'enum' src/sym.l doc/refE.html test/src/sym.l 25.5.21 'min' and 'max' also accept a single list argument src/subr.l test/src/subr.l doc/refM.html 25.5.17 Mention '@@' in the 'forall' reference doc/refF.html 25.5.16 'sub?' stores substrig byte position in '@@' src/dec.l src/main.l src/sym.l test/src/sym.l doc/refS.html 25.5.11 Auto-init in 'inc' and 'dec' src/lib/llvm.l src/big.l Revert to 20 instead of 21 bits from 'hash' src/big.l test/src/big.l doc/refH.html 25.5.10 Print times in 'bench' also as [hh:mm] lib/debug.l doc/refB.html 25.5.9 Bug in 'attr' lib/xm.l 25.5.8 'version' can also check for a required version src/main.l doc/refV.html Optimize 'idx' in 'search' for (+Ref +Link) and '+Joint' lib/db.l 25.5.5 New files src/Makefile.openbsd src/Makefile.macos 25.4.24 'forall' also accepts an 'init' step structure lib/db.l doc/refF.html 25.4.20 Return 21 instead of 20 bits from 'hash' src/big.l test/src/big.l doc/refH.html 'idx' in 'search' *after* filtering lib/db.l 25.4.19 Bug in 'initSeed' for external symbols src/big.l 25.4.18 'X' and 'Prg' in 'forall' private lib/db.l 25.4.17 Simplify 'body' and 'attr' lib/xm.l 25.4.14 'forall' also accepts a 'search' query structure lib/db.l doc/refF.html 'idx' in 'search' only if necessary lib/db.l 25.4.13 Avoid catch/throw in 'step' lib/btree.l 25.4.9 Add 'rt' to 'pretty' lib.l Return 20 instead of 16 bits from 'hash' src/big.l test/src/big.l doc/refH.html Hash 'idx' in 'search' lib/db.l 25.4.7 Support 'prune' also in 'scan' and 'iter' lib/btree.l doc/refP.html Make 'for' on lists more gc-conservative src/flow.l ####### 25.3 ####### 25.3.24 Don't skip empty value in 'create' for updates More 'create' tuning lib/db.l 25.3.20 'stdEval' must preserve '$At2' src/io.l 'rt' function src/glob.l src/main.l doc/ref.html doc/refR.html 25.3.19 Remove parallelization with 'later' from 'create' lib/db.l 25.3.13 KeyEvent 'keyCode' and 'charCode' are deprecated lib/form.js 25.3.11 "onkeypress" is deprecated lib/xhtml.l 25.3.9 Fix description of 'peek' (does not block, but returns only the next byte) doc/refP.html 25.3.8 Scroll page on horizontal touch movements in tables lib/form.js Cosmetics src/io.l lib/form.l 25.3.7 Move 'pagehide' handling (back/forward cache) from 'html' to 'form' lib/xhtml.l lib/form.l 25.3.6 Remove @lib/tinymce.l from distribution 25.3.2 Change type of '$NsLink' from 'i64*' to 'any' src/glob.l 25.2.27 Export namespace list from 'repl' via 'T' argument to 'symbols' src/glob.l src/sym.l src/io.l doc/refS.html 25.2.26 Typo doc/refI.html doc/refN.html Use 'any' instead of 'intern' for '+' arguments bin/vip 25.2.21 Move cursor left in final left scroll lib/vip.l 25.2.17 Scroll two steps with horizontal arrow keys lib/vip.l 25.2.13 'tco' continued lib/lint.l 25.2.9 'tco' continued src/flow.l lib.l test/src/flow.l 25.2.8 'tco' and 'tc' tail call optimization functions src/glob.l src/flow.l doc/ref.html doc/refR.html doc/refT.html 25.2.5 'if@@' function src/glob.l src/flow.l test/src/flow.l doc/ref.html doc/refC.html doc/refI.html 25.2.1 Missing 'F' argument to 'packJson' lib/json.l 25.1.22 Change 'permute' to use a callback function lib/simul.l 25.1.21 Postpone first move event for better double-click detection lib/canvas.js 25.1.9 Re-introduce "array" feature lib/json.l 25.1.5 Handle "^?" lib/vip.l Read and print decimal unicode in symbol names src/io.l lib.l 25.1.4 Wrong examples for 'eval' and 'run' offset doc/refE.html doc/refR.html Fix 'remark' lib.l ####### 24.12 ####### 24.12.30 Remove '*SesAdr' check lib/http.l lib/adm.l 24.12.23 Automatic lib configuration (Mike Pechkin) src/Makefile Reset form on 'pagehide' event to disable back/forward cache lib/xhtml.l 24.12.22 Reduce Cache-Control to 'no-store' lib/http.l 24.12.17 'remark' continued lib.l lib/vip.l Typo doc/refT.html 24.12.16 'remark' function to generalize REPL-comments src/glob.l src/io.l lib.l lib/vip.l doc/refR.html 'complete' reference doc/refC.html 24.12.14 Print namespace of symbols in REPL-comments src/io.l lib/vip.l 24.12.13 Cyan attribute for REPL-comments src/io.l 'markup' also in 'scratch' Print numbers as fixnum-comments also in Vip REPL lib/vip.l 24.12.10 New file lib/vip/load.l 24.12.5 Add ":wq" as alias for ":x" lib/vip.l 24.12.2 Add section about namespaces doc/ref.html doc/refE.html doc/refI.html doc/refL.html doc/refN.html doc/refP.html doc/refS.html 24.11.23 Example for catching errors doc/refC.html 24.11.21 Intern mark names into 'vip' lib/vip.l 24.11.20 Generalize 'llvm~fmtNum' Print numbers as fixnum-comments in REPL src/big.l src/io.l src/subr.l doc/rc.sample doc/refR.html doc/refS.html doc/ref_.html 24.11.7 Remove obsolete C-level 'lisp' descriptions doc/refN.html doc/native.html 24.10.16 Support also HOME and END keys lib/vip.l ####### 24.9 ####### 24.9.7 '0' for empty name in minimal symbol diagram doc/ref.html 24.8.19 Stop 'gps' via 'Flg' argument lib/android.l 24.8.16 'pil' is obsolete doc/refT.html 24.8.7 Add 'L' and 'S' to private symbols lib/vip.l 24.8.6 Pass TERM environment variable to 'psh' lib/http.l bin/psh 24.8.4 'wake' returns 'isHeld' lib/android.l 24.8.3 Fix 'gps' with two Location Listeners lib/android.l 24.7.30 Typo doc/refN.html 24.7.23 Call 'restart' as a UI thread (avoid 'java' reentrancy) lib/android.l 24.7.15 Cosmetics src/io.l src/ht.l 24.7.10 'volatile' access to '$Signal' src/lib/llvm.l src/dec.l 24.7.9 'Exe' argument to 'xName' not used src/main.l src/sym.l src/io.l src/db.l src/flow.l src/ext.l 'prompt' function src/glob.l src/main.l doc/ref.html doc/refP.html Typo doc/structures 24.7.7 Check for stale I/O frames in 'unwind' src/main.l 24.7.5 Change pbPut/pbGet to Zip transfers bin/pty Bug in 'erVar' lib/form.l Typo doc/refD.html 24.7.4 Mention '~' in the 'pico' reference doc/refP.html 24.7.3 Check for SDK_INT >= 31 in 'alarm?' lib/android.l 24.7.2 Adjust 'alarm' for changed numeric arguments lib/android.l ####### 24.6 ####### 24.6.27 Minimal delay time 1 ms in 'des' lib/simul.l Force frame buffer register through runCo() src/flow.l Re-arrange structures for alignment src/glob.l src/dec.l 24.6.26 'otg' in coroutine structure missing doc/structures 24.6.23 Show terminated originator in 'yield' error src/flow.l 24.6.22 'prv' in coroutine structure is obsolete doc/structures Fix 'This' upon coroutine termination Bug in coroutines with non-symbolic tags src/flow.l 24.6.21 Change 'opt' from "-O3" to "-O2" src/Makefile Generalize 'all*' lib.l dirString() function src/main.l Bug in coroutine free-list management src/flow.l 24.6.20 Generalize output in 'tty' src/main.l src/gc.l Check for terminated originator in 'yield' src/flow.l 24.6.18 Clear 'at' in coroutine 'unwind' src/main.l 'putCrtEnv' clean up src/dec.l src/flow.l 24.6.17 Reentrant 'co' checks src/flow.l 24.6.16 Thread exceptions revisited lib/android.l 24.6.14 'alarm?' function lib/android.l 24.6.13 Call fcntlSetFl() in 'accept' if OpenBSD or FreeBSD lib/net.l 24.6.12 Disallow reentrant 'co' calls src/flow.l doc/ref.html doc/refC.html 24.6.9 Default format 72 columns lib/vip.l COPYING README INSTALL doc/microTemplates 24.6.5 Handle thread exceptions in 'java1' lib/android.l 24.6.2 Make 'dirname' and 'basename' non-destructive lib/misc.l 24.5.30 'catch' stores throw/error-flag in '@@' src/flow.l test/src/flow.l doc/refC.html lib/vip.l lib/form.l 24.5.24 'iter' returns 'NIL' doc/refI.html 24.5.23 Typo doc/search.html 24.5.8 Minor mismatch doc/faq.html 24.4.4 TAB-completion also for search commands lib/vip.l 24.4.3 No 'flushAll' in child process 'bye' src/main.l src/lib.c 24.4.1 'for' instead of 'while' in 'des' lib/simul.l 24.3.31 Change 'sendCmd' protocol to UDP -> background task bin/pty ####### 24.3 ####### 24.3.29 Include lib/sysdefs in "clean2" src/Makefile 24.3.28 Ignore ESC in command mode lib/vip.l 24.3.11 Call (raw T) at start and (raw NIL) when done lib/vip.l 24.3.10 'scale' function lib/svg.l 24.3.5 Bug in "words" doc/viprc.sample 24.2.3 Fix 'stack' reference doc/refS.html 24.1.29 Runtime relations via 'erVar' function lib/form.l 24.1.21 Add "apk" to '*Mimes' lib/http.l 23.12.29 Minor comment lib/simul.l ####### 23.12 ####### 23.12.18 requestAnimationFrame() not helpful lib/canvas.js 23.12.13 'P' instead of 'N' in native call (malloc() returns pointer) test/src/main.l '*DB' is 'NIL' while no database is open src/glob.l src/main.l src/gc.l src/db.l doc/refD.html 23.12.12 'server' single-shot (non-forking) mode with 'Flg' argument lib/http.l 23.12.9 ZERO-cache also for 'co' stopping src/flow.l 23.12.8 ZERO-cache and free-list for 'co' speedup src/glob.l src/dec.l src/main.l src/flow.l doc/ref.html 23.12.6 'co' crashes when gc() runs in put() src/flow.l 23.12.5 Return 1 from ulimStk() for minimal stack address src/lib.c 23.12.4 Use 'key' instead of 'line' (because of GNU readline behaviour change) in 'more' and 'bt' lib/debug.l doc/refM.html doc/refB.html in 'select' lib/sq.l doc/refS.html and in 'query' (and thus also '?') lib/pilog.l doc/refQ.html doc/ref_.html 23.12.3 Global '$StkBrk' not needed src/glob.l src/main.l 23.12.1 Change transient "U" in 'bench' to private lib/debug.l 23.11.30 Typo doc/refN.html 23.11.29 Default '*Rt' off lib/simul.l doc/des.html Check for empty 'lst' in renderCanvas() lib/canvas.js 23.11.28 Transient "U" in 'bench' lib/debug.l 23.11.27 Resume all coroutines waiting for the same point in time lib/simul.l doc/des.html 23.11.26 Use '*@@' instead of '@@' lib/vip.l 'make' stores linkage cell in '@@' src/subr.l doc/refM.html 23.11.22 Simplify key loop in 'des' lib/simul.l 23.11.19 Fix 'help' for new reference format lib/debug.l doc/refH.html 23.11.18 Handle optional count in ":bd" lib/vip.l Explicit symbol argument to 'new' src/flow.l doc/refN.html 23.11.17 'sext' constexprs are deprecated (Mike Pechkin) src/lib/llvm.l 23.11.12 Use 'push1' instead of 'push' in 'finish' lib.l Mark end of layout in 'tracks' also with "#" lib/simul.l Remove @lib/compat.l from distribution 23.11.7 Fix 'cancel' call in 'alarm' Checks for SDK_INT >= 26 are obsolete lib/android.l 23.11.3 Search also for inherited indexes in 'select' Clean up lib/sq.l doc/refS.html 23.10.31 Handle external symbols in 'xName' src/main.l 'flg' argument to 'ext?' to check physical existence src/db.l lib/debug.l lib/vip.l 23.10.30 More general matching in 'search' lib/db.l Skip duplicates in 'hintQ' lib/form.l 23.10.29 Load @lib/sq.l at the end of @lib/db.l lib/db.l lib/pilog.l Keep relative file position lib/vip/html.l 23.10.28 Change 'hintQ' to use 'match>' lib/form.l Return 'Val' from 'match>' methods lib/db.l 23.10.27 Minor comment lib/svg.l Change 'dump' to use 'search' lib/too.l 23.10.26 Insert "# VIP " headers Fix 
 markups
      *.html

23.10.25
   Typo
      doc/search.html
   Minor comments
      src/subr.l
      doc/refC.html

23.10.24
   Typo
      doc/search.html

23.10.23
   Continued
      doc/search.html
   Add "search.html"
      doc/toc.html
   Comments
      lib/db.l

23.10.22
   Style for 
 tags
      doc/doc.css

23.10.21
   Documentation continued
      doc/refS.html
      doc/search.html

23.10.20
   New file
      doc/search.html
   Use (sys "BROWSER") if set
      lib/vip.l

23.10.19
   Cosmetics
      lib/vip/draw.l
   New file
      lib/vip/html.l
   Check for "# VIP " in the first three lines
      lib/vip.l

23.10.18
   Use inherited tree
      lib/db.l

23.10.17
   Optional extract-function argument to 'search'
      lib/db.l
      doc/refS.html

23.10.16
   Bug in 'iter>' for '+Sn'
      lib/db.l

23.10.15
   Change 'select' to use 'search'
      lib/sq.l
   '+DbChart' and 'hintQ' functions
      lib/form.l
   'search' function with 'iter>' and 'match>' methods
      lib/db.l
      doc/ref.html
      doc/refC.html
      doc/refS.html
   New file
      doc/search

23.10.5
   Check 'status != 200' in 'onload'
      lib/form.js

####### 23.9 #######
23.9.27
   Add namespace "-ap~main"
      doc/select.html

23.9.26
   Cosmetics
      lib/form.l

23.9.23
   Use '*Evt' mechanism instead of 'Busy'
      lib/form.l
      lib/form.js
   Remove 'vf'
      lib/vip.l

23.9.20
   Change global 'FormReq' to local
      lib/form.js

23.9.19
   Optionally cache image in 'csDrawImage'
      lib/canvas.l
      lib/canvas.js

23.9.17
   Missing semicolon
      lib/canvas.js

23.9.13
   Remove 'Queue' global
      lib/form.js

23.9.9
   Remove "form.html" and "app.html", add "des.html"
      doc/toc.html

23.9.8
   Don't fall back to stdin/stdout for closed files
      src/io.l
   Load also @lib/lint.l in 'psh'
      lib/http.l

23.9.7
   Realtime mode 'off' in "dining" demo
      doc/des.html

23.9.6
   Preserve initial 'This' in coroutines
      src/flow.l
      doc/ref.html

23.9.5
   Adjust LLVM version check (Mike Pechkin)
      src/Makefile

23.9.4
   Mark 'tag' and 'prg' also in non-running coroutines
      src/gc.l

23.9.3
   Allow reentrancy in coroutines
      src/flow.l
      doc/ref.html

23.8.31
   Tag checks in 'co' and 'yield'
      src/dec.l
      src/flow.l
   Cosmetics
      doc/des.html

23.8.29
   'noLint' for 'RED'
      lib/term.l

23.8.28
   Homogenize 'input' and' 'output'
      src/glob.l
      src/dec.l
      src/main.l
      src/gc.l
      src/io.l
      src/flow.l
   'null' instead of '@null' in 'table'
      src/lib/llvm.l

23.8.27
   Set namespace for '+' argument in debug mode
      bin/vip

23.8.26
   Handle $ErrFrames and $CtlFrames in coroutines
      src/flow.l
      src/dec.l
   'yield' bug revisited
      src/flow.l

23.8.25
   Release reference to Java object (Todd Coram)
      lib/android.l

23.8.22
   Bug in 'yield' for nested coroutines
      src/flow.l

23.8.21
   Move 'getSize' to lib/term.l
      lib/term.l
      lib/vip.l
   'clear' function
      lib/term.l

23.8.20
   Generalize 'attr'
      lib/term.l

23.8.15
   Note about coroutine environments
      doc/ref.html

23.8.13
   Clarify 'stack' reference
      doc/refN.html

23.8.12
   Avoid 'read' in 'download'
      lib/misc.l

23.8.8
   Search first 'priv' in 'nsp'
      src/sym.l
      doc/refP.html
   Rename lisp-level functions '_xxx' to '_Xxx'
      src/glob.l
      src/main.l
      src/gc.l
      src/big.l
      src/sym.l
      src/io.l
      src/db.l
      src/apply.l
      src/flow.l
      src/subr.l

23.8.7
   'startForeground' with service type
      lib/android.l

23.8.6
   Set SSL_CERT_FILE only if on mobile device
      lib/android.l

23.8.4
   Check local variables for lower case in 'lint'
      lib.l
      lib/lint.l
      lib/xhtml.l
      lib/form.l
      lib/svg.l

23.8.3
   Defer advancing the list pointer in 'for'
      src/flow.l

23.8.1
   Fixes to 'native' description
      doc/refN.html
      doc/native.html
   Target SDK 34 / androidx
      lib/android.l

23.7.28
   opaque-pointers for '18 > LLVM >= 15' (Mike Pechkin)
      src/Makefile

23.7.24
   Partially revert style simplification from 21.11.21
      lib/form.l
      lib/form.js

23.7.23
   New Vip commands
      - "gw" View Web page
      - "gh" View HTTP code
      - "gb" Invoke Browser (w3m)
   Implicit writing to 'scratch' files
   Extend 'map+', 'map+g' and 'map+q'
      lib/vip.l

23.7.21
   Minor clarification of @-result
      doc/ref.html

23.7.20
   Revisit 'allow'
      lib/svg.l

23.7.19
   Missing arg to "getnameinfo" in 'host'
      lib/net.l

23.7.17
   Generalize 'def' for 'any' keys
      src/flow.l
      doc/refD.html
   Don't 'allow' temporary files by default any longer
      lib/http.l
      lib/xhtml.l
      lib/svg.l

23.7.13
   Bug in 'input' and 'output': Must preserve '@'
      src/io.l

23.7.10
   Revert change from 23.7.6
      bin/vip
   TAB-completion also from command history
      lib/vip.l

23.7.8
   Note about accessing symbol values in ':'
      doc/ref_.html

23.7.7
   'all*' function
      doc/ref.html
   Exponent notation in 'parseJson' and 'readJson'
      lib/json.l

23.7.6
   Use 'str' instead of direct 'intern' to handle namespaces
      bin/vip

23.7.4
   Generalize HTTP method support
      src/httpGate.c

23.7.2
   Deprecate 'zxing?' / 'queryIntentActivities'
      lib/android.l

####### 23.6 #######
23.6.25
   Print current coroutine in 'stkErr'
      src/main.l

23.6.18
   Minor comment
      bin/pty

23.6.16
   Minor elaboration on the 'sect' reference
      doc/refS.html

23.6.6
   Disallow append mode (via "+file") in 'in' and 'load'
      src/io.l
      doc/refI.html
      doc/refO.html

23.6.4
   '+' defaults to tag in debug mode
      bin/vip
   Accept 'any' in 'intern'
      src/lib/llvm.l
      src/sym.l
      lib.l
      test/src/sym.l
      doc/refI.html
      lib/form.l
      lib/dbgc.l

23.5.27
   Global '*AlwaysAsk'
      lib/form.l

23.5.25
   Track network functions
      lib/simul.l
   New file
      doc/Tracks
   Add more stack checks
      src/main.l
      src/flow.l

23.5.24
   Change stack segment safety margin from 4096 to 1024
      src/glob.l
      src/flow.l

23.5.15
   Remove 'Cpy' from getCrtEnv(), set 'env' and '$StkLimit' in loadCoEnv()
      src/dec.l
      src/main.l
      src/flow.l

23.5.7
   Show buffer and dirty status also for long path names
      lib/vip.l

23.5.6
   Deprecate "ta" abbreviation for "tag" command
      lib/vip.l

23.5.5
   Fix description of left/right fork signals
      doc/des.html

23.4.28
   Set 'home' property in '' to '*Top'
      lib/canvas.l

23.4.25
   Wait for multiple events in 'pause'
      lib/simul.l
      doc/des.html

23.4.24
   Use 'idx' instead of 'rank' in '*Next'
      lib/simul.l
      doc/des.html
   Bug in 'compare' for anonymous symbols
      src/main.l

23.4.22
   New file
      doc/des.html
   Return max and min from 'idx' for 'T' and 'NIL' key arguments
   Randomize 'idx' if 'flg' is '0'
      src/sym.l
      src/io.l
      doc/refI.html
   chance() function
      src/dec.l
      src/lib.c

23.4.18
   Needs 'symb?' instead of 'sym?' in 'repl'
      src/io.l
   Cache coroutines for 'yield' in ZERO-properties
      src/main.l
      src/flow.l
   Clean up ZERO key handling in 'put' and 'get'
      src/sym.l
      src/flow.l
   Bug in ffiPrep() for direct Lisp arguments
      src/lib.c

23.4.16
   'private' cosmetics
      lib/net.l

23.4.13
   'finish' function
      lib.l
      lib/app.l
      lib/heartbeat.l
      bin/pty
      bin/watchdog
      doc/ref.html
      doc/refB.html
      doc/refF.html
      doc/refO.html

23.4.5
   Evaluate list arguments in 'select'
      lib/sq.l
      doc/refS.html

23.4.3
   Examples and test cases for 'ext:Base64' in 'input' and 'output'
      test/src/ext.l
      doc/refI.html
      doc/refO.html

####### 23.3 #######
23.3.29
   Make second port for pbPut/pbGet optional
      bin/pty

23.3.28
   Suppress duplicates in 'db/[345]'
      lib/pilog.l

23.3.27
   Fix escapes for special characters
      lib/debug.l
      doc/ref.html
      doc/refB.html
      doc/refD.html
      doc/refE.html
      doc/refN.html
      doc/refM.html
      doc/refP.html
      doc/refR.html
      doc/refU.html
      doc/refX.html
      doc/ref_.html
      doc/tut.html
      doc/native.html

23.3.26
   Fix various markup issues
      lib/debug.l
      lib/form.l
      ref.html
      ref?.html
      faq.html
      tut.html
      native.html
      select.html
      httpGate.html
   Set download link to demoApp.tgz
      doc/select.html

23.3.25
   Undo tag argument restriction from 14feb23
      src/flow.l
      doc/refC.html
      doc/refY.html

23.3.19
   Allow one "-" in uppercase global constants
   Handle 'default'
      lib/lint.l
   'noLint' for 'null'
      lib/android.l

23.3.17
   Repeat last shell command with ":$"
      lib/vip.l

23.3.13
   Support more attributes in 'serverSentEvent'
   Force chunked transfer in 'serverSend'
      lib/xhtml.l

23.3.5
   Typo
      lib/vip.l
   Restrict 'words' command to 'delimNs'
      doc/viprc.sample

23.2.27
   Bug in 'js>' for '+Url'
      lib/form.l

23.2.22
   Default hasbangs to /usr/bin/pil
      bin/pty
      bin/psh
      bin/watchdog

23.2.14
   Tag argument to 'co' and 'yield' must be a symbol
      src/flow.l
      doc/refC.html
      doc/refY.html

23.2.9
   Add "mp4" to '*Mimes'
      lib/http.l

####### 23.2 #######
23.2.8
   Check for atomic argument in 'made'
      src/subr.l

23.2.6
   Undo cosmetics from 14jul22
      lib/btree.l

23.2.5
   Keep 'prg' argument to 'des' private
      lib/simul.l

23.2.4
   Allow numeric argument to 'repl'
      src/io.l
   Add BROWN and PURPLE
      lib/term.l

23.2.1
   Numeric '*Rt' as speedup factor
   Optional 'prg' argument to 'des'
   Change '*Key' to fifo structure '*Keys'
      lib/simul.l

23.1.31
   Optional 'var' argument to 'key'
      src/io.l
      doc/refK.html

23.1.27
   Optional anchor for ''
   '' anchor function
      lib/xhtml.l

23.1.21
   Init '*Key' in 'des'
   Bug in 'wake'
      lib/simul.l

23.1.15
   Handle 'onOff'
      lib/lint.l

23.1.14
   Auto-quote 'null'
      lib/android.l

23.1.13
   'setCooked', 'setRaw' not needed in 'main' and 'brkLoad'
      src/main.l
      src/flow.l
   Call rl_deprep_terminal() in 'setCooked'
      src/lib.c

23.1.9
   Minor cosmetics
      src/main.l

23.1.6
   Add link to @lib/bash_completion
      INSTALL

23.1.2
   Separate buffer for each "$" (shell) command call
      lib/vip.l

23.1.1
   Clear *Complete upon backspace
      lib/vip.l

22.12.30
   Handle destructuring function parameters
      lib/lint.l

22.12.28
   Move 'less' to @lib.l
      lib.l
      lib/debug.l
      doc/refL.html

####### 22.12 #######
22.12.21
   Use 'less' in 'show'
      lib.l
      doc/refB.html
      doc/refM.html
      doc/tut.html
   Minor fix indentation
      lib/debug.l
   'circ' for atomic mapping arguments no longer needed
      lib/http.l

22.12.20
   Global '*Key'
      lib/simul.l

22.12.18
   Add GREEN and BLUE
      lib/term.l

22.12.15
   Handle destructuring function parameters in 'funq'
      src/main.l

22.12.12
   Fix 'tword' to go to the last space
      lib/vip.l

22.12.11
   Clear 'last' for deleted buffer
      lib/vip.l
   Directly call 'symbols' in 'tag'
      lib/vip.l

22.12.2
   Add percentage display to ''
      lib/xhtml.l
   Commented example for LEFT and RIGHT
      doc/viprc.sample

22.12.1
   Check for ":" delimiter in TAB-completion
      lib/vip.l

22.11.22
   'boss' is obsolete
      lib/android.l
   TAB-completion also for colon-commands
      lib/vip.l

22.11.20
   Minor privates
      lib/vip.l

22.11.19
   Fix 'unwind'ing coroutines
      src/dec.l
      src/main.l
      src/flow.l
   Reset screen and namespaces upon error
      lib/vip.l
      bin/vip

22.11.18
   'namespaces' function
      lib/debug.l
      doc/refN.html
      doc/refS.html
   Exchange also 'last', 'mark' and 'sc' in ":bx"
      lib/vip.l

22.11.15
   'shadows' function
      lib/debug.l
      doc/refS.html
   Allow also new namespace for '-symbols'
      lib.l

22.11.14
   Wrong 'save' / 'safe' in 'rdList'
      src/io.l
   Private 'queue'
      lib/simul.l

22.11.12
   'tabs' command to replace tabs with spaces
   'words' command to toggle between Lisp an C
      doc/viprc.sample
   Generalize delimiter checking
      lib/vip.l

22.11.11
   Store 'symbols' source info after the change
      src/sym.l

22.11.10
   'info' returns local time instead of UTC if the flag argument is zero
      src/dec.l
      src/main.l
      src/lib.c
      doc/refI.html
      lib/vip.l

22.11.9
   Set blob symlinks in mirror destination directories
      src/ssl.c

22.11.2
   Clear references to deleted buffer in ":bd"
      lib/vip.l

22.10.30
   Don't clear '@' and '@@' before (gc)
      src/gc.l
      doc/refG.html

22.10.26
   Passing zero to 'tell' refers to the parent process
      src/io.l
      src/db.l
      doc/refT.html
   Remove "lib/boss.l" from distribution

22.10.21
   Use 'delete' instead of 'replace'
      lib/dbgc.l

22.10.20
   Minor cosmetics
      src/main.l
      src/subr.l

22.10.17
   Decrement 'Ms' in 'waitFd' only if not 292MY
      src/io.l
   Include external declaration of ppoll()
      src/lib.c
   Fix reference of '*CPU'.
      doc/refC.html

22.10.15
   Avoid setting 'last' to current buffer
      lib/vip.l
   Call 'flush' in 'beep'
      lib.l

22.10.6
   'able' checks in 'val>' for '+ObjVal' and '+ObjVar'
      lib/form.l

22.10.4
   Add 'put' and 'get' to reference of '+Joint'
      doc/refJ.html

####### 22.9 #######
22.9.29
   Bitmask bug in 
      lib/xhtml.l

22.9.24
   Use opaque-pointers in LLVM >= 15 (Mike Pechkin)
      src/Makefile

22.9.16
   Support partially circular lists in 'pretty' and 'view'
   Print 'def' in 'pp' instead of 'de' for non-functions
      lib.l
   Simplify printing of circular lists
      src/io.l

22.9.13
   Move "ix.io" to @doc/viprc.sample, added "pb1n"
      lib/vip.l
      doc/viprc.sample
   Bug in 'server' for non-numeric arguments
      lib/net.l

22.9.9
   Allow empty 'url' argument
      src/ssl.c

22.9.6
   Pass FLAG_IMMUTABLE to PendingIntent
      lib/android.l

22.9.4
   Avoid multiple auto timers
      lib/canvas.js

22.9.3
   Pass flag 'T' for mouse/touch events
      lib/canvas.l
      lib/canvas.js

22.9.1
   Make 'all*' selective with 'T' or '0'
      lib.l
      doc/refA.html
      lib/vip.l

22.8.31
   Change 'http' abort time to 20 minutes
      lib/http.l

22.8.30
   '' function
      lib/xhtml.l
   Abort 'http' after 7 seconds
      lib/http.l

22.8.29
   Remove stale symbolic links
      src/ssl.c

22.8.26
   'cmd' function
      lib/vip.l

22.8.22
   Store debug source info in 'symbols'
      src/dec.l
      src/sym.l
      lib/debug.l
      doc/refD.html
      doc/refS.html

22.8.21
   Extend 'pool' tests
      test/src/db.l
      test/lib/db.l

22.8.20
   'b8+' aligns stack buffers to 8 bytes
      src/lib/llvm.l
      src/main.l
      src/io.l
      src/db.l
      src/flow.l
   Pad 'dbFile' and 'child' to multiples of 8
      src/dec.l
   Add file
      doc/viprc.sample
   Improve use cases
      doc/rc.sample

22.8.19
   'gPrintf' returns void
      src/dec.l
   Size check in gPrintf()
      src/lib.c
   'save' before 'loop'
      src/main.l
   '$TickU' and '$TickS' are obsolete
      src/glob.l

22.8.18
   Declare 'Tio' and 'Fsign' as "char" instead of "int"
      src/lib.c
   Make insensitive to endianness
      test/src/main.l

22.8.1
   Add note on destructuring bind of function parameters
      doc/ref.html

22.7.27
   Bug in 'extra' assuming positive pointers
      src/flow.l
   Display applied functions in backtraces
      lib/debug.l
      lib/app.l

22.7.20
   Bug in 'compare' for circular lists
      src/main.l
      test/src/subr.l

22.7.16
   Call 'blob+' in (clone> . +Entity)
      lib/db.l

22.7.15
   Improve 'hex' argument verification
      lib/misc.l

22.7.14
   Use 'skip' instead of 'line' in 'here'
      lib/misc.l
   Minor cosmetics
      lib/btree.l

22.7.13
   'overview' function
      lib/android.l
   Go to last instead of previous buffer in ":bd"
      lib/vip.l

22.7.12
   Remove "Building httpGate"
      doc/httpGate.html
   '' function
      lib/canvas.l

22.7.11
   Go to previous instead of next buffer in ":bd"
      lib/vip.l

22.7.9
   Correct earth mean radius to 6371 km
      lib/gis.l

22.7.8
   'map+', 'map+g' and 'map+q' functions
      lib/vip.l

22.7.3
   Default values in 'print>' methods
      lib/sq.l

22.7.2
   Uncomment 'shift' import
      src/lib/llvm.l
   Let 'beep' return 'NIL'
      lib.l
      lib/vip.l
      doc/refB.html

22.6.30
    Show blank screen in 'restart'
      lib/android.l

####### 22.6 #######
22.6.30
   Bug in realpath() handling
      lib/vip.l

22.6.26
   Corrections (Christos Gitsis)
      doc/ref.html
      doc/refA.html
   More fixes in local coroutine stacks
      src/flow.l

22.6.25
   realpath() directly if directory
      lib/vip.l

22.6.24
   Apply realpath() only to path of the file
      lib/vip.l
   More fixes in local coroutine stacks
      src/flow.l

22.6.23
   Set 'org' when resuming a coroutine in 'co'
      src/flow.l

22.6.22
   Silent exit if connect fails
      src/ssl.c

22.6.17
   Bugs in 'sort' with 'fun' argument
      src/subr.l

22.6.15
   Disable '*Run' in 'sync' calls
      lib/form.l

22.6.13
   Bug in printing symbols overshadowed in 'priv'
      src/io.l

22.6.10
   Don't lock remote symbols
      lib/vip.l

22.6.9
   Check empty name in '+SymField'
      lib/form.l

22.6.7
   Refined system clipboard copy
      lib/vip.l

22.6.6
   Missing "void *" in '*C-Defs'
      src/lib/llvm.l

22.6.3
   Disable form action for stale locks
      lib/form.l

22.5.31
   Remove 'visibilitychange' event handling
      lib/xhtml.l

22.5.30
   'h' function
      lib/debug.l
      doc/refH.html

22.5.29
   String arguments do no longer cause strdup(3) calls
      doc/native.html

22.5.26
   Add 'binutils'
      INSTALL
   Use 'output' instead of 'pipe'
      lib/misc.l
   Replace control characters with backslash sequences
      lib/misc.l
      lib/db.l
      lib/vip.l
      lib/term.l
      lib/http.l
      lib/xhtml.l
      lib/form.l
      lib/canvas.l
      lib/xm.l
      lib/tinymce.l
      test/src/io.l
      test/src/sym.l
      test/lib/misc.l
      doc/tut.html
      doc/refA.html
      doc/refP.html
      doc/form/refS.html
      doc/app.html
      misc/bigtest

22.5.25
   Bug in 'untrace'
      lib/debug.l
   Multi-line data in 'serverSend'
      lib/xhtml.l
   'input' and 'output' functions
      src/glob.l
      src/dec.l
      src/main.l
      src/gc.l
      src/io.l
      test/src/io.l
      doc/ref.html
      doc/refI.html
      doc/refO.html

22.5.18
   Fix 'raw' example
      doc/refR.html
   Clear stdin 'tty' flag in 'pipe' child
      src/io.l

22.5.15
   Replace "%" also if in command window
      lib/vip.l

22.5.13
   Optional "dup" file descriptor argument to 'fd'
      src/io.l
      doc/refF.html
   Use 'in' instead of 'pipe' for "ccrypt" call
      lib/vip.l

22.5.12
   Fix 'dbs' example
      doc/refD.html

22.5.11
   Use '*Uri' instead of '*Url' in 'post'
      lib/form.l

22.5.10
   Support also PUT, PATCH and DELETE
      src/httpGate.c

22.5.6
   Global '*Uri'
      lib/http.l
   Clean up '*Err'
      lib/app.l

22.5.5
   Call 'flush' in 'tty'
      src/dec.l
      src/main.l
      src/ht.l

22.5.3
   Use 'tty' in 'msg'
      lib.l
   Re-introduce 'visibilitychange' event handling
      lib/xhtml.l

22.5.1
   'fun' function
      src/glob.l
      src/apply.l
      test/src/apply.l
      doc/ref.html
      doc/refF.html

22.4.30
   Add "epub" mime type
      lib/http.l

22.4.26
   Outdated example for 'lisp'
      doc/refL.html

22.4.24
   Define PATH_MAX
      src/sysdefs.c
      lib/vip.l

22.4.22
   Preserve 'errno' across readline(3) calls
      src/dec.l
      src/io.l
      src/lib.c
   Word search without 'match' support
      lib/vip.l

22.4.20
   'noLint' declarations
      lib/xhtml.l
      lib/svg.l
      lib/canvas.l

22.4.17
   Don't maintain ErrFrames and CtlFrames in coroutines
   Fix file descriptor leak when stopping coroutines
      src/dec.l
      src/flow.l

22.4.11
   'trail' check not needed
      lib/app.l

22.4.9
   Collect also C-tags into @lib/map
      src/lib/llvm.l
      src/main.l
      src/pico.h
      src/lib.c

22.4.8
   Add "-o lib.bc"
   Add "clean2" target
      src/Makefile

22.4.6
   Optional rounding in 'lat', 'lon' and 'fmt'
      lib/gis.l

22.4.5
   Check zero charCode in hint key events
      lib/form.js

####### 22.3 #######
22.3.16
   Pre-set 'home' property in 'form'
   Conditionally unlock and enable in 'panel'
      lib/form.l

22.3.14
   Bug in 'ps'
      lib/svg.l
   Local and private declarations
      lib/xm.l
   Escape also backslashes in ''
      lib/gis.l

22.3.13
   Escape single quotes in '' text argument
      lib/gis.l
   Use 'get' instead of (cdr (asoq ..))
      lib/xm.l

22.3.8
   Revisit tcsetpgrp() calls
      src/dec.l
      src/flow.l
      lib/debug.l

22.3.4
   Plain searches without 'match' overhead
      lib/vip.l

22.2.28
   Issues with tcsetpgrp() calls
      src/io.l
      src/flow.l

22.2.26
   Transient and private namespaces in catch and coroutine frames
      src/glob.l
      src/dec.l
      src/main.l
      src/gc.l
      src/flow.l

22.2.24
   Refactor 'repl' loops
      src/io.l

22.2.23
   Don't exit top-level REPL
      src/main.l
      src/io.l

22.2.22
   Print error location in 'repl'
      lib/form.l
   Print error location in 'evCmd'
      lib/vip.l

22.2.21
   'height' function
   Handle '0' and 'T' directly in 'ps'
      lib/svg.l

22.2.19
   Handle NILs in (has> . +List)
      lib/db.l
   Increase stack size
      bin/vip

22.2.13
   'move!>' method for '+Entity'
      lib/too.l

22.2.11
   Comment for 'fill'
      src/subr.l

22.2.5
   Remove 'dbs+'
      lib/db.l
      doc/ref.html
      doc/refD.html
   Pass '*Uuid' and arguments to RPC calls
      lib/android.l

22.2.2
   Revisit (rel> . +Dep)
      lib/db.l

22.2.1
   Add 'nth' to "see also" of 'get'
      doc/refG.html

22.1.30
   Additional arguments to 'fish'
      src/apply.l
      doc/refF.html
      test/src/apply.l
      lib/too.l

22.1.28
   Optional third argument to 'fill'
      src/subr.l
      doc/refF.html
      test/src/subr.l

22.1.27
   'wrap' also converts string to list of strings
      lib/misc.l
      doc/refW.html
      test/lib/misc.l
   'badDep' function
      lib/too.l

22.1.26
   Bug in (rel> . +Dep)
      lib/db.l

22.1.21
   Optional database file for 'forall'
      lib/db.l
      doc/refF.html
   Inherit tags from superclasses
      lib/vip.l
   Refactor screen handling
      lib/term.l
      lib/vip.l

22.1.20
   'seq' instead of 'dbMap' in 'dangling'
   'displaced' function
      lib/too.l

22.1.18
   Stack check in 'apply'
      src/apply.l
   Discrete-Event Simulation: 'des', 'pause', 'event' and 'wake' functions
      lib/simul.l

22.1.15
   '-debug' and '-trace' functions
      lib/debug.l
      doc/ref.html
      doc/refD.html
      doc/refT.html

22.1.13
   Change "EMail" to "E-Mail"
      doc/form/refM.html

22.1.11
   Central Kurdish localization (Hunar Omar)
      loc/CKB.l
      loc/ckb

22.1.10
   Variable '*Port'
      bin/pty

22.1.8
   Handle SIGWINCH
      bin/pty
   Reset readline in 'setTerm'
      lib/term.l
   Display namespace in 'repl'
      lib/form.l

22.1.7
   'refObj' searches also values
      lib/too.l

22.1.6
   Don't reset 'Busy' in ping()
      lib/form.js

22.1.4
   Bug in 'name' for external symbols
      src/sym.l

####### 21.12 #######
22.1.3
   Bugs in (del> . +Entity) and (has> . +List)
      lib/db.l
      test/lib/db.l
   'assoc', 'rassoc', 'asoq' and 'rasoq' accept circular lists
      src/subr.l
      test/src/subr.l

21.12.30
   Enable file transfers (via 'pbPut' and 'pbGet' in PilBox)
      bin/pty

21.12.29
   Fix touch scrolling in chart tables
      lib/form.l
      lib/form.js
      lib/xhtml/table

21.12.27
   '-symbols' function
      lib.l
      doc/ref.html
      doc/refS.html

21.12.22
   OpenBSD patch (Frithjof Schulze)
      src/httpGate.c

21.12.20
   Don't put single "." into readline history

21.12.14
   Avoid 'resolveActivity' in 'startActivityForResult'
      lib/android.l

21.12.13
   Splice also atomic results in "~" read macros and 'fill'
      src/io.l
      src/subr.l
      test/src/subr.l
      doc/refF.html

21.12.12
   Bug in 'format' (llvm~fmtNum)
      src/big.l
   Overflow float/double to bignum
      src/dec.l
      src/main.l
      src/pico.h
      src/lib.c

21.12.10
   'native' and 'struct' not limited to C functions
      doc/refN.html
      doc/refS.html
   'Str' not used in 'getWord'
      lib/vip.l

21.12.8
   Add 'adr' to "see also" of 'native'
      doc/refN.html

21.12.5
   Global '*Keys'
   ":map" command
      lib/vip.l

21.12.4
   Lock, sync and commit external symbols
      lib/vip.l

21.11.30
   'R' may be modified in 'evCmd'
      lib/vip.l

21.11.29
   Extend 'command' with '*CmdMap'
   Continue direct editing only with "K" ("^]" always goes to source)
      lib/vip.l

21.11.28
   Remove '*Complete' filter
      lib/vip.l

21.11.26
   'all*' function
      lib.l
      doc/refA.html
   Refactor TAB-completion
      lib/vip.l

21.11.25
   Search namespaces in TAB-completion
      lib/vip.l

21.11.22
   Minor cosmetics
      lib.css
      lib/canvas.js
      lib/plio.js
      lib/gis.js
      loc/ar
      loc/ch
      loc/cn
      loc/de
      loc/hr
      loc/it
      loc/ja
      loc/tr

21.11.21
   Simplify style manipulations
      lib/form.l
      lib/form.js

21.11.18
   Bug in 'bagBag'
      lib/form.l

21.11.17
   Minor cosmetics
      lib/form.l
   Inherit 'Dbf' in 'forall' from superclasses
      lib/db.l

21.11.16
   Re-introduce the '====' function
      src/glob.l
      src/sym.l
      test/src/sym.l
      doc/ref_.html
      doc/diff
   and use it in 'locale'
      lib/misc.l
   Preserve transients in comma read macro
      src/io.l

21.11.15
   Use 'fName' in 'vf'
      lib/vip.l

21.11.12
   '+ObjVar' prefix class
      lib/form.l

21.11.11
   Missing semicolon (Mia)
      lib/form.js

21.11.9
   Increase escape delay from 80 to 120
      lib/vip.l

21.10.31
   Mention Ctrl-D to terminate 'bt', 'query' and '?'
      doc/ref.html
      doc/refB.html
      doc/refM.html
      doc/refQ.html
      doc/ref_.html

21.10.30
   Generalize cut in 'prove'
      src/subr.l

21.10.29
   rl_initialize() not necessary
      src/lib.c

21.10.28
   Display namespace in 'status'
      lib/vip.l
   Minor optimization in '*Prompt'
      lib/debug.l

21.10.27
   'vf' (vi/find) function
      lib/vip.l
   Default '*Tab' to 1
      lib/xhtml.l

21.10.25
   '*KeyMap', '*KeyMap-g' and '*KeyMap-q' globals (Erik Gustafson)
   More transients
      lib/vip.l

21.10.18
   Refactor (gui> . +User)
      lib/adm.l
      lib/user.l

21.10.15
   Mention Ctrl-D to terminate 'more'
      doc/refM.html

21.10.11
   "CSV" -> "Export CSV" in 'csv'
      lib/xhtml.l

21.10.9
   'pico~cells' function
      lib/vip/draw.l
   Minor cosmetics
      lib/vip.l
   Fix 'arrow' for small distances
      lib/vip/draw.l

21.10.2
   Remove '+JsField'
      lib/form.l
      doc/app.html
      doc/form/refJ.html
   Import 'permute' from 'pico' namespace
      lib/simul.l

21.9.29
   '+hintObj' prefix class for '+Obj' and '+ObjVal'
      lib/form.l

21.9.25
   'rand' argument checks
      src/big.l
      doc/refR.html

21.9.24
   Ignore SIGINT in 'ctty' parent process
      src/main.l
   Forward "^D"
      bin/pty

21.9.23
   Clear '*Err'
      bin/pty

21.9.20
   Initial '$StkBrk' and '$StkLimit'
      src/glob.l
      src/main.l

21.9.19
   ulimStk() system call
      src/dec.l
      src/pico.h
      src/lib.c

21.9.17
   Clear 'history' after argument evaluation
      src/main.l

21.9.16
   Insert "^M" before "^J" in 'mail' body
      lib/misc.l
   'refObj' function
      lib/too.l

21.9.13
   Insert "^M" before "^J" in 'mail' body
      lib/misc.l
   'prBase64' optional "^M" argument
      lib/misc.l
      doc/refP.html
   Explanations for reference syntax
      doc/ref.html

21.9.10
   "gg" uses *Count
      lib/vip.l

21.9.3
   'mis>' method for '+Swap'
      lib/db.l

21.9.1
   select() system calls are now poll()
      doc/refK.html
      doc/refL.html
      doc/refR.html
      doc/refS.html
      doc/refW.html

21.8.30
   Typo
      doc/refR.html

21.8.28
   Add note about 'native'
      doc/faq.html
   'rid' function
      test/src/sym.l

21.8.27
   'rid' function
      src/glob.l
      src/sym.l
      test/src/sym.l
      doc/ref.html
      doc/refC.html
      doc/refD.html
      doc/refF.html
      doc/refQ.html
      doc/refR.html

21.8.26
   Bug in 'place'
      src/subr.l
      test/src/subr.l

21.8.25
   Division by zero did not throw an error
      src/big.l
   Private declarations
      lib/xhtml.l

21.8.22
   Default alert text color black
      lib.css

21.8.20
   Wrong 'tty' checks for stdin/stdout
      src/main.l
      src/flow.l

21.8.19
   LLC and LINK variables
      src/Makefile

21.8.18
   Strip binaries
      src/Makefile
   'rasoq' function
      src/glob.l
      src/subr.l
      test/src/subr.l
      doc/ref.html
      doc/refA.html
      doc/refR.html

21.8.16
   Add 'packJson'
      lib/json.l

21.8.14
   Sort TAB-completion
      lib/vip.l
   Host option
      bin/pty

21.8.13
   Check (sys "SHELL") for default shell
      lib/vip.l

21.8.12
   Some Pilog variables private again
      lib/pilog.l

21.8.11
   Default shell "bash" -> "sh"
      lib/vip.l
   Shell prefix "$ " -> "!" in 'repl'
      lib/form.l

21.8.9
   'go', 'up', 'down', 'left' and 'right functions
   'block' function
      lib/vip/draw.l
   Preset terminal attributes in setRaw()
      src/lib.c

21.8.8
   Add files
      lib/term.l
      bin/pty

21.8.7
   Clean up terminal handling
      lib/vip.l

21.8.6
   Define TIOCSWINSZ
      src/sysdefs.c
   Set standard I/O to a PTY with (ctty)
      src/Makefile
      src/dec.l
      src/main.l
      doc/refC.html

21.8.3
   'tty' flag also in 'inFile'
      src/dec.l
      src/main.l
      src/io.l
      src/flow.l

21.7.27
   Direct 'run' in auto-load with "# VIP (...)"
      lib/vip.l

21.7.26
   Bug in reading non-ASCII characters in internal symbols
      src/io.l

21.7.25
   'cnt' argument to 'unify'
      src/subr.l
      lib/pilog.l
      doc/refU.html

21.7.24
   Signal handler in 'prove'
      src/subr.l

21.7.23
   Pilog variables not private
      lib/pilog.l
   Revisit Pilog variables in Lisp expressions
      src/subr.l

21.7.22
   Revisit private symbols in properties
      lib/vip.l

21.7.21
   Global '*Rule' cleared in 'repl'
      src/glob.l
      src/io.l
      doc/ref.html
      doc/refB.html
      doc/refC.html
      doc/refR.html
   Maintain source properties also in 'clause'
      lib/pilog.l
   Bind Pilog variables in Lisp expressions
      src/subr.l
      lib/pilog.l
      test/src/subr.l
      doc/ref.html
      doc/refM.html
      doc/refR.html
      doc/refT.html
   Intern private symbols also in properties
      lib/vip.l
   Bug in 'putSrc' for first property
      src/flow.l

21.7.18
   Minor cosmetics
      src/subr.l

21.7.16
   em120 and em150 styles
      lib.css

21.7.13
   'buf' function
      doc/ref.html
      doc/refB.html

21.7.10
   Revisit (put> . +Swap)
      lib/db.l
      test/lib/db.l

21.7.5
   Fix 'clone>' for '+Swap' in '+Bag'
      lib/db.l

21.7.4
   E/R unit tests
      lib/test.l
      test/src/sym.l
      test/src/db.l
      test/lib/db.l
   Clean up 'has>' methods
      lib/db.l
      lib/tinymce.l
   Revisit '+Bag' and '+Swap'
      lib/db.l

21.7.3
   Support methods as ":ta msg> +Cls"
      lib/vip.l
   Make 'bagBag' non-destructive
      lib/form.l

21.7.2
   'forall' function
      doc/ref.html
   Add file
      doc/rc.sample

21.7.1
   'forall' function
      lib/db.l
      doc/refF.html

####### 21.6 #######
21.6.30
   '+Swp' prefix class
      lib/form.l
   Lazy external symbol creation in '+Swap'
      lib/db.l
   'has>' check in (rel> . +Joint)
      lib/db.l
   Keep application namespaces for background tasks in '*Ns'
      lib/vip.l

21.6.29
   Keep application namespaces for background tasks in '*Ns'
      lib/vip.l
      bin/vip

21.6.24
   Minor addition
      doc/microTemplates

21.6.23
   Micro-templates for '' and ''
      doc/microTemplates

21.6.22
   Micro-templates for '
' and ''
      lib/xhtml.l
      lib/xhtml/table
      lib/xhtml/grid
   Add  and 
      lib/xhtml/tab

21.6.21
   Minor fix in reference for 'all'
      doc/refA.html

21.6.20
   Micro-templates 2.0
      lib/xhtml.l
      lib/xhtml/
      doc/microTemplates

21.6.19
   Wrong 'Attr' output in 'html'
      lib/xhtml.l
   'pack' not needed
      lib/vip.l
   General argument to 'any'
      src/io.l
      doc/refA.html

21.6.18
   Also 'flip'ped sort in 'sortButton'
      lib/form.l

21.6.17
   'sortButton' function
      lib/form.l

21.6.16
   Vip running in coroutine
   Suspend with "qz", resume with (v)
      lib/vip.l
      doc/refV.html

21.6.15
   Fix terminal after 'pipe', 'in' and 'out'
      src/io.l

21.6.14
   Minor fix indentation
      src/flow.l
   Restore private declarations
      lib/xhtml.l
   Missing '+Remote' methods
      lib/db.l

21.6.13
   Add '\e' to escape markups
      src/io.l
      doc/ref.html

21.6.11
   Optional 'put' and 'get' function arguments for '+Joint'
      lib/db.l

21.6.9
   Revert confirm row deletion (01may21)
      lib/form.l

21.6.4
   'ctty' 'NIL' argument is obsolete
      src/main.l
      doc/refC.html
   Minor renaming
      src/flow.l

21.6.2
   Push tag stack in "gf" command
      lib/vip.l
   Add A3 page sizes
      lib/svg.l
   Intern some globals for reload
      lib/form.l

21.6.1
   'class' clears old method and var definitions
   'var' uses 'def' instead of 'put'
      lib.l
      test/lib.l

21.5.29
   Set cooked terminal mode in 'repl'
      src/io.l

21.5.27
   Revisit TAB-completion
      lib/vip.l
   Use 'val' for '+Swap' relations in 'set>'
      lib/db.l

21.5.25
   Revisit TAB-completion from 'history'
      lib/vip.l
   Unary '+' is obsolete in '*Run' setup
      lib.l

21.5.24
   Nesting bug in 'cells'
      lib/vip/draw.l

21.5.23
   Maintain 'symbols' per buffer
      lib/vip.l

21.5.21
   TAB-complete from 'history' on ": "
   ":v" command
      lib/vip.l

21.5.20
   setCooked() only if necessary
      src/lib.c

21.5.19
   Add file
      lib/clang.l

21.5.18
   Fix 'struct'  example
      doc/refS.html

21.5.14
   '' vertical-aligns to top
      lib.css
   Optional submenu CSS class index
      lib/xhtml.l
      lib/xhtml/menu

21.5.12
   Add file
      doc/microTemplates
   Needs '*XhtmlField' in ''
      lib/xhtml.l

21.5.11
   Don't set IPV6_V6ONLY for OpenBSD
      lib/net.l

21.5.10
   64-bit check not needed
      lib/adm.l

21.5.6
   Missing '+Remote' methods
      lib/db.l
   Missing 'mail' handshake (Mike Pechkin)
      lib/misc.l

21.5.5
   Fix catch/throw between coroutines
      src/dec.l
      src/main.l
      src/flow.l
      doc/structures
      doc/ref.html

21.5.4
   I/O save/restore bug in 'co' / 'yield'
      src/main.l
      src/flow.l
   Minor cosmetics (collapse two 'let's)
      src/flow.l
   Fix docs and comments about coroutine tags
      src/main.l
      src/flow.l
      doc/ref.html
      doc/refC.html
      doc/refS.html
      doc/refY.html

21.5.3
   (co) returns tag of current coroutine
      src/flow.l
      doc/refC.html
   'shift' function
      src/glob.l
      src/sym.l
      doc/ref.html
      doc/refS.html
      doc/refP.html
      test/src/sym.l

21.5.1
   Confirm row deletion also if repeated
      lib/form.l

21.4.30
   Add file
      doc/app.html

21.4.29
   Call 'loadCoEnv' in 'unwind'
      src/main.l
      src/flow.l
   Remove coroutines from catch/throw environment
      src/glob.l

21.4.22
   Show thousands-separator in total counts in search dialogs
      lib/form.l

21.4.21
   File in first column of directory listings
      lib/vip.l

21.4.20
   Bug in 'till' reading UTF-8
      src/io.l

21.4.19
   Align SUBRs to 8 bytes
      src/lib/llvm.l

21.4.18
   's-expr' function, evaluate with "^E"
      lib/vip.l

21.4.17
   'stack' return value fix
      src/main.l
      doc/refS.html
   Infinite timeout for values greater than 24 days in '*Run', 'wait' and 'key'
   on non-Linux systems (using ppoll(2) on Linux)
      src/lib.c
   'stack' continued
      src/main.l

21.4.16
   Independent size of main stack segment
      src/glob.l
      src/main.l
      src/flow.l
      doc/refS.html
   'stack' returns unused spaces
      src/main.l
      doc/refS.html
   'llvm~cons2' function
      src/dec.l
      src/gc.l
   Coroutine structure 'prv'
      doc/structures
   Optional alignment for 'memcpy' and 'memset'
      src/lib/llvm.l
      src/main.l
      src/db.l
      src/flow.l

21.4.15
   Infinite timeout for values greater than 24 days in '*Run', 'wait' and 'key'
   (only on systems with sizeof(int) == 4)
      src/lib.c

21.4.14
   Skip remote replication if 'key' is empty
      src/ssl.c

21.4.13
   Bug in '
': Header text not evaluated
      lib/xhtml.l
   ContextCompat 'permit' function
      lib/android.l
   'Str' in 'repl' private
      lib/form.l

21.4.10
   Minor fix indentation
      lib/vip.l

21.4.9
   Extensions to 'NIL' punning
      doc/ref.html

21.4.8
   Support '-fun' command line arguments
      bin/vip

21.4.7
   'enum?' function
      src/glob.l
      src/sym.l
      doc/ref.html
      doc/refE.html
      doc/refL.html
      test/src/sym.l

21.4.4
   Wrong external declaration
      src/ht.l

21.4.3
   Bug in 'stem' (for -O2 or -O3)
      src/subr.l

21.4.1
   'enum' returns cell instead of value
      src/sym.l
      doc/refE.html
      test/src/sym.l
      doc/faq.html
   Bug in '*Term' signal handling
      src/main.l

21.3.31
   '+Remote' entity class
      lib/db.l
      lib/too.l

21.3.30
   Exit '*', '/*', '/' and '%' upon zero
      src/big.l

21.3.29
   Note about the default browser for 'doc' calls
      man/man1/picolisp.1
      doc/man.html

21.3.26
   'enum' with single argument returns association list
      src/sym.l
      doc/refE.html
      test/src/sym.l

21.3.25
   Return 'NIL' from 'enum' if key <= 0
      src/sym.l
   Unit tests for 'enum'
      test/src/sym.l
   '*Term' signal handling (Constantine Bitensky)
      src/glob.l
      src/main.l
      doc/ref.html
      doc/refT.html
      doc/refA.html
      doc/refH.html
      doc/refS.html
      doc/refW.html

21.3.24
   'enum' function
      src/sym.l

21.3.23
   'enum' function
      src/glob.l
      src/sym.l
      doc/ref.html
      doc/refE.html
      doc/refH.html
      doc/refI.html
   'rev' function bit count argument
      src/big.l
      doc/refR.html

21.3.21
   'rev' function
      src/glob.l
      src/big.l
      doc/ref.html
      doc/refR.html
      doc/refH.html
      doc/refI.html
      doc/ref_.html

21.3.17
   Still missing
      lib/xm.l
   Ukrainian and russian localization (Constantine Bitensky)
      loc/RU.l
      loc/uk
      loc/ru

21.3.10
   Renamed "UK.l" to "UA.l", restored "UK.l" and renamed to "GB.l"
   Renamed "gr" to "el" and "jp" to "ja"
      loc/UA.l
      loc/GB.l
      loc/uk
   Symbolic links
      UK.l -> GB.l
      gr -> el
      jp -> ja

21.3.8
   Missing file
      lib/xm.l

21.3.7
   Ukrainian localization (Constantine Bitensky)
      loc/UK.l
      loc/uk

21.3.5
   Subdirectory recursion buffer-local
   Recurse when no trailing "/"
      lib/vip.l

21.3.2
   '*Bye' cleared in children
      src/io.l
      lib.l
      lib/adm.l
      lib/app.l
      doc/diff

21.2.28
   Missing check for 'NIL'
      lib/vip.l

21.2.26
   Remove Access-Control-Allow-Origin header
      lib/http.l

21.2.20
   Prefix "@" with "./" in directory listings
   Recurse into subdirectories with ":E"
      lib/vip.l

21.2.16
   Case insensitive search with "~" prefix
   Increase escape delay to 80 ms
      lib/vip.l

21.2.12
   Rename file to "area", add "field"
      lib/xhtml.l
      lib/xhtml/area
      lib/xhtml/field

21.2.11
   Elaborate ''
      lib/xhtml.l
      lib/xhtml/textarea

21.2.9
   Ignore SIGHUP for non-config calls
      src/httpGate.c

21.2.8
   Start task in first 'heartbeat' call
      lib/heartbeat.l
   Touch events not needed
      lib/xhtml/tab

21.2.7
   Variable titles in menu
   Layout template line format
      lib/xhtml.l
      lib/xhtml/menu
      lib/xhtml/layout

21.2.5
   'plio' must preserve $Ptr and $End
      src/io.l
   Load @lib/too.l always in 'psh'
      lib/http.l

21.2.3
   Load @lib/sq.l in 'psh'
      lib/http.l

21.2.2
   Optional insert string in config keys
      src/httpGate.c
      doc/httpGate.html

21.2.1
   Typo ".pil" -> "./pil"
      doc/httpGate.html

21.1.28
   Typo "none" -> "nond"
      doc/tut.html

21.1.25
   Remove 'evCmd' from custom function keys
      lib/vip.l

21.1.23
   'fish' function "skip" return value
      src/apply.l
      doc/refF.html
      lib/vip.l

21.1.22
   em80, em90 and em100 styles
      lib.css

21.1.21
   Stack check in 'fish'
      src/apply.l

21.1.20
   Comment
      lib/tinymce.l

21.1.18
   Bug in 'pack' of external symbol names
      src/sym.l

21.1.17
   'pil' backport
      lib/compat.l

21.1.15
   Micro-templates
      lib/xhtml.l
      lib/xhtml/
   Bug in 'pass'
      src/apply.l
   Call 'bufString' instead of 'pathString' in 'token'
      src/io.l

21.1.14
   Bug in 'bit?'
      src/big.l

21.1.8
   Minor cosmetics
      src/subr.l
   Improved terminal reset
      src/lib.c

21.1.5
   Debian release

Dec20
   Pil21 initial version

####### 21.0 #######


================================================
FILE: doc/Tracks
================================================
# VIP @lib/vip/draw.l
# 25may23 Software Lab. Alexander Burger

(label 1 1 "Connectors:")

(cells 7 6 '(| | | . |))
(go 1 3 "-")
(right 9 "+")
(down 2 "v")
(go 10 8 "+")
(down 8 "v")
(go 28 6 "+")
(up 3 "+")
(right 14 ">")
(go 46 6 "+")
(up 3 "+")
(right 30 ">")

(box 7 17 13 6 "Track"
   (label 1 1 "- a")
   (label 10 1 "b -")
   (label 2 5 "x")
   (label 11 5 "y") )
(go 7 18 "+")
(left 4 "+")
(up 11 "+")
(right 3 ">")
(go 20 18 "+")
(right 4 ">")

(cells 25 17 '(| | | . |))
(go 28 17 "+")
(up 3 "+")
(left 11 "+")
(down 2 "v")
(go 76 22 "-")
(left 48 "+")
(up 2 "\^")
(go 46 19 "+")
(down 6 "+")
(left 45 "<")
(go 64 19 "+")
(down 6 "+")
(left 14 "<")

(go 70 17 "+")
(up 6 "+")
(left 58 "+")
(up 2 "\^")
(go 52 8 "+")
(down 6 "+")
(left 22 "+")
(down 2 "v")


================================================
FILE: doc/des.html
================================================
Discrete-Event Simulationabu@software-lab.de
Discrete-Event Simulation (DES)
(c) Software Lab. Alexander Burger


PicoLisp has a Discrete-Event
Simulation library in "@lib/simul.l".


Implementation
The simulated objects (often called "Agents") are implemented as separate coroutines. These are
created the normal way with co, and the library functions
use yield to transfer
control between them.


Only one coroutine may be running at one point in time. All others are either


    

  • ready to run,

  • waiting for the next scheduled point in time, and/or

  • waiting for one or several specific signals (events).

A running coroutine can suspend itself, and cause another coroutine to
resume, by either


    

  • passing control to the next coroutine, or

  • pausing for a given amount of time and/or waiting for signals.

The simulation can optionally run in realtime mode. In that case, it sleeps
between the scheduled points in time, and accepts key strokes for user
interaction.


The library consists of five global variables and four functions.



Global Variables



*Time


Simulated system time since the start of the simulation. It can be in any
unit, but should be in milliseconds if in realtime mode.



*Ready


Queue of coroutines ready to run.



*Next


idx tree of
coroutines pausing for a given time.



*Rt


Realtime: Either NIL (default), or 1 for wall clock speed, 2
for double speed etc.



*Keys


Holds possibly queued key presses (only in realtime mode).



Functions



(des [. prg])


Performs one discrete-event simulation step. It first runs all coroutines in
*Ready until that queue is empty. Then - if *Next is
not empty - advances the simulation to the next point in time, and resumes all
corresponding coroutines. In that case, if in realtime mode, it delays execution
as necessary, handles possible key presses, and runs prg after each
key.



(pause ['cnt|sym] ..) -> any


Waits for events (i.e. a time span elapsed or a signal arrived). For a
numeric argument, the current coroutine is scheduled in *Next for a
point in time after that number of time units. For symbolic arguments, the
current coroutine is queued into those symbol's event queues. In any case,
control is passed to the next coroutine.



(event 'sym 'exe)


Sends the signal sym to all coroutines waiting in that symbol's
event queue. As a result, these coroutines are removed from the queue and
appended to the *Ready queue, with the optional exe to
be evaluated when resumed. The current coroutine continues to run.



(wake 'sym 'exe)


Wakes up another coroutine sym, by appending it to the
*Ready queue with the optional 'exe' to be evaluated when resumed.
This means that if sym is currently waiting for a point in time in
*Next, it is removed from that index (i.e. the pause is aborted).
Also, if sym is waiting for signals, it is removed from those event
queues. The current coroutine continues to run.



Usage
A typical DES program will start some coroutines and let them perform their
initial work until they need to pause.


That means, if a given operation in the simulation is supposed to take
cnt time units, this coroutine calls pause with that
number. Or, if it depends on some signals from another part of the program, it
may call pause with those symbols. In any case - as it has nothing
else to do - it goes to sleep.


When all of them wait for a time or signal, control is returned to the main
program. All coroutines are now waiting in *Next or some signal
event queue (or in *Ready if they just gave up control with
(pause)).


The main program may now check *Next and perhaps
*Ready. If both are empty, no further events can occur, and the
program may terminate.


Otherwise, it calls des to continue with the next step(s).


At any time, a coroutine or the main program may call wake, for
example to interrupt another coroutine and cause it to throw into some other
context, or have that coroutine's pause return a special value by
evaluating the exe argument.




An Example
Let's use DES to demonstrate the well-known Dining
Philosophers Problem.


 Put the following code into a file "dining.l".


# 07sep23 Software Lab. Alexander Burger
# Dining Philosophers
# pil dining.l -dining~main +

(load "@lib/simul.l")

(symbols 'dining 'simul 'pico)

(local) (*ForkA *ForkB *ForkC *ForkD *ForkE now think)

(de now (Str)
   (prinl (tim$ (* 60 *Time)) " " (co) " " Str) )

(de think (Left Right)
   (loop
      (now "thinking")
      (pause (rand 180 240))  # 3 to 4 hours
      (now "hungry")
      (while (or (val Left) (val Right))
         (now "waiting")
         (pause Left Right) )
      (set Left (set Right (co)))
      (now "eating")
      (pause 20)  # 20 minutes
      (set Left (set Right NIL))
      (event Left)
      (event Right) ) )

(local) main

(de main ()
   (symbols '(dining simul pico))
   (co 'Aristotle
      (think '*ForkA '*ForkB) )
   (co 'Kant
      (think '*ForkB '*ForkC) )
   (co 'Spinoza
      (think '*ForkC '*ForkD) )
   (co 'Marx
      (think '*ForkD '*ForkE) )
   (co 'Russell
      (think '*ForkE '*ForkA) ) )

It uses five global variables *ForkA through *ForkE
and five coroutines Aristotle, Kant,
Spinoza, Marx and Russell. They all run
the same function think, with their neighboring forks as
Left and Right arguments.


In think, each philospher is first "thinking" for a random time
between three and four hours. Then it gets "hungry", tries to pick up both
forks, and - if at least one of the forks is in use - starts "waiting" for a
left or right fork signal from another philosopher, and checks the forks again.


Now both forks are free. The philosopher puts himself into both (it could put
in fact any non-NIL value), then is "eating" for 20 minutes,
releases both forks by setting them to NIL, and sends a left and a
right fork signal to the neighboring philosophers possibly waiting for the
forks.


The simulation cannot deadlock, because both forks are picked up and released
atomically, and because coroutines waiting for fork signals are always queued
after the other waiting coroutines.


Sample Run
$ ./pil misc/dining.l -dining~main +
00:00 Aristotle thinking
00:00 Kant thinking
00:00 Spinoza thinking
00:00 Marx thinking
00:00 Russell thinking
dining: (more (stack))
(Russell . 62)
(Marx . 62)
(Spinoza . 62)
(Kant . 62)
(Aristotle . 62)
(T . 155)
-> NIL
dining: *Ready
-> NIL
dining: (idx '*Next)
-> ((180 . Aristotle) (194 . Marx) (198 . Russell) (201 . Spinoza) (229 . Kant))
dining: (des)
03:00 Aristotle hungry
03:00 Aristotle eating
-> NIL
dining: (des)
03:14 Marx hungry
03:14 Marx eating
-> NIL
dining: (des)
03:18 Russell hungry
03:18 Russell waiting
-> NIL
dining: (do 10 (des))
03:20 Aristotle thinking
03:20 Russell waiting
03:21 Spinoza hungry
03:21 Spinoza waiting
03:34 Marx thinking
03:34 Spinoza eating
03:34 Russell eating
03:49 Kant hungry
03:49 Kant waiting
03:54 Russell thinking
03:54 Spinoza thinking
03:54 Kant eating
04:14 Kant thinking
06:27 Aristotle hungry
06:27 Aristotle eating
06:47 Aristotle thinking
06:47 Marx hungry
06:47 Marx eating
07:07 Marx thinking
07:40 Russell hungry
07:40 Russell eating
-> NIL
dining:




================================================
FILE: doc/doc.css
================================================
/* 22oct23 Software Lab. Alexander Burger
 * 06dec12jk
 */

html {
   background-color: #ddd;
}

body {
   margin: auto;
   max-width: 50em;
   border: 1px solid #bbb;
   background-color: white;
   padding: 2em 7% 4em 10%;
}

h5 {
   font-size: 95%;
   margin-bottom: 1em;
}

dt {
   margin: 0.4em -2em 0 0;
   font-weight: 600;
   color: #444;
}

dd {
   margin-top: 0.3em;
   margin-bottom: 0.4em;
}

code, pre {
   color: rgb(0%,40%,0%);
}

dt code {
   word-spacing: -0.04em;
}


================================================
FILE: doc/faq.html
================================================
PicoLisp FAQabu@software-lab.de

Monk: "If I have nothing in my mind, what shall I do?"

Joshu: "Throw it out."

Monk: "But if there is nothing, how can I throw it out?"

Joshu: "Well, then carry it out."

(Zen koan)



PicoLisp Frequently Asked Questions
(c) Software Lab. Alexander Burger


Why did you write yet another Lisp?
Because other Lisps are not the way I'd like them to be. They concentrate on
efficient compilation, and lost the one-to-one relationship of language and
virtual machine of an interpreted system, gave up power and flexibility, and
impose unnecessary limitations on the freedom of the programmer. Other reasons
are the case-insensitivity and complexity of current Lisp systems.



Who can use PicoLisp?
PicoLisp is for programmers who want to control their programming
environment, at all levels, from the application domain down to the bare metal,
who want to use a transparent and simple - yet universal - programming model,
and who want to know exactly what is going on.


It does not pretend to be easy to learn. There are already plenty of
languages that do so. It is not for people who don't care what's under the hood,
who just want to get their application running. They are better served with some
standard, "safe" black-box, which may be easier to learn, and which allegedly
better protects them from their own mistakes.



What are the advantages over other Lisp systems?
Simplicity
PicoLisp is easy to understand and adapt. There is no compiler enforcing
special rules, and the interpreter is simple and straightforward. There are only
three data types: Numbers, symbols and lists ("LISP" means "List-, Integer- and
Symbol Processing" after all ;-). The memory footprint is minimal, and the
tarball size of the whole system is just a few hundred kilobytes.


A Clear Model
Most other systems define the language, and leave it up to the implementation
to follow the specifications. Therefore, language designers try to be as
abstract and general as possible, leaving many questions and ambiguities to the
users of the language.


PicoLisp does the opposite. Initially, only the single-cell data structure
was defined, and then the structure of numbers, symbols and lists as they are
composed of these cells. Everything else in the whole system follows from these
axioms. This is documented in the chapter about The
PicoLisp Machine in the reference manual.


Orthogonality
There is only one symbolic data type, no distinction (confusion) between
symbols, strings, variables, special variables and identifiers.


Most data-manipulation functions operate on the values of symbols as well as
the CARs of cons pairs:


: (let (N 7  L (7 7 7)) (inc 'N) (inc (cdr L)) (cons N L))
-> (8 7 8 7)

There is only a single functional type, no "special forms". As there is no
compiler, functions can be used instead of macros. No special "syntax"
constructs are needed. This allows a completely orthogonal use of functions. For
example, most other Lisps do not allow calls like


: (mapcar if '(T NIL T NIL) (1 2 3 4) (5 6 7 8))
-> (1 6 3 8)

PicoLisp has no such restrictions. It favors the principle of "Least
Astonishment".


Object System
The OOP system is very powerful, because it is fully dynamic, yet extremely
simple:


    

  • In other systems you have to statically declare "slots". In PicoLisp,
classes and objects are completely dynamic, they are created and extended at
runtime. "Slots" don't even exist at creation time. They spring into existence
purely dynamically. You can add any new property or any new method to any single
object, at any time, regardless of its class.


  • The multiple inheritance is such that not only classes can have several
superclasses, but each individual object can be of more than one class.


  • Prefix classes can surgically change the inheritance tree for any class or
object. They behave like Mixins in this regard.


  • Fine-control of inheritance in methods with super and extra.


Pragmatism
PicoLisp has many practical features not found in other Lisp dialects. Among
them are:


    

  • Auto-quoting of lists when the CAR is a number. Instead of '(1 2
3) you can just write (1 2 3). This is possible because a
number never makes sense as a function name, and has to be checked at runtime
anyway.


  • The quote function returns all
unevaluated arguments, instead of just the first one. This is both faster
(quote does not have to take the CAR of its argument list) and
smaller (a single cell instead of two). For example, 'A expands to
(quote . A) and '(A B C) expands to (quote A B
C).


  • The symbol @ is automatically
maintained as a local variable, and set implicitly in certain flow- and
logic-functions. This makes it often unnecessary to allocate and assign local
variables.


  • Functional I/O is more convenient than
explicitly passing around file descriptors.


  • A well-defined ordinal relationship between
arbitrary data types facilitates generalized comparing and sorting.


  • Uniform handling of var locations (i.e. values of symbols and
CARs of cons pairs).


  • The universality and usefulness of symbol properties is enforced and
extended with implicit and explicit bindings of the symbol This in combination with the access functions
=:, : and ::.


  • A very convenient list-building machinery, using the link, yoke, chain and made functions in the make environment.


  • The syntax of often-used functions is kept non-verbose. For example, instead
of (let ((A 1) (B 2) C 3) ..) you write (let (A 1 B 2 C 3)
..), or just (let A 1 ..) if there is only a single
variable.


  • The use of the hash (#) as a comment character is more appropriate
today, and allows a clean hash-bang (#!) syntax for stand-alone
scripts.


  • The interpreter is invoked with a simple and
flexible syntax, where command line arguments are either files to be interpreted
or functions to be directly executed. With that, many tasks can be performed
without writing a separate script.


  • A sophisticated system of interprocess communication, file locking and
synchronization allows multi-user access to database applications.


  • A general and dynamic interface for Native C Calls
(FFI).


  • A Prolog interpreter is tightly integrated into the language. Prolog
clauses can call Lisp expressions and vice versa, and a self-adjusting
depth-first search predicate select can be used in database
queries.


Persistent Symbols
Database objects ("external" symbols) are a primary data type in PicoLisp.
They look like normal symbols to the programmer, but are managed in the database
(fetched from, and stored to) automatically by the system. Symbol manipulation
functions like set, put or get, the
garbage collector, and other parts of the interpreter know about them.


Application Server
It is a stand-alone system (it does not depend on external programs like
Apache or MySQL) and it provides a "live" user interface on the client side,
with an application server session for each connected client. The GUI layout and
behavior are described with S-expressions, generated dynamically at runtime, and
interact directly with the database structures.


Localization
Internal exclusive and full use of UTF-8 encoding, and self-translating transient symbols (strings), make it easy to
write country- and language-independent applications.



How is the performance compared to other Lisp systems?
Despite the fact that PicoLisp is an interpreted-only system, the performance
is quite good. Typical Lisp programs operating on list data structures are
executed in (interpreted) PicoLisp at about the same speed as in (compiled)
CMUCL, and about two or three times faster than in CLisp or Scheme48.


But in practice, speed was never a problem, even with the first versions of
PicoLisp in 1988 on a Mac II with a 12 MHz CPU. And certain things are cleaner
and easier to do in C (or other low-level languages) anyway. It is
very easy to write C functions in PicoLisp, either in the kernel,
as shared object libraries, or even inline in the Lisp code.


PicoLisp is very space-efficient. Other Lisp systems reserve heap space twice
as much as needed, or use rather large internal structures to store cells and
symbols. Each cell or minimal symbol in PicoLisp consists of only two pointers.
No additional tags are stored, because they are implied in the pointer
encodings. No gaps remain in the heap during allocation, as there are only
objects of a single size. As a result, consing and garbage collection are very
fast, and overall performance benefits from a better cache efficiency. Heap and
stack grow automatically, and are limited only by hardware and operating system
constraints.



What does "interpreted" mean?
It means to directly execute Lisp data as program code. No transformation to
another representation of the code (e.g. compilation), and no structural
modifications of these data, takes place.


Lisp data are the "real" things, like numbers, symbols and lists, which can
be directly handled by the system. They are not the textual
representation of these structures (which is outside the Lisp realm and taken
care of by the reading and printing functions).


The following example builds a function and immediately calls it with two
arguments:


: ((list (list 'X 'Y) (list '* 'X 'Y)) 3 4)
-> 12

Note that no time is wasted to build up a lexical environment. Variable
bindings take place dynamically during interpretation.


A PicoLisp function is able to inspect or modify itself while it is running
(though this is rarely done in application programming). The following function
modifies itself by incrementing the '0' in its body:


(de incMe ()
   (do 8
      (printsp 0)
      (inc (cdadr (cdadr incMe))) ) )

: (incMe)
0 1 2 3 4 5 6 7 -> 8
: (incMe)
8 9 10 11 12 13 14 15 -> 16

Only an interpreted Lisp can fully support such "Equivalence of Code and
Data". If executable pieces of data are used frequently, like in PicoLisp's
dynamically generated GUI, a fast interpreter is preferable over any compiler.



Is there (or will be in the future) a compiler available?
No. That would contradict the idea of PicoLisp's simple virtual machine
structure. A compiler transforms it to another (physical) machine, with the
result that many assumptions about the machine's behavior won't hold any more.
Besides that, PicoLisp primitive functions evaluate their arguments
independently and are not suited for being called from compiled code. Finally,
the gain in execution speed would probably not be worth the effort. Typical
PicoLisp applications often use single-pass code which is loaded, executed and
thrown away; a process that would be considerably slowed down by compilation.



Is it portable?
Yes and No. Though we wrote and tested PicoLisp originally only on Linux, it
now also runs on many other POSIX systems. The first versions were even fully
portable between DOS, SCO-Unix and Macintosh systems. But today we have Linux.
Linux itself is very portable, and you can get access to a Linux system almost
everywhere. So why bother?


The GUI is completely platform independent (Browser), and in the age of the
Internet an application server does not really need to be portable.



Is PicoLisp a web server?
Not really, but it evolved a great deal into that direction.


Historically it was the other way round: We had a plain X11 GUI for our
applications, and needed something platform independent. The solution was
obvious: Browsers are installed virtually everywhere. So we developed a protocol
which persuades a browser to function as a GUI front-end to our applications.
This is much simpler than to develop a full-blown web server.



I cannot find the LAMBDA keyword in PicoLisp
Because it isn't there. The reason is that it is redundant; it is equivalent
to the quote function in any aspect, because there's no distinction
between code and data in PicoLisp, and quote returns the whole
(unevaluated) argument list. If you insist on it, you can define your own
lambda:


: (def 'lambda quote)
-> lambda
: ((lambda (X Y) (+ X Y)) 3 4)
-> 7
: (mapcar (lambda (X) (+ 1 X)) (1 2 3 4 5))
-> (2 3 4 5 6)

Why do you use dynamic variable binding?
Dynamic binding is very powerful, because there is only one single,
dynamically changing environment active all the time. This makes it possible
(e.g. for program snippets, interspersed with application data and/or passed
over the network) to access the whole application context, freely, yet in a
dynamically controlled manner. And (shallow) dynamic binding is the fastest
method for a Lisp interpreter.


Lexical binding is more limited by definition, because each environment is
deliberately restricted to the visible (textual) static scope within its
establishing form. Therefore, most Lisps with lexical binding introduce "special
variables" to support dynamic binding as well, and constructs like
labels to extend the scope of variables beyond a single function.


In PicoLisp, function definitions are normal symbol values. They can be
dynamically rebound like other variables. As a useful real-world example, take
this little gem:


(de recur recurse
   (run (cdr recurse)) )

It implements anonymous recursion, by defining recur statically
and recurse dynamically. Usually it is very cumbersome to think up
a name for a function (like the following one) which is used only in a single
place. But with recur and recurse you can simply
write:


: (mapcar
   '((N)
      (recur (N)
         (if (=0 N)
            1
            (* N (recurse (- N 1))) ) ) )
   (1 2 3 4 5 6 7 8) )
-> (1 2 6 24 120 720 5040 40320)

Needless to say, the call to recurse does not have to reside in
the same function as the corresponding recur. Can you implement
anonymous recursion so elegantly with lexical binding?



Are there no problems caused by dynamic binding?
You mean the funarg problem, or problems that arise when a variable
might be bound to itself? For that reason we have a convention in
PicoLisp to use transient symbols (instead
of internal symbols) or private internal symbols


    


  1. for all parameters and locals, when functional arguments or executable lists
are passed through the current dynamic bindings


  2. for a parameter or local, when that symbol might possibly be (directly or
indirectly) bound to itself, and the bound symbol's value is accessed in the
dynamic context.


This is a form of lexical scoping - though we still have dynamic
binding - of symbols, similar to the static keyword in
C.


In fact, these problems are a real threat, and may lead to mysterious bugs
(other Lisps have similar problems, e.g. with symbol capture in macros). They
can be avoided, however, when the above conventions are observed. As an example,
consider a function which doubles the value in a variable:


(de double (Var)
   (set Var (* 2 (val Var))) )

This works fine, as long as we call it as (double 'X), but will
break if we call it as (double 'Var). Therefore, the correct
implementation of double should be:


(de double ("Var")
   (set "Var" (* 2 (val "Var"))) )

If double is defined that way in a separate source file, then
the symbol Var is locked into a private lexical context and
cannot conflict with other symbols.


Admittedly, there are two disadvantages with this solution:


    


  1. The rules for when to use transient or private symbols are a bit
complicated. Though it is safe to use them even when not necessary, it will take
more space then and be more difficult to debug.


  2. The string-like syntax of transient symbols as variables may look strange to
alumni of other languages. With private symbols this is not an issue.




Fortunately, these pitfalls do not occur so very often, and seem more likely in
utilities than in production code, so that they can be easily encapsulated.



But with dynamic binding I cannot implement closures!
This is not true. Closures are a matter of scope, not of binding.


For a closure it is necessary to build and maintain a separate environment.
In a system with lexical bindings, this has to be done at each function
call, and for compiled code it is the most efficient strategy anyway, because it
is done once by the compiler, and can then be accessed as stack frames at
runtime.


For an interpreter, however, this is quite an overhead. So it should not be
done automatically at each and every function invocation, but only if needed.


You have several options in PicoLisp. For simple cases, you can take
advantage of the static scope of transient
or private symbols. For the general case, PicoLisp has built-in functions like
bind or job, which dynamically manage statically scoped
environments.


Environments are first-class objects in PicoLisp, more flexible than
hard-coded closures, because they can be created and manipulated independently
from the code.


As an example, consider a currying function:


(de curry Args
   (list (car Args)
      (list 'list
         (lit (cadr Args))
         (list 'cons ''job
            (list 'cons
               (list 'lit (list 'env (lit (car Args))))
               (lit (cddr Args)) ) ) ) ) )

When called, it returns a function-building function which may be applied to
some argument:


: ((curry (X) (N) (* X N)) 3)
-> ((N) (job '((X . 3)) (* X N)))

or used as:


: (((curry (X) (N) (* X N)) 3) 4)
-> 12

In other cases, you are free to choose a shorter and faster solution. If (as
in the example above) the curried argument is known to be immutable:


(de curry Args
   (list
      (cadr Args)
      (list 'fill
         (lit (cons (car Args) (cddr Args)))
         (lit (cadr Args)) ) ) )

Then the function built above will just be:


: ((curry (X) (N) (* X N)) 3)
-> ((X) (* X 3))

In that case, the "environment build-up" is reduced by a simple (lexical)
constant substitution with zero runtime overhead.


Note that the actual curry
function is simpler and more pragmatic. It combines both strategies (to use
job, or to substitute), deciding at runtime what kind of function
to build.



Do you have macros?
Yes, there is a macro mechanism in PicoLisp, to build and immediately execute
a list of expressions. But it is seldom used. Macros are a kludge. Most things
where you need macros in other Lisps are directly expressible as functions in
PicoLisp, which (as opposed to macros) can be applied, passed around, and
debugged.


For example, Common Lisp's DO* macro, written as a function:


(de do* "Args"
   (bind (mapcar car (car "Args"))
      (for "A" (car "Args")
         (set (car "A") (eval (cadr "A"))) )
      (until (eval (caadr "Args"))
         (run (cddr "Args"))
         (for "A" (car "Args")
            (and (cddr "A") (set (car "A") (run @))) ) )
      (run (cdadr "Args")) ) )

Can I run threads?
This is not possible. Threads share memory and other resources (as opposed to
processes, which are better isolated from each other). Each thread has its own
stack for private data, but PicoLisp uses dynamic binding, where the stack holds
the saved values instead of the current values of symbols. As a
result, each running thread would overwrite the symbol bindings of other
threads.


Instead, PicoLisp uses separate processes - and interprocess communication -
for parallel execution, or coroutines as a
kind of cooperative threads running a controlled way and doing all
necessary housekeeping.


Another advantage of separate processes over threads: They can be distributed
across multiple machines, and therefore scale better.



Why are there no strings?
Because PicoLisp has something better: Transient symbols. They look and behave like
strings in any respect, but are nevertheless true symbols, with a value and a
property list.


This leads to interesting opportunities. The value, for example, can point to
other data that represent the string's translation. This is used extensively for
localization. When a program calls


   (prinl "Good morning!")

then changing the value of the symbol "Good morning!" to its
translation will change the program's output at runtime.


Transient symbols are also quite memory-conservative. As they are stored in
normal heap cells, no additional overhead for memory management is induced. The
cell holds the symbol's value in its CDR, and the tail in its CAR. If the string
is not longer than 7 bytes, it fits completely into the tail, and a single cell
suffices. Up to 15 bytes take up two cells, 23 bytes three etc., so that long
strings are not very efficient (needing twice the memory on the average), but
this disadvantage is made up by simplicity and uniformity. And lots of extremely
long strings are not the common case, as they are split up anyway during
processing, and stored as plain byte sequences in external files and databases.


Because transient symbols are temporarily interned (while loading the current source file), they are
shared within the same source and occupy that space only once, even if they
occur multiple times within the same file.



What about arrays?
PicoLisp has no array or vector data type. Instead, lists must be used for
any type of sequentially arranged data.


We believe that arrays are usually overrated. Textbook wisdom tells that they
have a constant access time O(1) when the index is known. Many other operations
like splits or insertions are expensive. Access with a known (numeric) index is
not typical for Lisp, and even then the advantage of an array is significant
only if it is relatively long. Holding lots of data in long arrays, however,
smells quite like a program design error, and we suspect that often more
structured representations like trees or interconnected objects would be better.


In practice, most arrays are rather short, or the program can be designed in
such a way that long arrays (or at least an indexed access) are avoided.


Using lists, on the other hand, has advantages. We have so many concerted
functions that uniformly operate on lists. There is no separate data type that
has to be handled by the interpreter, garbage collector, I/O, database and so
on. Lists can be made circular. And lists don't cause memory fragmentation.


Still, if there is really a need to access large amounts of data with a
numeric index, enum can be used. It
emulates a multidimensional - possibly sparse - array. It takes roughly 1.5 the
space a linear list would require, and is very fast.



How to do floating point arithmetic?
PicoLisp does not support real floating point numbers. You can do all kinds
of floating point calculations by calling existing library functions via
native, inline-C code, and/or by
loading the "@lib/math.l" library.


But PicoLisp has something even (arguably) better: Scaled fixpoint numbers, with unlimited precision.


The reasons for this design decision are manifold. Floating point numbers
smack of imperfection, they don't give "exact" results, have limited precision
and range, and require an extra data type. It is hard to understand what really
goes on (How many digits of precision do we have today? Are perhaps 10-byte
floats used for intermediate results? How does rounding behave?).


For fixpoint support, the system must handle just integer arithmetic, I/O and
string conversions. The rest is under programmer's control and responsibility
(the essence of PicoLisp).


Carefully scaled fixpoint calculations can do anything floating point can do.



What happens when I locally bind a symbol which has a function definition?
That's not a good idea. The next time that function gets executed within the
dynamic context the program may crash. Therefore we have a convention to use an
upper case first letter for locally bound symbols:


(de findCar (Car List)
   (when (member Car (cdr List))
      (list Car (car List)) ) )



;-)



Would it make sense to build PicoLisp in hardware?
At least it should be interesting. It would be a machine executing list
(tree) structures instead of linear instruction sequences. "Instruction
prefetch" would look down the CAR- and CDR-chains, and perhaps need only a
single cache for both data and instructions.


Primitive functions like set, val, if
and while, which are written in C or assembly language
now, would be implemented in microcode. Plus a few I/O functions for hardware
access. EVAL itself would be a microcode subroutine.


Only a single heap and a single stack is needed. They grow towards each
other, and cause garbage collection if they get too close. Heap compaction is
trivial due to the single cell size.


There would be no assembly-language. The lowest level (above the hardware and
microcode levels) are s-expressions: The machine language is Lisp.



I get a segfault if I ...
It is easy to produce a segfault in PicoLisp. Just set a symbol to a value
which is not a function, and call it:


: (setq foo 1)
-> 1
: (foo)
Segmentation fault



There is another example in the Evaluation section of the reference manual.


PicoLisp is a pragmatic language. It doesn't check at runtime for all
possible error conditions which won't occur during normal usage. Such errors are
usually detected quickly at the first test run, and checking for them after that
would just produce runtime overhead.


Catching the segmentation violation and bus fault signals is also not a good
idea, because the Lisp heap is most probably be damaged afterwards, possibly
creating further havoc if execution continues.


It is recommended to inspect the code periodically with lint. It will detect many potential errors.
And, most of these errors are avoided by following the PicoLisp naming conventions.



Where can I ask questions?
The best place is the PicoLisp Mailing
List (see also The Mail
Archive), or the IRC #picolisp
channel on FreeNode.net.





================================================
FILE: doc/httpGate.html
================================================






The 'httpGate' Proxy Server



mattias@inogu.se


The 'httpGate' Proxy Server
(c) Software Lab. Mattias Sundblad


This document describes the httpGate utility which is included
in the PicoLisp distribution.


For basic information about the PicoLisp system please look at the PicoLisp Reference and the PicoLisp
Tutorial.


Purpose
httpGate is a central element of the PicoLisp application server
architecture. Its purpose is to perform the following tasks:


    

  • Provide a single application entry port (e.g. 80 or 443).

  • Allow PicoLisp applications to run as non-root.

  • Start application servers on demand.

  • Handle HTTPS/SSL communication.

Basic functionality
A HTTP request to port 80, respectively 443, of the form


   http[s]://server.org/12345/path/file

is forwarded to a server on localhost listening on port 12345, to ask for the
resource "path/file".


If httpGate was started with a config file, and that file contains an entry
for "app", then also the following request is accepted:


   http[s]://server.org/app/path/file

In that case, the "app" server process is started automatically (if it is not
already running) listening on port 12345, and the request is forwarded as above.


Only requests to ports >= 1024 will be forwarded. The main httpGate
process then forks two child processes, one for each direction. These child
processes terminate automatically if the connection is idle for more than 7
minutes.


Running httpGate
The simplest way to run httpGate is to start it with an explicit port
argument:


   bin/httpGate 80 8080
   bin/httpGate 443 8080 pem/www.domain.key,pem/domain.crt

When started in this way, httpGate forwards requests from port 80 and 443
respectively to a PicoLisp application on port 8080. This form has a drawback
though, since it only allows for a single application to be handled. Usually,
there are many PicoLisp applications running on the same machine, and we need
httpGate to forward requests to all of them.


To handle several applications, start httpGate with a "names" config file:


      bin/httpGate 80 names
      bin/httpGate 443 names pem/www.domain.key,pem/domain.crt

httpGate needs to be started as root, but application servers should run
under normal user accounts. The easiest way to start httpGate automatically is
to add lines like the ones above to '/etc/rc.local'.


Configuring httpGate
The "names" config file
The "names" config file contains one line per application server. Each line
holds six whitespace separated tokens, for example:


   app 12345 tom /home/tom log/app ./pil app/main.l lib/app.l -main -go -wait

    

  1. "app" is the name of the application, and the key to this line.

  2. "12345" is the port where this server should listen at.

  3. "tom" is the user under whose ID the server should run.

  4. "/home/tom" is the working directory where the server should start.

  5. "log/app" is a log file to redirect stdout/stderr to.

  6. The rest of the line "./pil app/main.l ..." is the command to start the application.

Empty lines, and lines starting with a "#", are ignored. If the key in a
config file record is the special name "@", then it denotes the default
application for this machine. URLs without name will be forwarded to that port.
If the key contains a slash followed by a string (e.g. "app/foo") then this
string is inserted in front of URLs.


Optional tokens (e.g. log files) or empty arguments to the commands must be
written as single caret (^) characters to denote empty strings. Double or single
quotes are not parsed.


If the port is zero, then a single additional token is expected which should
denote an URL to redirect the request to:


   app 0 https://domain/foo/bar



This will cause httpGate to respnd with "302 Found" and "Location:
https://domain/foo/bar".


Balanced names file
If the config file contains many (hundreds or thousands) entries, then it is
recommended to sort it with the 'balance' utility. This may greatly accelerate
name (key) lookup at runtime. For that, put the above config lines into a file
"config". The tool 'balance' can be built - together with httpGate - with


   (cd src; make tools gate)

The following command will create a balanced "names" file:


   cat config | bin/balance -sort > names

The "void" file
If the local application server cannot be connected on the requested port
(typically because a session timed out), and a file with the name "void" exists
in the current working directory (token 4 in the config line), then the contents
of that file (normally HTML) are sent as response to the client.


Reloading the configuration
When the config file is modified, it can be reloaded by sending SIGHUP to all
running top-level httpGate processes:


   $ sudo pkill -HUP -P1 httpGate

Another possibility is to restart httpGate(s). This is not a problem, and can
be done also while the server is in production.


Just kill the top level httpGate parent process. This is not harmful, because
existing user sessions are handled by pairs of child processes, which continue
to run (until they terminate normally) even if their parent is stopped. Note
that this is different from PicoLisp DB applications, where the parent should
*never* be hard-stopped (eg. with 'kill -9 <pid>') while child processes
are running ('kill <pid>' is OK though, because the parent takes care of
stopping the children).


An example for stopping and restarting a running httpGate is:


   (let L
      # Build list of all httpGate parents (i.e. on 80 and 443)
      (make
         (in '("sudo" "pgrep" "-P1" "httpGate")
            (while (read)
               (link @) ) ) )
      # Stop them
      (for P L
         (call "sudo" "kill" P) )
      # Wait until all are gone
      (while (find '((P) (kill P 0)) L)
         (wait 200) )
      # Start new
      (call "sudo" "bin/httpGate" 80 "names")
      (call "sudo" "bin/httpGate" 443 "names" "pem/...") )

Keep-alive and retirement
Applications should call


   (retire 20)

before they call 'server'. This causes the parent server process to terminate
automatically 20 minutes after the last child process (user session) terminated.
It will be started by httpGate again on demand. User sessions in turn terminate
automatically after 5 minutes (if nobody logged in) or 1 hour (if a user is
logged in), unless JavaScript is enabled in the client browser and the
application calls


   (<ping> 7)

in its main 'action' function. In that case, the user session will not
terminate until the user closes the last window or tab to this application.





================================================
FILE: doc/man.html
================================================
Content-type: text/html; charset=UTF-8


Man page of PICOLISP


PICOLISP

Section: User Commands (1)
Updated: 
IndexReturn to Main Contents
 
NAME


pil, picolisp - a fast, lightweight Lisp interpreter
 
SYNOPSIS
pil

[arguments ...] [-] [arguments ...] [+]

picolisp

[arguments ...] [-] [arguments ...] [+]
 
DESCRIPTION
PicoLisp

is a Lisp interpreter with a small memory footprint, yet relatively high
execution speed. It combines an elegant and powerful language with built-in
database functionality.



pil

is the startup front-end for the interpreter. It takes care of starting the
binary base system and loading a useful runtime environment.



picolisp

is just the bare interpreter binary. It is usually called in stand-alone
scripts, using the she-bang notation in the first line, passing the minimal
environment in
lib.l

and loading additional files as needed:





#!/usr/bin/picolisp /usr/lib/picolisp/lib.l


(load "@ext.l" "myfiles/lib.l" "myfiles/foo.l")


(do ... something ...)


(bye)

 
INVOCATION
PicoLisp

has no pre-defined command line flags; applications are free to define their
own. Any built-in or user-level Lisp function can be invoked from the command
line by prefixing it with a hyphen. Examples for built-in functions useful in
this context are
version

(print the version number) or
bye

(exit the interpreter). Therefore, a minimal call to print the version number
and then immediately exit the interpreter would be:





$ pil -version -bye



Any other argument (not starting with a hyphen) should be the name of a file to
be loaded. If the first character of a path or file name is an at-mark, it
will be substituted with the path to the installation directory.



All arguments are evaluated from left to right, then an interactive
read-eval-print

loop is entered (with a colon as prompt).



A single hyphen stops the evaluation of the rest of the command line, so that
the remaining arguments may be processed under program control.



If the very last command line argument is a single plus character, debugging
mode is switched on at interpreter startup, before evaluating any of the command
line arguments. A minimal interactive session is started with:





$ pil +



Here you can access the reference manual (expects the shell variable BROWSER to
be set, defaults to "w3m")





: (doc)



and the online documentation for most functions,





: (doc 'vi)



or directly inspect their sources:





: (vi 'doc)



The interpreter can be terminated with





: (bye)



or by typing Ctrl-D.
 

FILES


Runtime files are maintained in the ~/.pil directory:



~/.pil/tmp/<pid>/

Process-local temporary directories

~/.pil/rc

Loaded after interpreter startup

~/.pil/viprc

Loaded by the Vip editor

 
BUGS
PicoLisp

doesn't try to protect you from every possible programming error ("You asked for
it, you got it").
 
AUTHOR


Alexander Burger <abu@software-lab.de>
 
RESOURCES
Home page:http://home.picolisp.com
Download:http://www.software-lab.de/down.html



 
Index


NAME


SYNOPSIS


DESCRIPTION


INVOCATION


FILES


BUGS


AUTHOR


RESOURCES



This document was created by
man2html,
using the manual pages.

Time: 08:01:21 GMT, March 29, 2021



================================================
FILE: doc/microTemplates
================================================
         Micro-Templates

* Each template file in the @lib/xhtml/ directory applies to one type of
  component in the @lib/xhtml.l functions.

* The template files are line oriented. One micro-template per line.

* A micro-template can be continued on the following line(s) by
  indenting these lines with space(s).

* Each line has a defined meaning. Except for indented lines, no lines
  can be added or removed.

* A micro-template may contain either variables or expressions enclosed
  by "¦" (broken bar character, hex "00A6").

* An empty line is denoted by "<>".

* "~" is replaced at runtime with the session ID.

* At program start, all templates from @lib/xhtml/ are loaded.

* The application may override one or more files in a local directory,
  and call 'xhtml' with that path. Also more than once.

* Available templates:

   html
      1. DOCTYPE
      2. HTML start
      3. HEAD
      4. BODY
      5. HTML end

   table
      1. Table start
      2. Caption
      3. Header row start
      4. Header row entry
      5. Header row end
      6. Data row start
      7. Data row entry
      8. Data row end
      9. Table end

   grid
      1. Grid start
      2. Grid row start
      3. Grid row entry
      4. Grid row end
      5. Grid end

   layout
      Variable number of lines, one per code block

   menu
      1. Menu start
      2. Submenu start
      3. Plain HTML
      4. Disabled link
      5. Enabled link
      6. Enabled active link
      7. Closed submenu
      8. Open submenu start
      9. Open submenu end
      10. Submenu end
      11. Menu end

   tab
      1. TABLE start
      2. Disabled entry
      3. Enabled entry
      4. TABLE end

   input
      1. (Non-text) Input element

   field
      1. Text input element

   area
      1. TEXTAREA start
      2. TEXTAREA end

   select
      1. SELECT start
      2. OPTION
      3. SELECT end

   submit
      1. Submit input element


================================================
FILE: doc/native.html
================================================
Native C Callsabu@software-lab.de
Native C Calls
(c) Software Lab. Alexander Burger


This document describes how to call C functions in shared object files
(libraries) from PicoLisp, using the built-in native function - possibly with the help of
the struct and lisp functions.


Overview

native calls a C function in a
shared library. It tries to


    

  1. find a library by name

  2. find a function by name in the library

  3. convert the function's argument(s) from Lisp to C data structures

  4. call the function's C code

  5. convert the function's return value(s) from C to Lisp data structures

The direct return value of native is the Lisp representation of
the C function's return value. Further values, returned by reference from the C
function, are available in Lisp variables (symbol values).


struct is a helper function,
which can be used to manipulate C data structures in memory. It may take a
scalar (a numeric representation of a C value) to convert it to a Lisp item, or
(more typically) a pointer to a memory area to build and extract data
structures. lisp allows you to install callback functions, callable
from C code, written in Lisp.


%@ is a convenience function,
simplifying the most common use case of native.


In combination, these functions can interface PicoLisp to almost any C
function.


The above steps are fully dynamic; native doesn't have (and
doesn't require) a priori knowledge about the library, the function or the
involved data. No need to write any glue code, interfaces or include files. All
functions can even be called interactively from the REPL.



Syntax
The arguments to native are


    

  1. a library

  2. a function

  3. a return value specification

  4. optional arguments

The simplest form is a call to a function without return value and without
arguments. If we assume a library "lib.so", containing a function with the
prototype


void fun(void);

then we can call it as


(native "lib.so" "fun")

Libraries
The first argument to native specifies the library. It is either
the name of a library (a symbol), or the handle of a previously
found library (a number).


As a special case, a transient symbol "@" can be passed for the
library name. It then refers to the current main program (instead of an external
library), and can be used for standard functions like "malloc" or
"free".
Because this is needed so often,


(%@ "fun" ...)

can be used instead of


(native "@" "fun" ...)

native uses dlopen(3) internally to find and open
the library, and to obtain the handle. If the name contains a slash ('/'), then
it is interpreted as a (relative or absolute) pathname. Otherwise, the dynamic
linker searches for the library according to the system's environment and
directories. See the man page of dlopen(3) for further details.


If called with a symbolic argument, native automatically caches
the handle of the found library in the value of that symbol. The most natural
way is to pass the library name as a transient
symbol ("lib.so" above): The initial value of a transient symbol is
that symbol itself, so that native receives the library name upon
the first call. After successfully finding and opening the library,
native stores the handle of that library in the value of the passed
symbol ("lib.so"). As native evaluates its arguments
in the normal way, subsequent calls within the same transient scope will receive
the numeric value (the handle), and don't need to open and search the library
again.



Functions
The same rules applies to the second argument, the function. When called with
a symbol, native stores the function handle in its value, so that
subsequent calls evaluate to that handle, and native can directly
jump to the function.


native uses dlsym(3) internally to obtain the
function pointer. See the man page of dlsym(3) for further details.


In most cases a program will call more than one function from a given
library. If we keep the code within the same transient scope (i.e. in the same
source file), each library will be opened - and each function searched - only
once.


(native "lib.so" "fun1")
(native "lib.so" "fun2")
(native "lib.so" "fun3")

After "fun1" was called, "lib.so" will be open, and
won't be re-opened for "fun2" and "fun3". Consider
the definition of helper functions:


(de fun1 ()
   (native "lib.so" "fun1") )

(de fun2 ()
   (native "lib.so" "fun2") )

(de fun3 ()
   (native "lib.so" "fun3") )

After any one of fun1, fun2 or fun3
was called, the symbol "lib.so" will hold the library handle. And
each function "fun1", "fun2" and "fun3"
will be searched only when called the first time.


Note that the function handle points to a structure in memory, which is
automatically allocated. This implies that a memory leak may occur if the
transient symbol holding the function handle goes out of scope (e.g. by repeated
(re)loading the library after
executing its functions).


Warning: It should be avoided to put more than one library into a single
transient scope if there is a chance that two different functions with the same
name will be called in two different libraries. Because of the function handle
caching, the second call would otherwise (wrongly) go to the first function.



Return Value
The (optional) third argument to native specifies the return
value. A C function can return many types of values, like integer or floating
point numbers, string pointers, or pointers to structures which in turn consist
of those types, and even other structures or pointers to structures.
native tries to cover most of them.


As described in the result specification,
the third argument should consist of a pattern which tells native
how to extract the proper value.



Primitive Types
In the simplest case, the result specification is NIL like in
the examples so far. This means that either the C function returns
void, or that we are not interested in the value. The return value
of native will be NIL in that case.


If the result specification is one of the symbols B,
I or N, an integer number is returned, by interpreting
the result as a char (8 bit unsigned byte), int (32
bit signed integer), or long number (64 bit signed integer),
respectively. Other (signed or unsigned numbers, and of different sizes) can be
produced from these types with logical and arithmetic operations if necessary.


If the result specification is the symbol C, the result is
interpreted as a 16 bit number, and a single-char transient symbol (string) is
returned.


A specification of S tells native to interpret the
result as a pointer to a C string (null terminated), and to return a transient
symbol (string).


If the result specification is a number, it will be used as a scale to
convert a returned double (if the number is positive) or
float (if the number is negative) to a scaled fixpoint number.


Examples for function calls, with their corresponding C prototypes:


(native "lib.so" "fun" 'I)             # int fun(void);
(native "lib.so" "fun" 'N)             # long fun(void);
(native "lib.so" "fun" 'P)             # void *fun(void);
(native "lib.so" "fun" 'S)             # char *fun(void);
(native "lib.so" "fun" 1.0)            # double fun(void);

Arrays and Structures
If the result specification is a list, it means that the C function returned
a pointer to an array, or an arbitrary memory structure. The specification list
should then consist of either the above primitive specifications (symbols or
numbers), or of cons pairs of a primitive specification and a repeat count, to
denote arrays of the given type.


Examples for function calls, with their corresponding pseudo C prototypes:


(native "lib.so" "fun" '(I . 8))       # int *fun(void);  // 8 integers
(native "lib.so" "fun" '(B . 16))      # unsigned char *fun(void);  // 16 bytes

(native "lib.so" "fun" '(I I))         # struct {int i; int j;} *fun(void);
(native "lib.so" "fun" '(I . 4))       # struct {int i[4];} *fun(void);

(native "lib.so" "fun" '(I (B . 4)))   # struct {
                                       #    int i;
                                       #    unsigned char c[4];
                                       # } *fun(void);

(native "lib.so" "fun"                 # struct {
   '(((B . 4) I) (S . 12) (N . 8)) )   #    struct {unsigned char c[4]; int i;}
                                       #    char *names[12];
                                       #    long num[8];
                                       # } *fun(void);

If a returned structure has an element which is a pointer to some
other structure (i.e. not an embedded structure like in the last example above),
this pointer must be first obtained with a N pattern, which can
then be passed to struct for further
extraction.



Arguments
The (optional) fourth and following arguments to native specify
the arguments to the C function.



Primitive Types
Integer arguments (up to 64 bits, signed or unsigned char,
short, int or long) can be passed as they
are: As numbers.


(native "lib.so" "fun" NIL 123)        # void fun(int);
(native "lib.so" "fun" NIL 1 2 3)      # void fun(int, long, short);

String arguments can be specified as symbols. native allocates
memory for each string on the stack, passes the pointer to the C function, and
cleans up the stack when done.


(native "lib.so" "fun" NIL "abc")      # void fun(char*);
(native "lib.so" "fun" NIL 3 "def")    # void fun(int, char*);

Note that the allocated string memory is released after the return
value is extracted. This allows a C function to return the argument string
pointer, perhaps after modifying the data in-place, and receive the new string
as the return value (with the S specification).


(native "lib.so" "fun" 'S "abc")       # char *fun(char*);

Also note that specifying NIL as an argument passes an empty
string ("", which also reads as NIL in PicoLisp) to the C function.
Physically, this is a pointer to a NULL-byte, and is not a NULL-pointer.
Be sure to pass 0 (the number zero) if a NULL-pointer is desired.


Floating point arguments are specified as cons pairs, where the value is in
the CAR, and the CDR holds the fixpoint scale. If the scale is positive, the
number is passed as a double, otherwise as a float.


(native "lib.so" "fun" NIL             # void fun(double, float);
   (12.3 . 1.0) (4.56 . -1.0) )

Arrays and Structures
Composite arguments are specified as nested list structures.
native allocates memory for each array or structure (with
malloc(3)), passes the pointer to the C function, and releases the
memory (with free(3)) when done.


This implies that such an argument can be both an input and an output value
to a C function (pass by reference).


The CAR of the argument specification can be NIL (then it is an
input-only argument). Otherwise, it should be a variable which receives the
returned structure data.


The CADR of the argument specification must be a cons pair with the total
size of the structure in its CAR. The CDR is ignored for input-only arguments,
and should contain a result specification for
the output value to be stored in the variable.


For example, a minimal case is a function that takes an integer reference,
and stores the number '123' in that location:


void fun(int *i) {
   *i = 123;
}

We call native with a variable X in the CAR of the
argument specification, a size of 4 (i.e. sizeof(int)), and
I for the result specification. The stored value is then available
in the variable X:


: (native "lib.so" "fun" NIL '(X (4 . I)))
-> NIL
: X
-> 123

The rest (CDDR) of the argument specification may contain initialization
data, if the C function expects input values in the structure. It should be a
list of initialization items, optionally with a
fill-byte value in the CDR of the last cell.


If there are no initialization items and just the final fill-byte,
then the whole buffer is filled with that byte. For example, to pass a buffer of
20 bytes, initialized to zero:


: (native "lib.so" "fun" NIL '(NIL (20) . 0))

A buffer of 20 bytes, with the first 4 bytes initialized to 1, 2, 3, and 4,
and the rest filled with zero:


: (native "lib.so" "fun" NIL '(NIL (20) 1 2 3 4 . 0))

and the same, where the buffer contents are returned as a list of bytes in
the variable X:


: (native "lib.so" "fun" NIL '(X (20 B . 20) 1 2 3 4 . 0))

For a more extensive example, let's use the following definitions:


typedef struct value {
   int x, y;
   double a, b, c;
   int z;
   char nm[4];
} value;

void fun(value *val) {
   printf("%d %d\n", val->x, val->y);
   val->x = 3;
   val->y = 4;
   strcpy(val->nm, "OK");
}

We call this function with a structure of 40 bytes, requesting the returned
data in V, with two integers (I . 2), three doubles
(100 . 3) with a scale of 2 (1.0 = 100), another integer
I and four characters (C . 4). If the structure gets
initialized with two integers 7 and 6, three doubles 0.11, 0.22 and 0.33, and
another integer 5 while the rest of the 40 bytes is cleared to zero


: (native "lib.so" "fun" NIL
   '(V (40 (I . 2) (100 . 3) I (C . 4)) -7 -6 (100 11 22 33) -5 . 0) )

then it will print the integers 7 and 6, and V will contain the
returned list


((3 4) (11 22 33) 5 ("O" "K" NIL NIL))

i.e. the original integer values 7 and 6 replaced with 3 and 4.


Note that the allocated structure memory is released after the return
value is extracted. This allows a C function to return the argument structure
pointer, perhaps after modifying the data in-place, and receive the new
structure as the return value - instead of (or even in addition to) to the
direct return via the argument reference.



Memory Management
The preceding Arguments section mentions that
native implicitly allocates and releases memory for strings, arrays
and structures.


Technically, this mimics automatic variables in C.


For a simple example, let's assume that we want to call read(2)
directly, to fetch a 4-byte integer from a given file descriptor. This could be
done with the following C function:


int read4bytes(int fd) {
   char buf[4];

   read(fd, buf, 4);
   return *(int*)buf;
}

buf is an automatic variable, allocated on the stack, which
disappears when the function returns. A corresponding native call
would be:


(%@ "read" 'I Fd '(Buf (4 . I)) 4)

The structure argument (Buf (4 . I)) says that a space of 4
bytes should be allocated and passed to read, then an integer
I returned in the variable Buf (the return value of
native itself is the integer returned by read). The
memory space is released after that.


(Note that we can call %@ here, as read resides in
the main program.)


Instead of a single integer, we might want a list of four bytes to be
returned from native:


(%@ "read" 'I Fd '(Buf (4 B . 4)) 4)

The difference is that we wrote (B . 4) (a list of 4 bytes)
instead of I (a single integer) for the result specification (see the Arrays and Structures section).


Let's see what happens if we extend this example. We'll write the four bytes
to another file descriptor, after reading them from the first one:


void copy4bytes(int fd1, int fd2) {
   char buf[4];

   read(fd1, buf, 4);
   write(fd2, buf, 4);
}

Again, buf is an automatic variable. It is passed to both
read and write. A direct translation would be:


(%@ "read" 'I Fd '(Buf (4 B . 4)) 4)
(%@ "write" 'I Fd2 (cons NIL (4) Buf) 4)

This works as expected. read returns a list of four bytes in
Buf. The call to cons builds the structure


(NIL (4) 1 2 3 4)

i.e. no return variable, a four-byte memory area, filled with the four bytes
(assuming that read returned 1, 2, 3 and 4). Then this structure is
passed to write.


But: This solution induces quite some overhead. The four-byte buffer is
allocated before the call to read and released after that, then
allocated and released again for write. Also, the bytes are
converted to a list to be stored in Buf, then that list is extended
for the structure argument to write, and converted again back to
the raw byte array. The data in the list itself are never used.


If the above operation is to be used more than once, it is better to allocate
the buffer manually, use it for both reading and writing, and then release it.
This also avoids all intermediate list conversions.


(let Buf (%@ "malloc" 'P 4)  # Allocate memory
   (%@ "read" 'I Fd Buf 4)   # (Possibly repeat this several times)
   (%@ "write" 'I Fd2 Buf 4)
   (%@ "free" NIL Buf) )     # Release memory

To allocate such a buffer locally on the stack (just like a C function would
do), buf can be used. Equivalent to the
above is:


(buf Buf 4  # Allocate local memory
   (%@ "read" 'I Fd Buf 4)
   (%@ "write" 'I Fd2 Buf 4) )

Fast Fourier Transform
For a more typical example, we might call the Fast Fourier Transform using
the library from the FFTW package. With the
example code for calculating Complex One-Dimensional DFTs:


#include <fftw3.h>
...
{
   fftw_complex *in, *out;
   fftw_plan p;
   ...
   in = (fftw_complex*) fftw_malloc(sizeof(fftw_complex) * N);
   out = (fftw_complex*) fftw_malloc(sizeof(fftw_complex) * N);
   p = fftw_plan_dft_1d(N, in, out, FFTW_FORWARD, FFTW_ESTIMATE);
   ...
   fftw_execute(p); /* repeat as needed */
   ...
   fftw_destroy_plan(p);
   fftw_free(in); fftw_free(out);
}

we can build the following equivalent:


(load "@lib/math.l")

(de FFTW_FORWARD . -1)
(de FFTW_ESTIMATE . 64)

(de fft (Lst)
   (let
      (Len (length Lst)
         In (native "libfftw3.so" "fftw_malloc" 'P (* Len 16))
         Out (native "libfftw3.so" "fftw_malloc" 'P (* Len 16))
         P (native "libfftw3.so" "fftw_plan_dft_1d" 'N
            Len In Out FFTW_FORWARD FFTW_ESTIMATE ) )
      (struct In NIL (cons 1.0 (apply append Lst)))
      (native "libfftw3.so" "fftw_execute" NIL P)
      (prog1
         (struct Out (make (do Len (link (1.0 . 2)))))
         (native "libfftw3.so" "fftw_destroy_plan" NIL P)
         (native "libfftw3.so" "fftw_free" NIL Out)
         (native "libfftw3.so" "fftw_free" NIL In) ) ) )

This assumes that the argument list Lst is passed as a list
of complex numbers, each as a list of two numbers for the real and imaginary
part, like


(fft '((1.0 0) (1.0 0) (1.0 0) (1.0 0) (0 0) (0 0) (0 0) (0 0)))

The above translation to Lisp is quite straightforward. After the two buffers
are allocated, and a plan is created, struct is called to store the argument list
in the In structure as a list of double numbers (according to the
1.0 initialization item). Then
fftw_execute is called, and struct is called again to
retrieve the result from Out and return it from fft
via the prog1. Finally, all memory is
released.



Constant Data
If such allocated data (strings, arrays or structures passed to
native) are constant during the lifetime of a program, it makes
sense to allocate them only once, before their first use. A typical candidate is
the format string of a printf call. Consider a function which
prints a floating point number in scientific notation:


(load "@lib/math.l")

: (de prf (Flt)
   (%@ "printf" NIL "%e\n" (cons Flt 1.0)) )
-> prf

: (prf (exp 12.3))
2.196960e+05

As we know that the format string "%e\n" will be converted from
a Lisp symbol to a C string on each call to prf, we might as well
perform a little optimization and delegate this conversion to the program load
time:


: (de prf (Flt)
   (%@ "printf" NIL `(%@ "strdup" 'P "%e\n") (cons Flt 1.0)) )
-> prf

: (prf (exp 12.3))
2.196960e+05

If we look at the prf function, we see that it now contains the
pointer to the allocated string memory:


: (pp 'prf)
(de prf (Flt)
   (%@ "printf" NIL 24662032 (cons Flt 1000000)) )
-> prf

This pointer will be used by printf directly, without any
further conversion or memory management.



Callbacks
Sometimes it is necessary to do the reverse: Call Lisp code from C code.


This mechanism uses the Lisp-level function lisp. No C source code access is
required.


lisp returns a function pointer, which can be passed to
C functions via native. When this function pointer is
dereferenced and called from the C code, the corresponding Lisp function
is invoked. Only five numeric arguments and a numeric return value can
be used, and other data types must be handled by the Lisp function with
struct and memory management
operations.


Callbacks are often used in user interface libraries, to handle key-, mouse-
and other events. Examples can be found in "@lib/openGl.l". The
following function mouseFunc takes a Lisp function, installs it
under the tag mouseFunc (any other tag would be all right too) as a
callback, and passes the resulting function pointer to the OpenGL
glutMouseFunc() function, to set it as a callback for the current
window:


(de mouseFunc (Fun)
   (native `*GlutLib "glutMouseFunc" NIL (lisp 'mouseFunc Fun)) )

(The global *GlutLib holds the library
"/usr/lib/libglut.so". The backquote (`) is important
here, so that the transient symbol with the library name (and not the global
*GlutLib) is evaluated by native, resulting in the
proper library handle at runtime).


A program using OpenGL may then use mouseFunc to install a
function


(mouseFunc
   '((Btn State X Y)
      (do-something-with Btn State X Y) ) )

so that future clicks into the window will pass the button, state and
coordinates to that function.





================================================
FILE: doc/rc.sample
================================================
# 20nov24 Software Lab. Alexander Burger
# Copy to ~/.pil/rc

(history
   (make
      (skip "#")
      (while (line T) (link @))  # Global history
      (while (read) (eval @))  # Initial commands
      (when (info ".pilrc")  # Local history and commands
         (in @@
            (skip "#")
            (while (line T) (link @))
            (while (read) (eval @)) ) ) ) )

# Initial history
(stack)
(gc 1200) (dbCheck)
(show (; *FormLst 1 2))
(vi (; *FormLst 1 2 *Dbg 1 -1))
(show (; *FormLst 1 2 obj))

# Initial commands
(de x ()
   (load "x.l") )


================================================
FILE: doc/ref.html
================================================






PicoLisp Reference



abu@software-lab.de



Perfection is attained

not when there is nothing left to add

but when there is nothing left to take away.

(Antoine de Saint-Exupéry)




The PicoLisp Reference
(c) Software Lab. Alexander Burger


This document describes the concepts, data types, and kernel functions of the
PicoLisp system.


This is not a Lisp tutorial. For an introduction to Lisp, a
traditional Lisp book like "Lisp" by Winston/Horn (Addison-Wesley 1981) is
recommended. Note, however, that there are significant differences between
PicoLisp and Maclisp (and even greater differences to Common Lisp).


Please take a look at the PicoLisp Tutorial for an
explanation of some aspects of PicoLisp, and scan through the list of Frequently Asked Questions (FAQ).


Introduction
PicoLisp is the result of a language design study, trying to answer the
question "What is a minimal but useful architecture for a virtual machine?".
Because opinions differ about what is meant by "minimal" and "useful", there are
many answers to that question, and people might consider other solutions more
"minimal" or more "useful". But from a practical point of view, PicoLisp has
proven to be a valuable answer to that question.


First of all, PicoLisp is a virtual machine architecture, and then a
programming language. It was designed in a "bottom up" way, and "bottom up" is
also the most natural way to understand and to use it: Form Follows
Function.


PicoLisp has been used in several commercial and research programming
projects since 1988. Its internal structures are simple enough, allowing an
experienced programmer always to fully understand what's going on under the
hood, and its language features, efficiency and extensibility make it suitable
for almost any practical programming task.


In a nutshell, emphasis was put on four design objectives. The PicoLisp
system should be





Simple


The internal data structure should be as simple as possible. Only one single
data structure is used to build all higher level constructs.




Unlimited


There are no limits imposed upon the language due to limitations of the
virtual machine architecture. That is, there is no upper bound in symbol name
length, number digit counts, stack depth, or data structure and buffer sizes,
except for the total memory size of the host machine.




Dynamic


Behavior should be as dynamic as possible ("run"-time vs. "compile"-time).
All decisions are delayed until runtime where possible. This involves matters
like memory management, dynamic symbol binding, and late method binding.




Practical


PicoLisp is not just a toy of theoretical value. It is in use since 1988 in
actual application development, research and production.




The PicoLisp Machine
An important point in the PicoLisp philosophy is the knowledge about the
architecture and data structures of the internal machinery. The high-level
constructs of the programming language directly map to that machinery, making
the whole system both understandable and predictable.


This is similar to assembly language programming, where the programmer has
complete control over the machine.



The Cell
The PicoLisp virtual machine is both simpler and more powerful than most
current (hardware) processors. At the lowest level, it is constructed from a
single data structure called "cell":


         +-----+-----+
         | CAR | CDR |
         +-----+-----+

A cell is a pair of 64-bit machine words, which traditionally are called CAR
and CDR in the Lisp terminology. These words can represent either a numeric
value (scalar) or the address of another cell (pointer). All higher level data
structures are built out of cells.


The type information of higher level data is contained in the pointers to
these data. Assuming the implementation on a byte-addressed physical machine,
and the pointer size being 8 bytes, each cell has a size of 16 bytes. Therefore,
the pointer to a cell must point to a 16-byte boundary (a number which is a
multiple of 16), and its bit-representation will look like:


      xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx0000

(the 'x' 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 four bits to non-zero values. These bits are then used by the
interpreter to determine the data type.


In any case, bit(0) - the least significant of these bits - is reserved as a
mark bit for garbage collection.


Initially, all cells in the memory are unused (free), and linked together to
form a "free list". To create higher level data types at runtime, cells are
taken from that free list, and returned by the garbage collector when they are
no longer needed. All memory management is done via that free list; there are no
additional buffers, string spaces or special memory areas, with two exceptions:


    

  • A certain fixed area of memory is set aside to contain the executable code
and global variables of the interpreter itself, and


  • a standard push down stack for return addresses and temporary storage. Both
are not directly accessible by the programmer.


Data Types
On the virtual machine level, PicoLisp supports


    

  • three base data types: Numbers, Symbols and Cons Pairs (Lists),

  • the three scope variations of symbols: Internal, Transient and External, and

  • the special symbol NIL.

They are all built from the single cell data structure, and all runtime data
cannot consist of any other types than these three.


The following diagram shows the complete data type hierarchy, consisting of
the three base types and the symbol variations:


                       cell
                        |
            +-----------+-----------+
            |           |           |
         Number       Symbol       Pair
                        |
                        |
   +--------+-----------+-----------+
   |        |           |           |
  NIL   Internal    Transient    External

Numbers
A number can represent a signed integral value of arbitrary size. Internally,
numeric values of up to 60 bits are stored in "short" numbers,


      xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxS010



i.e. the value is directly represented in the pointer, and doesn't take any heap
space.


Numbers larger than that are "big" numbers, stored in heap cells. The CARs of
one or more cells hold the number's "digits" (64 bits each), with the least
significant digit first, while the CDRs point to the remaining digits.


         Bignum
         |
         V
      +-----+-----+
      | DIG |  |  |
      +-----+--+--+
               |
               V
            +-----+-----+
            | DIG |  |  |
            +-----+--+--+
                     |
                     V
                  +-----+-----+
                  | DIG | CNT |
                  +-----+-----+



The CDR of the final cell holds the remaining bits in a short number.


The pointer to a big number points into the middle of the CAR, with an offset
of 4 from the cell's start address, and the sign bit in bit(3):


      xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxS100

Thus, a number is recognized by the interpreter when either bit(1) is
non-zero (a short number) or bit(2) is non-zero (a big number).



Symbols
A symbol is more complex than a number. Each symbol has a value, and
optionally a name and an arbitrary number of properties. The CDR of a symbol
cell is also called VAL, and the CAR points to the symbol's tail. As a minimum,
a symbol consists of a single cell, and has no name or properties:


            Symbol
            |
            V
      +-----+-----+
      | '0' | VAL |
      +-----+-----+

That is, the symbol's tail is empty (ZERO, as indicated by
'0').


The pointer to a symbol points to the CDR of the cell, with an offset of 8
bytes from the cell's start address. Therefore, the bit pattern of a symbol will
be:


      xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx1000

Thus, a symbol is recognized by the interpreter when bit(3) is non-zero. (It
should also be understood that both bit(2) and bit(1) must be zero, thus
avoiding confusion with the number types.)


A property is a key-value pair, represented by a cons pair in the symbol's
tail. This is called a "property list". The property list may be terminated by a
number (short or big) representing the symbol's name. In the following example,
a symbol with the name "abcdefghijklmno" has three properties: A
KEY/VAL pair, a cell with only a KEY, and another KEY/VAL pair.


            Symbol
            |
            V
      +-----+-----+                                +----------+---------+
      |  |  | VAL |                                |'hgfedcba'|'onmlkji'|
      +--+--+-----+                                +----------+---------+
         | tail                                       ^
         |                                            |
         V                                            | name
         +-----+-----+     +-----+-----+     +-----+--+--+
         |  |  |  ---+---> | KEY |  ---+---> |  |  |  |  |
         +--+--+-----+     +-----+-----+     +--+--+-----+
            |                                   |
            V                                   V
            +-----+-----+                       +-----+-----+
            | VAL | KEY |                       | VAL | KEY |
            +-----+-----+                       +-----+-----+

Each property in a symbol's tail is either a symbol (like the single KEY
above, then it represents the boolean value T) or a cons pair with
the property key in its CDR and the property value in its CAR. In both cases,
the key should be a symbol, because searches in the property list are performed
using pointer comparisons.


The name of a symbol is stored as a number at the end of the tail. It
contains the characters of the name in UTF-8 encoding, using between one and
seven bytes in a short number, or eight bytes in a bignum cell. The first byte
of the first character, for example, is stored in the lowest 8 bits of the
number.


All symbols have the above structure, but depending on scope and
accessibility there are actually four types of symbols: NIL, internal, transient and external symbols.



NIL
NIL is a special symbol which exists exactly once in the whole
system. It is used


    

  • as an end-of-list marker

  • to represent the empty list

  • to represent the boolean value "false"

  • to represent a string of length zero

  • to represent the absolute minimum

  • to represent end of file

  • to represent standard in/out

  • to represent the value "Not a Number"

  • as the root of all class hierarchies

  • as volatile property key

  • as "no value"

For that, NIL has a special structure:


      NIL:  /
            |
            V
      +-----+-----+-----+-----+
      |'LIN'|  /  |  /  |  /  |
      +-----+-----+-----+-----+

The reason for that structure is NIL's dual nature both as a
symbol and as a list:


    

  • As a symbol, it should give NIL for its VAL, and be without
properties


  • For the empty list, NIL should give NIL both for
its CAR and for its CDR


These requirements are fulfilled by the above structure.



Internal Symbols
Internal symbols are all those "normal" symbols, as they are used for
function definitions and variable names. They are "interned" into an index
structure, so that it is possible to find an internal symbol by searching for
its name.


There cannot be two different symbols with the same name in the same
namespace.


Initially, a new internal symbol's VAL is NIL.



Transient Symbols
Transient symbols are only interned into an index structure for a certain
time (e.g. while reading the current source file), and are released after that.
That means, a transient symbol cannot be accessed then by its name, and there
may be several transient symbols in the system having the same name.


Transient symbols are used


    

  • as text strings


  • as identifiers with a limited access scope (like, for example,
static identifiers in the C language family)


  • as anonymous, dynamically created objects (without a name)


Initially, a new transient symbol's VAL is that symbol itself.


A transient symbol without a name can be created with the box or new functions.



External Symbols
External symbols reside in a database file (or other resources, see *Ext), and are loaded into memory - and written
back to the file - dynamically as needed, and transparently to the programmer.
They are kept in memory ("cached") as long as they are accessible ("referred
to") from other parts of the program, or when they were modified but not yet
written to the database file (by commit).


The interpreter recognizes external symbols internally by an additional tag
bit in the tail structure.


There cannot be two different external symbols with the same name. External
symbols are maintained in index structures while they are loaded into memory,
and have their external location (disk file and block offset) directly coded
into their names (more details here).


Initially, a new external symbol's VAL is NIL, unless otherwise
specified at creation time.



Lists
A list is a sequence of one or more cells (cons pairs), holding numbers,
symbols, or cons pairs.


      |
      V
      +-----+-----+
      | any |  |  |
      +-----+--+--+
               |
               V
               +-----+-----+
               | any |  |  |
               +-----+--+--+
                        |
                        V
                        ...

Lists are used in PicoLisp to implement composite data structures like
arrays, trees, stacks or queues.


In contrast to lists, numbers and symbols are collectively called "Atoms".


Typically, the CDR of each cell in a list points to the following cell,
except for the last cell which points to NIL. 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).



Memory Management
The PicoLisp interpreter has complete knowledge of all data in the system,
due to the type information associated with every pointer. Therefore, an
efficient garbage collector mechanism can easily be implemented. PicoLisp
employs a simple but fast mark-and-sweep garbage collector.


As the collection process is very fast (in the order of milliseconds per
megabyte), it was not necessary to develop more complicated, time-consuming and
error-prone garbage collection algorithms (e.g. incremental collection). A
compacting garbage collector is also not necessary, because the single cell data
type cannot cause heap fragmentation.



Programming Environment
Lisp was chosen as the programming language, because of its clear and simple
structure.


In some previous versions, a Forth-like syntax was also implemented on top of
a similar virtual machine (Lifo). Though that language was more flexible and
expressive, the traditional Lisp syntax proved easier to handle, and the virtual
machine can be kept considerably simpler.

PicoLisp inherits the major advantages of classical Lisp systems like


    

  • Dynamic data types and structures

  • Formal equivalence of code and data

  • Functional programming style

  • An interactive environment

In the following, some concepts and peculiarities of the PicoLisp language
and environment are described.



Installation
PicoLisp supports two installation strategies: Local and Global.


Normally, if you didn't build PicoLisp yourself but installed it with your
operating system's package manager, you will have a global installation. This
allows system-wide access to the executable and library/documentation files.


To get a local installation, you can directly download the PicoLisp tarball,
and follow the instructions in the INSTALL file.


A local installation will not interfere in any way with the world outside its
directory. There is no need to touch any system locations, and you don't have to
be root to install it. Many different versions - or local modifications - of
PicoLisp can co-exist on a single machine.


Note that you are still free to have local installations along with a global
installation, and invoke them explicitly as desired.


Most examples in the following apply to a global installation.



Invocation
When PicoLisp is invoked from the command line, an arbitrary number of
arguments may follow the command name.


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 argv and opt functions). This whole mechanism corresponds
to calling (load T).


A special case is if the last argument is a single '+'. This
will switch on debug mode (the *Dbg
global variable) and discard the '+'. In that case, a file
"~/.pil/rc" (if it exists) will be loaded, which can contain arbitrary statements
and definitions (e.g. to initialize the readline(3) history).


As a convention, PicoLisp source files have the extension ".l".


Note that the PicoLisp executable itself does not expect or accept any
command line flags or options (except the '+', see above). They are
reserved for application programs.


The simplest and shortest invocation of PicoLisp does nothing, and exits
immediately by calling bye:


$ picolisp -bye
$

In interactive mode, the PicoLisp interpreter (see load) will also exit when Ctrl-D
is entered:


$ picolisp
:           # Typed Ctrl-D
$

To start up the standard PicoLisp environment, several files should be
loaded. The most commonly used things are in "lib.l" and in a bunch of other
files, which are in turn loaded by "ext.l". Thus, a typical call would be:


$ picolisp lib.l ext.l

The recommended way, however, is to call the "pil" shell script, which
includes "lib.l" and "ext.l". Given that your current project is loaded by some
file "myProject.l" and your startup function is main, your
invocation would look like:


$ pil myProject.l -main

For interactive development it is recommended to enable debugging mode, to
get readline(3) line history, single-stepping, tracing and other
debugging utilities.


$ pil myProject.l -main +

This is - in a local installation - equivalent to


$ ./pil myProject.l -main +

In any case, the directory part of the first file name supplied (normally,
the path to "lib.l" as called by 'pil') is remembered internally as the
PicoLisp Home Directory. This path is later automatically substituted for
any leading "@" character in file name arguments to I/O functions
(see path).



Input/Output
In Lisp, each internal data structure has a well-defined external
representation in human-readable format. All kinds of data can be written to a
file, and restored later to their original form by reading that file.


For all input functions besides wr,
rd and echo the input is assumed to be valid UTF-8,
consisting only of characters allowed in picolisp symbol names.


In normal operation, the PicoLisp interpreter continually executes an
infinite "read-eval-print loop". It reads one expression at a time, evaluates
it, and prints the result to the console. Any input into the system, like data
structures and function definitions, is done in a consistent way no matter
whether it is entered at the console or read from a file.


Comments can be embedded in the input stream with the hash #
character. Everything up to the end of that line will be ignored by the reader.


: (* 1 2 3)  # This is a comment
-> 6

A comment spanning several lines (a block comment) may be enclosed between
#{ and }#. Block comments may be nested.



Here is the I/O syntax for the individual PicoLisp data types (numbers,
symbols and lists) and for read-macros:



Numbers
A number consists of an arbitrary number of digits ('0' through
'9'), optionally preceded by a sign character ('+' or
'-'). Legal number input is:


: 7
-> 7
: -12345678901245678901234567890
-> -12345678901245678901234567890

Fixpoint numbers can be input by embedding a decimal point '.',
and setting the global variable *Scl
appropriately:


: *Scl
-> 0

: 123.45
-> 123
: 456.78
-> 457

: (setq *Scl 3)
-> 3
: 123.45
-> 123450
: 456.78
-> 456780

Thus, fixpoint input simply scales the number to an integer value
corresponding to the number of digits in *Scl.


Formatted output of scaled fixpoint values can be done with the format and round functions:


: (format 1234567890 2)
-> "12345678.90"
: (format 1234567890 2 "." ",")
-> "12,345,678.90"

Symbols
The reader is able to recognize the individual symbol types from their
syntactic form. A symbol name should - of course - not look like a legal number
(see above).


In general, symbol names are case-sensitive. car is not the same
as CAR.



NIL
Besides the standard form, NIL is also recognized as
(), [] or "".


: NIL
-> NIL
: ()
-> NIL
: ""
-> NIL

Output will always appear as NIL.



Internal Symbols
Internal symbol names can consist of any printable (non-whitespace)
character, except for the following meta characters:


   "  '  (  )  ,  [  ]  `  { } ~

It is possible, though, to include these special characters into symbol names
by escaping them with a backslash '\'.


The dot '.' has a dual nature. It is a meta character when
standing alone, denoting a dotted pair, but can otherwise
be used in symbol names.


As a rule, anything not recognized by the reader as another data type will be
returned as an internal symbol.



Transient Symbols
A transient symbol is anything surrounded by double quotes '"'.
With that, it looks like - and can be used as - a string constant in other
languages. However, it is a real symbol, and may be assigned a value or a
function definition, and properties.


Initially, a transient symbol's value is that symbol itself, so that it does
not need to be quoted for evaluation:


: "This is a string"
-> "This is a string"

However, care must be taken when assigning a value to a transient symbol.
This may cause unexpected behavior:


: (setq "This is a string" 12345)
-> 12345
: "This is a string"
-> 12345

The name of a transient symbol can contain any character except the
null-byte. Control characters can be written with a preceding hat
'^' character. A hat or a double quote character can be escaped
with a backslash '\', and a backslash itself has to be escaped with
another backslash.


: "We^Ird\\Str\"ing"
-> "We^Ird\\Str\"ing"
: (chop @)
-> ("W" "e" "^I" "r" "d" "\\" "S" "t" "r" "\"" "i" "n" "g")

The combination of a backslash followed by 'b', 'e', 'n', 'r' or 't' is
replaced with backspace ("^H"), escape ("^["), newline ("^J"), return ("^M") or
TAB ("^I"), respectively.


: "abc\tdef\r"
-> "abc^Idef^M"

A decimal number between two backslashes can be used to specify any unicode
character directly.


: "äöü\8364\xyz"
-> "äöü€xyz"

A backslash in a transient symbol name at the end of a line discards the
newline, and continues the name in the next line. In that case, all leading
spaces and tabs in that line are discarded, to allow proper source code
indentation.


: "abc\
   def"
-> "abcdef"
: "x \
   y \
   z"
-> "x y z"

The index for transient symbols is local when loading a source file. With that mechanism, it
is possible to create symbols with a local access scope, not accessible from
other parts of the program.


A special case of transient symbols are anonymous symbols. These are
symbols without name (see box, box? or new). They print as a dollar sign
($) followed by a decimal digit string (actually their machine
address).



External Symbols
External symbol names are surrounded by braces ('{' and
'}'). The characters of the symbol's name itself identify the
physical location of the external object. This is 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').


The database file is omitted for the first (default) file.



Lists
Lists are surrounded by parentheses ('(' and ')').


(A) is a list consisting of a single cell, with the symbol
A in its CAR, and NIL in its CDR.


(A B C) is a list consisting of three cells, with the symbols
A, B and C respectively in their CAR, and
NIL in the last cell's CDR.


(A . B) is a "dotted pair", a list
consisting of a single cell, with the symbol A in its CAR, and
B in its CDR.


PicoLisp has built-in support for reading and printing simple circular lists.
If the dot in a dotted-pair notation is immediately followed by a closing
parenthesis, it indicates that the CDR of the last cell points back to the
beginning of that list.


: (let L '(a b c) (conc L L))
-> (a b c .)
: (cdr '(a b c .))
-> (b c a .)
: (cddddr '(a b c .))
-> (b c a .)

A similar result can be achieved with the function circ. Such lists must be used with care,
because many functions won't terminate or will crash when given such a list.



Read-Macros
Read-macros in PicoLisp are special forms that are recognized by the reader,
and modify its behavior. Note that they take effect immediately while reading an expression, and are not seen by the
eval in the main loop.


The most prominent read-macro in Lisp is the single quote character
"'", which expands to a call of the quote function. Note that the single quote
character is also printed instead of the full function name.


: '(a b c)
-> (a b c)
: '(quote . a)
-> 'a
: (cons 'quote 'a)   # (quote . a)
-> 'a
: (list 'quote 'a)   # (quote a)
-> '(a)

A comma (,) will cause the reader to collect the following data
item into an idx tree in the global
variable *Uni, 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. If the value of *Uni is T, the
comma read macro mechanism is disabled.


A single backquote character "`" will cause the reader to
evaluate the following expression, and return the result.


: '(a `(+ 1 2 3) z)
-> (a 6 z)

A tilde character ~ inside a list will cause the reader to
evaluate the following expression, and (destructively) splice the result into
the list.


: '(a b c ~(list 'd 'e 'f) g h i)
-> (a b c d e f g h i)

When a tilde character is used to separate two symbol names (without
surrounding whitespace), the first is taken as a namespace to look up the
second.


: 'libA~foo  # Look up 'foo' in namespace 'libA'
-> libA~foo  # "foo" is not interned in the current namespace

Reading libA~foo is equivalent to switching the current
namespace search order to libA only (with symbols), reading the symbol
foo, and then switching back to the original search order.


%~foo temporarily switches the search order to the
CDR of the current namespace list.


Brackets ('[' and ']') can be used as super
parentheses. A closing bracket will match the innermost opening bracket, or all
currently open parentheses.


: '(a (b (c (d]
-> (a (b (c (d))))
: '(a (b [c (d]))
-> (a (b (c (d))))

Finally, reading the sequence '{}' will result in a new
anonymous symbol with value NIL, equivalent to a call to box without arguments.


: '({} {} {})
-> ($177066763035351 $177066763035353 $177066763035355)
: (mapcar val @)
-> (NIL NIL NIL)

Namespaces
When the reader encounters an atom that is not a number, it looks for
it in the current namespace search order. If a symbol with that name is
found, it is used; otherwise, a new symbol is created and interned in
the current namespace.


In general, namespaces in PicoLisp have nothing to do with the values
or definitions of symbols, but only with their scope (visibility).
Several symbols with the same name may exist in different namespaces,
and a single symbol may exist in one or many (or none at all)
namespaces.


At interpreter startup, only the internal pico namespace exists, along with the
three special built-in namespaces for transient, external,
and private symbols.


For internal symbols, it may not always be clear which namespace(s)
they belong to. Depending on the search order, the same name in a given
code segment might refer to different physical symbols. To avoid
ambiguity, it is recommended to follow these namespace policies:





Invariant namespace order


Across different parts of a program and all loaded libraries the
search order may be changed as needed, but the position of each
namespace relative to other namespaces should stay the same. That is,
namespace A should not overshadow namespace B in one context and be
overshadowed by B in another context.




Scope declaration before first usage


Calls to symbols,
private, local or import should precede any appearance
(not just definition!) of all involved symbols, because merely reading a
symbol may already intern it in the wrong namespace. 



Evaluation
PicoLisp tries to evaluate any expression encountered in the read-eval-print
loop. Basically, it does so by applying the following three rules:


    

  • A number evaluates to itself.


  • A symbol evaluates to its value (VAL).


  • A list is evaluated as a function call, with the CAR as the function and the
CDR the arguments to that function. These arguments are in turn evaluated
according to these three rules.


: 1234
-> 1234        # Number evaluates to itself
: *Pid
-> 22972       # Symbol evaluates to its VAL
: (+ 1 2 3)
-> 6           # List is evaluated as a function call

For the third rule, however, things get a bit more involved. First - as a
special case - if the CAR of the list is a number, the whole list is returned as
it is:


: (1 2 3 4 5 6)
-> (1 2 3 4 5 6)

This is not really a function call, but just a convenience to avoid having to
quote simple data lists. The interpreter needs to check it anyway, and returning
the list (instead of throwing an error) is a lot faster than calling the
quote function.


Otherwise, if the CAR is a symbol or a list, PicoLisp tries to obtain an
executable function from that, by either using the symbol's value, or by
evaluating the list.


What is an executable function? Or, said in another way, what can be applied
to a list of arguments, to result in a function call? A legal function in
PicoLisp is




either


a number. When a number is used as a function, it is simply taken as
a pointer to executable code that will be called with the list of (unevaluated)
arguments as its single parameter. It is up to that code to evaluate the
arguments, or not. Some functions do not evaluate their arguments (e.g.
quote) or evaluate only some of their arguments (e.g.
setq).




or


a lambda expression. A lambda expression is a list, whose CAR is
either a symbol or a list of symbols, and whose CDR is a list of expressions.
Note: In contrast to other Lisp implementations, the symbol LAMBDA itself does
not exist in PicoLisp but is implied from context.




A few examples should help to understand the practical consequences of these
rules. In the most common case, the CAR will be a symbol defined as a function,
like the * in:


: (* 1 2 3)    # Call the function '*'
-> 6

Inspecting the VAL of * gives


: *            # Get the VAL of the symbol '*'
-> 67318096

The VAL of * is a number. In fact, it is the numeric
representation of a function pointer, i.e. a pointer to executable code. This
is the case for all built-in functions of PicoLisp.


Other functions in turn are written as Lisp expressions:


: (de foo (X Y)            # Define the function 'foo'
   (* (+ X Y) (+ X Y)) )
-> foo
: (foo 2 3)                # Call the function 'foo'
-> 25
: foo                      # Get the VAL of the symbol 'foo'
-> ((X Y) (* (+ X Y) (+ X Y)))

The VAL of foo is a list. It is the list that was assigned to
foo with the de function. It would be perfectly legal
to use setq instead of de:


: (setq foo '((X Y) (* (+ X Y) (+ X Y))))
-> ((X Y) (* (+ X Y) (+ X Y)))
: (foo 2 3)
-> 25

If the VAL of foo were another symbol, that symbol's VAL would
be used instead to search for an executable function.


As we said above, if the CAR of the evaluated expression is not a symbol but
a list, that list is evaluated to obtain an executable function.


: ((intern (pack "c" "a" "r")) (1 2 3))
-> 1

Here, the intern function returns the symbol car
whose VAL is used then. It is also legal, though quite dangerous, to use the code-pointer directly:


: *
-> 67318096
: ((* 2 33659048) 1 2 3)
-> 6
: ((quote . 67318096) 1 2 3)
-> 6
: ((quote . 1234) (1 2 3))
Segmentation fault

When an executable function is defined in Lisp itself, we call it a lambda expression. A lambda expression always has a
list of executable expressions as its CDR. The CAR, however, must be a either a
list of symbols, or a single symbol, and it controls the evaluation of the
arguments to the executable function according to the following rules:





When the CAR is a list of symbols


For each of these symbols an argument is evaluated, then the symbols are
bound simultaneously to the results. The body of the lambda expression is
executed, then the VAL's of the symbols are restored to their original values.
This is the most common case, a fixed number of arguments is passed to the
function. 
As a special case, a single-level list of symbols may be passed
instead of a single parameter here, resulting in a restricted form of
destructuring bind.




Otherwise, when the CAR is the symbol @


All arguments are evaluated and the results kept internally in a list. The
body of the lambda expression is executed, and the evaluated arguments can be
accessed sequentially with the args,
next, arg and rest functions. This allows to define functions
with a variable number of evaluated arguments.




Otherwise, when the CAR is a single symbol


The symbol is bound to the whole unevaluated argument list. The body of the
lambda expression is executed, then the symbol is restored to its original
value. This allows to define functions with unevaluated arguments. Any kind of
interpretation and evaluation of the argument list can be done inside the
expression body.




In all cases, the return value is the result of the last expression in the
body.


: (de foo (X Y Z)                   # CAR is a list of symbols
   (list X Y Z) )                   # Return a list of all arguments
-> foo
: (foo (+ 1 2) (+ 3 4) (+ 5 6))
-> (3 7 11)                         # all arguments are evaluated

: (de foo @                         # CAR is the symbol '@'
   (list (next) (next) (next)) )    # Return the first three arguments
-> foo
: (foo (+ 1 2) (+ 3 4) (+ 5 6))
-> (3 7 11)                         # all arguments are evaluated

: (de foo X                         # CAR is a single symbol
   X )                              # Return the argument
-> foo
: (foo (+ 1 2) (+ 3 4) (+ 5 6))
-> ((+ 1 2) (+ 3 4) (+ 5 6))        # the whole unevaluated list is returned

Note that these forms can also be combined. For example, to evaluate only the
first two arguments, bind the results to X and Y, and
bind all other arguments (unevaluated) to Z:


: (de foo (X Y . Z)                 # CAR is a list with a dotted-pair tail
   (list X Y Z) )                   # Return a list of all arguments
-> foo
: (foo (+ 1 2) (+ 3 4) (+ 5 6))
-> (3 7 ((+ 5 6)))                  # Only the first two arguments are evaluated

Or, a single argument followed by a variable number of arguments:


: (de foo (X . @)                   # CAR is a dotted-pair with '@'
   (println X)                      # print the first evaluated argument
   (while (args)                    # while there are more arguments
      (println (next)) ) )          # print the next one
-> foo
: (foo (+ 1 2) (+ 3 4) (+ 5 6))
3                                   # X
7                                   # next argument
11                                  # and the last argument
-> 11

In general, if more than the expected number of arguments is supplied to a
function, these extra arguments will be ignored. Missing arguments default to
NIL.



Shared Libraries
Analogous to built-in functions (which are written in PilSrc (based on LLVM))
in the interpreter kernel), PicoLisp functions may also be defined in shared
object files (called "DLLs" on some systems). The coding style, register usage,
argument passing etc. follow the same rules as for normal built-in functions.


Note that this has nothing to do with external (e.g. third-party) library
functions called with native.


When the interpreter encounters a symbol supposed to be called as a function,
without a function definition, but with a name of the form
"lib:sym", then - instead of throwing an "undefined"-error - it
tries to locate a shared object file with the name lib.so and a
function sym, and stores a pointer to this code in the symbol's
value. From that point, this symbol lib:sym keeps that function
definition, and is undistinguishable from built-in functions. Future calls to
this function do not require another library search.


A consequence of this lookup mechanism, however, is the fact that such
symbols cannot be used directly in a function-passing context (i.e.
"apply" them) like


(apply + (1 2 3))
(mapcar inc (1 2 3))

These calls work because + and inc already have a
(function) value at this point. Applying a shared library function like


(apply ext:Base64 (1 2 3))

works only if ext:Base64 was either called before (and
thus automatically received a function definition), or was fetched explicitly
with (getd 'ext:Base64).


Therefore, it is recommended to always apply such functions by passing the
symbol itself and not just the value:


(apply 'ext:Base64 (1 2 3))

Coroutines
Coroutines are independent execution contexts. They may have multiple entry
and exit points, and preserve their environment (stack, symbol bindings,
namespaces, catch/throw and I/O frames) between invocations.


A coroutine is identified by a tag. This tag can be passed to other
functions, and (re)invoked as needed. In this regard coroutines are similar to
"continuations" in other languages.


Tags may be of any type (pointer equality is used for comparison), but
symbolic tags are more efficient for large numbers of coroutines. They cache a
pointer to the internal data structure in a property with key zero (which is
inaccessible with the put and get functions).


A coroutine is created by calling co.
Its prg body will be executed, and unless yield is called at some point, the coroutine
will "fall off" at the end and disappear.


The initial value of This is bound
and preserved in the coroutine environment.


When yield is called, control is
either transferred back to the caller, or to some other - explicitly specified,
and already running - coroutine.


A coroutine is stopped and disposed when


    

  • execution falls off the end


  • some other (co)routine calls co with
that tag but without a prg body


  • a throw into another (co)routine
environment is executed


  • an error occurred, and error handling was entered


Reentrant co calls are not allowed: A
coroutine cannot call or stop itself directly or indirectly.


Before using many coroutines, make sure you have sufficient stack space, e.g.
by calling


$ ulimit -s unlimited

Without that, the stack limit in Linux is typically 8 MiB.



Interrupt
During the evaluation of an expression, the PicoLisp interpreter can be
interrupted at any time by hitting Ctrl-C. It will then enter the
breakpoint routine, as if ! were called.


Hitting ENTER at that point will continue evaluation, while
Ctrl-D or (quit) will
abort evaluation and return the interpreter to the top level. See also debug, e, ^ and
*Dbg


Other interrupts may be handled by alarm, sigio, *Hup, *Winch, *Sig[12], *TStp[12] and *Term.



Error Handling
When a runtime error occurs, execution is stopped and an error handler is
entered.


The error handler resets the I/O channels to the console, and displays the
location (if possible) and the reason of the error, followed by an error
message. That message is also stored in the global *Msg, and the location of the error in ^. If the VAL of the global *Err is non-NIL it is executed as
a prg body. If the standard input is from a terminal, a
read-eval-print loop (with a question mark "?" as prompt) is
entered (the loop is exited when an empty line is input). Then all pending
finally expressions are executed,
all variable bindings restored, and all files closed. If the standard input is
not from a terminal, the interpreter terminates. Otherwise it is reset to its
top-level state.


: (de foo (A B) (badFoo A B))       # 'foo' calls an undefined symbol
-> foo
: (foo 3 4)                         # Call 'foo'
!? (badFoo A B)                     # Error handler entered
badFoo -- Undefined
? A                                 # Inspect 'A'
-> 3
? B                                 # Inspect 'B'
-> 4
?                                   # Empty line: Exit
:

Errors can be caught with catch,
if a list of substrings of possible error messages is supplied for the first
argument. In such a case, the matching substring (or the whole error message if
the substring is NIL) is returned.


An arbitrary error can be thrown explicitly with quit.



@ Result
In certain situations, the result of the last evaluation is stored in the VAL
of the symbol @. This can be very convenient, because it often
makes the assignment to temporary variables unnecessary.


This happens in two - only superficially similar - situations:





load


In read-eval loops, the last three results which were printed at the console
are available in @@@, @@ and @, in that
order (i.e the latest result is in @).


: (+ 1 2 3)
-> 6
: (/ 128 4)
-> 32
: (- @ @@)        # Subtract the last two results
-> 26






Flow functions


Flow functions store the non-nil results of controlling expressions, and
logic functions their non-nil results, in @.


: (while (read) (println 'got: @))
abc            # User input
got: abc       # print result
123            # User input
got: 123       # print result
NIL
-> 123

: (setq L (1 2 3 4 5 1 2 3 4 5))
-> (1 2 3 4 5 1 2 3 4 5)
: (and (member 3 L) (member 3 (cdr @)) (set @ 999))
-> 999
: L
-> (1 2 3 4 5 1 2 999 4 5)




Functions with controlling expressions are
   case,
   casq,
   prog1,
   prog2,
and the bodies of *Run tasks.


Functions with conditional expressions are
   and,
   cond,
   do,
   for,
   if,
   ifn,
   if2,
   if@@,
   loop,
   nand,
   nond,
   nor,
   not,
   or,
   state,
   unless,
   until,
   when and
   while.




@ is generally local to functions and methods, its value is
automatically saved upon function entry and restored at exit.



Comparing
In PicoLisp, it is legal to compare data items of arbitrary type. Any two
items are either





Identical


They are the same memory object (pointer equality). For example, two
internal symbols with the same name are identical. And short numbers (up to 60
bits plus sign) are also equivalent to "pointer"-equal.




Equal


They are equal in every respect (structure equality), but need not to be
identical. Examples are numbers with the same value, transient symbols with the
same name or lists with equal elements.




Or they have a well-defined ordinal relationship


Numbers are comparable by their numeric value, strings by their name, and
lists recursively by their elements (if the CAR's are equal, their CDR's are
compared). For differing types, the following rule applies: Numbers are less
than symbols, and symbols are less than lists. As special cases,
NIL is always less than anything else, and T is always
greater than anything else.




To demonstrate this, sort a list of
mixed data types:


: (sort '("abc" T (d e f) NIL 123 DEF))
-> (NIL 123 DEF "abc" (d e f) T)

See also max, min, rank, <, =, >
etc.



OO Concepts
PicoLisp comes with built-in object oriented extensions. There seems to be a
common agreement upon three criteria for object orientation:




Encapsulation


Code and data are encapsulated into objects, giving them both a
behavior and a state. Objects communicate by sending and receiving
messages.




Inheritance


Objects are organized into classes. The behavior of an object is
inherited from its class(es) and superclass(es).




Polymorphism


Objects of different classes may behave differently in response to the same
message. For that, classes may define different methods for each message.




PicoLisp implements both objects and classes with symbols. Object-local data
are stored in the symbol's property list, while the code (methods) and links to
the superclasses are stored in the symbol's VAL (encapsulation).


In fact, there is no formal difference between objects and classes (except
that objects usually are anonymous symbols containing mostly local data, while
classes are named internal symbols with an emphasis on method definitions). At
any time, a class may be assigned its own local data (class variables), and any
object can receive individual method definitions in addition to (or overriding)
those inherited from its (super)classes.


PicoLisp supports multiple inheritance. The VAL of each object is a (possibly
empty) association list of message symbols and method bodies, concatenated with
a list of classes. When a message is sent to an object, it is searched in the
object's own method list, and then (with a left-to-right depth-first search) in
the tree of its classes and superclasses. The first method found is executed and
the search stops. The search may be explicitly continued with the extra and super functions.


Thus, which method is actually executed when a message is sent to an object
depends on the classes that the object is currently linked to (polymorphism). As
the method search is fully dynamic (late binding), an object's type (i.e. its
classes and method definitions) can be changed even at runtime!


While a method body is being executed, the global variable This is set to the current object, allowing
the use of the short-cut property functions =:, :
and ::.



Database
On the lowest level, a PicoLisp database is just a collection of external symbols. They reside in a database file, and are
dynamically swapped in and out of memory. Only one database can be open at a
time (pool).


In addition, further external symbols can be specified to originate from
arbitrary sources via the *Ext
mechanism.


Whenever an external symbol's value or property list is accessed, it will be
automatically fetched into memory, and can then be used like any other symbol.
Modifications will be written to disk only when commit is called. Alternatively, all
modifications since the last call to commit can be discarded by
calling rollback.


Note that a property with the key NIL is a volatile
property, which is held only in memory and not written to disk on
commit, and discarded by rollback. Volatile properties
can be used by applications for any kind of temporary data.



Transactions
In the typical case there will be multiple processes operating on the same
database. These processes should be all children of the same parent process,
which takes care of synchronizing read/write operations and heap contents. Then
a database transaction is normally initiated by calling (dbSync), and closed by calling (commit 'upd). Short transactions, involving
only a single DB operation, are available in functions like new! and methods like put!> (by convention with an
exclamation mark), which implicitly call (dbSync) and (commit
'upd) themselves.


A transaction proceeds through five phases:


    

  1. dbSync waits to get a lock on the root object *DB. Other processes continue reading and
writing meanwhile.


  2. dbSync calls sync to synchronize with changes from other
processes. We hold the shared lock, but other processes may continue reading.


  3. We make modifications to the internal state of external symbols with
put>, set>, lose> etc. We -
and also other processes - can still read the DB.


  4. We call (commit 'upd).
commit obtains an exclusive lock (no more read operations by other
processes), writes an optional transaction log, and then all modified symbols.
As upd is passed to 'commit', other
processes synchronize with these changes.


  5. Finally, all locks are released by 'commit'.


Entities / Relations
The symbols in a database can be used to store arbitrary information
structures. In typical use, some symbols represent nodes of search trees, by
holding keys, values, and links to subtrees in their VAL's. Such a search tree
in the database is called index.


For the most part, other symbols in the database are objects derived from the
+Entity class.


Entities depend on objects of the +relation class hierarchy.
Relation-objects manage the property values of entities, they define the
application database model and are responsible for the integrity of mutual
object references and index trees.


Relations are stored as properties in the entity classes, their methods are
invoked as daemons whenever property values in an entity are changed. When
defining an +Entity class, relations are defined - in addition to
the method definitions of a normal class - with the rel function. Predefined relation classes
include


    

  • Scalar relations like
   
    
   
    +Symbol
    
   
    Symbolic data
    
   
    +String
    
   
    Strings (just a general case of symbols)
    
   
    +Number
    
   
    Integers and fixpoint numbers
    
   
    +Date
    
   
    Calendar date values, represented by a number
    
   
    +Time
    
   
    Time-of-the-day values, represented by a number
    
   
    +Blob
    
   
    "Binary large objects" stored in separate files
    
   
    +Bool
    
   
    T or NIL
    
   
    

  • Object-to-object relations
   
    
   
    +Link
    
   
    A reference to some other entity
    
   
    +Hook
    
   
    A reference to an entity holding object-local index trees
    
   
    +Joint
    
   
    A bidirectional reference to some other entity
    
   
    

  • Container prefix classes like
   
    
   
    +List
    
   
    A list of any of the other primitive or object relation types
    
   
    +Bag
    
   
    A list containing a mixture of any of the other types
    
   
    

  • Index prefix classes
   
    
   
    +Ref
    
   
    An index with other primitives or entities as key
    
   
    +Key
    
   
    A unique index with other primitives or entities as key
    
   
    +Idx
    
   
    A full-text index, typically for strings
    
   
    +Fold
    
   
    A folded text index
    
   
    +IdxFold
    
   
    Folded substring index
    
   
    +Sn
    
   
    Tolerant index, using a modified Soundex-Algorithm
    
   
    

  • And a catch-all class
   
    
   
    +Any
    
   
    Not specified, may be any of the above relations
    
   
    

Pilog (PicoLisp Prolog)
A declarative language is built on top of PicoLisp, that has the semantics of
Prolog, but uses the syntax of Lisp.


For an explanation of Prolog's declarative programming style, an introduction
like "Programming in Prolog" by Clocksin/Mellish (Springer-Verlag 1981) is
recommended.


Facts and rules can be declared with the be function. For example, a Prolog fact
'likes(john,mary).' is written in Pilog as:


(be likes (John Mary))

and a rule 'likes(john,X) :- likes(X,wine), likes(X,food).' is
in Pilog:


(be likes (John @X) (likes @X wine) (likes @X food))

As in Prolog, the difference between facts and rules is that the latter ones
have conditions, and usually contain variables.


A variable in Pilog is any symbol starting with an at-mark character
("@"), i.e. a pat?
symbol. The symbol @ itself can be used as an anonymous variable:
It will match during unification, but will not be bound to the matched values.


The cut operator of Prolog (usually written as an exclamation mark
(!)) is the symbol T in Pilog.


An interactive query can be done with the ? function:


(? (likes John @X))

This will print all solutions, waiting for a key after each line. If
ESC is typed, it will terminate.


Pilog can be called from Lisp and vice versa:


    


  • The interface from Lisp is via the functions goal (prepare a query from Lisp data) and
prove (return an association list of
successful bindings), and the application level functions pilog and solve.


  • When the CAR of a Pilog clause is the symbol ^, then the CDDR
is executed as a Lisp prg body and the result unified with the
CADR.


  • Within such a Lisp expression in a Pilog clause, the current bindings of
Pilog variables are directly accessible in the corresponding Lisp symbol
bindings or can be accessed with the -> function (the latter is only necessary
to access non-top-level Pilog environments).


Naming Conventions
It was necessary to introduce - and adhere to - a set of conventions for
PicoLisp symbol names. Because all (internal) symbols have a global scope, and
each symbol can only have either a value or function definition, it would
otherwise be very easy to introduce name conflicts. Besides this, source code
readability is increased when the scope of a symbol is indicated by its name.


These conventions are not hard-coded into the language, but should be so into
the head of the programmer. Here are the most commonly used ones:


    

  • Global variables start with an asterisk "*"

  • Global constants may be written all-uppercase

  • Functions and other global symbols start with a lower case letter

  • Locally bound symbols start with an upper case letter

  • Local functions start with an underscore "_"

  • Classes start with a plus-sign "+", where the first letter
   
      
   
    • is in lower case for abstract classes
   
    • and in upper case for normal classes
   
    

  • Methods end with a right arrow ">"

  • Class variables may be indicated by an upper case letter

For example, a local variable could easily overshadow a function definition:


: (de max-speed (car)
   (.. (get car 'speeds) ..) )
-> max-speed

Inside the body of max-speed (and all other functions called
during that execution) the kernel function car is redefined to some
other value, and will surely crash if something like (car Lst) is
executed. Instead, it is safe to write:


: (de max-speed (Car)            # 'Car' with upper case first letter
   (.. (get Car 'speeds) ..) )
-> max-speed

Note that there are also some strict naming rules (as opposed to the
voluntary conventions) that are required by the corresponding kernel
functionalities, like:


    

  • Transient symbols are enclosed in double quotes (see Transient Symbols)

  • External symbols are enclosed in braces (see External
Symbols)

  • Pattern-Wildcards start with an at-mark "@" (see match and fill)

  • Symbols referring to a shared library contain a colon "lib:sym"

With that, the last of the above conventions (local functions start with an
underscore) is not really necessary, because true local scope can be enforced
with transient symbols.


The symbols T and NIL are global constants, so care
should be taken not to bind them to some other value by mistake:


(de foo (R S T)
   ...

However, lint will issue a warning
in such a case.



Breaking Traditions
PicoLisp does not try very hard to be compatible with traditional Lisp
systems. If you are used to some other Lisp dialects, you may notice the
following differences:





Case Sensitivity


PicoLisp distinguishes between upper case and lower case characters in
symbol names. Thus, CAR and car are different symbols,
which was not the case in traditional Lisp systems.




QUOTE


In traditional Lisp, the QUOTE function returns its
first unevaluated argument. In PicoLisp, on the other hand,
quote returns all (unevaluated) argument(s).




LAMBDA


The LAMBDA function, in some way at the heart of traditional
Lisp, is completely missing (and quote is used instead).




PROG


The PROG function of traditional Lisp, with its GOTO and ENTER
functionality, is also missing. PicoLisp's prog function is just a
simple sequencer (as PROGN in some Lisps).




Function/Value


In PicoLisp, a symbol cannot have a value and a function definition
at the same time. Though this is a disadvantage at first sight, it allows a
completely uniform handling of functional data.




Function Reference
This section provides a reference manual for the kernel functions, and some
extensions. See the thematically grouped list of indexes below.


Though PicoLisp is a dynamically typed language (resolved at runtime, as
opposed to statically (compile-time) typed languages), many functions can only
accept and/or return a certain set of data types. For each function, the
expected argument types and return values are described with the following
abbreviations:


The primary data types:


    

  • num - Number

  • sym - Symbol

  • lst - List

Other (derived) data types


    

  • any - Anything: Any data type

  • flg - Flag: Boolean value (NIL or non-NIL)

  • cnt - A count or a small number

  • dat - Date: Days, starting first of March of the year 0 A.D.

  • tim - Time: Seconds since midnight

  • obj - Object/Class: A symbol with methods and/or classes

  • var - Variable: Either a symbol or a cons pair

  • exe - Executable: An executable expression (eval)

  • prg - Prog-Body: A list of executable expressions (run)

  • fun - Function: Either a number (code-pointer), a symbol (message) or a list (lambda)

  • msg - Message: A symbol sent to an object (to invoke a method)

  • cls - Class: A symbol defined as an object's class

  • typ - Type: A list of cls symbols

  • pat - Pattern: A symbol whose name starts with an at-mark "@"

  • pid - Process ID: A number, the ID of a Unix process

  • fd - File descriptor: The number of an open file

  • tree - Database index tree specification

  • hook - Database hook object

Arguments evaluated by the function in the "normal" way are quoted (prefixed
with the single quote character "'"). Other arguments are either
not evaluated, or may be evaluated depending on the context.


For example, the function setq
evaluates every second argument (giving any kind of value), while it does
not evaluate the others (vars, here typically symbols). This
could be specified as:


   (setq var1 'any1 var2 'any2 ..) -> any

A dotted pair notation in the argument list like (... 'any .
prg) indicates an unevaluated list of further arguments.


Arguments in brackets '[' and ']' are optional.



A
B
C
D
E
F
G
H
I
J
K
L
M
N
O
P
Q
R
S
T
U
V
W
X
Y
Z
Other





Symbol Functions



   new
   sym
   str
   char
   name
   nsp
   sp?
   pat?
   fun?
   all
   symbols
   -symbols
   private
   local
   export
   import
   all*
   intern
   extern
   qsym
   loc
   box?
   str?
   ext?
   touch
   zap
   length
   size
   format
   chop
   pack
   glue
   pad
   align
   center
   text
   wrap
   pre?
   sub?
   low?
   upp?
   lowc
   uppc
   fold
   val
   getd
   set
   setq
   def
   de
   dm
   recur
   undef
   redef
   daemon
   patch
   swap
   xchg
   on
   off
   onOff
   zero
   one
   default
   expr
   subr
   let
   let?
   use
   buf
   accu
   push
   push1
   push1q
   pop
   ++
   shift
   cut
   del
   queue
   fifo
   rid
   enum
   enum?
   idx
   lup
   cache
   locale
   dirname
   basename





Property Access



   put
   get
   prop
   ;
   =:
   :
   ::
   putl
   getl
   wipe
   meta





Predicates



   atom
   pair
   circ?
   lst?
   num?
   sym?
   flg?
   sp?
   pat?
   fun?
   box?
   str?
   ext?
   bool
   not
   ==
   n==
   =
   <>
   =0
   =1
   =T
   n0
   nT
   <
   <=
   >
   >=
   match
   full





Arithmetics



   +
   -
   *
   /
   %
   */
   **
   inc
   dec
   >>
   rev
   lt0
   le0
   ge0
   gt0
   abs
   bit?
   &
   |
   x|
   sq
   sqrt
   seed
   hash
   rand
   max
   min
   length
   size
   accu
   format
   pad
   money
   round
   bin
   oct
   hex
   hax





List Processing



   car
   cdr
   caar
   cadr
   cdar
   cddr
   caaar
   caadr
   cadar
   caddr
   cdaar
   cdadr
   cddar
   cdddr
   caaaar
   caaadr
   caadar
   caaddr
   cadaar
   cadadr
   caddar
   cadddr
   cdaaar
   cdaadr
   cdadar
   cdaddr
   cddaar
   cddadr
   cdddar
   cddddr
   nth
   con
   cons
   conc
   circ
   rot
   list
   need
   range
   full
   make
   made
   chain
   link
   yoke
   copy
   mix
   append
   delete
   delq
   replace
   insert
   remove
   place
   strip
   split
   reverse
   flip
   trim
   clip
   head
   tail
   stem
   fin
   last
   member
   memq
   mmeq
   sect
   diff
   index
   offset
   prior
   assoc
   rassoc
   asoq
   rasoq
   flood
   rank
   sort
   uniq
   group
   length
   size
   bytes
   val
   set
   xchg
   push
   push1
   push1q
   pop
   ++
   shift
   cut
   queue
   fifo
   idx
   balance
   depth
   get
   fill
   apply





Control Flow



   load
   args
   next
   arg
   rest
   pass
   quote
   as
   lit
   eval
   run
   macro
   curry
   def
   de
   dm
   recur
   recurse
   undef
   box
   new
   type
   isa
   method
   meth
   send
   try
   super
   extra
   this
   with
   bind
   job
   let
   let?
   use
   and
   or
   nand
   nor
   xor
   bool
   not
   nil
   t
   prog
   prog1
   prog2
   if
   ifn
   if2
   if@@
   when
   unless
   cond
   nond
   case
   casq
   state
   while
   until
   loop
   do
   at
   for
   tco
   tc
   catch
   throw
   finally
   co
   yield
   !
   !!
   e
   $
   call
   ipid
   opid
   kill
   quit
   task
   fork
   detach
   pipe
   later
   timeout
   tasks
   abort
   bye





Mapping



   apply
   pass
   fun
   maps
   map
   mapc
   maplist
   mapcar
   mapcon
   mapcan
   filter
   extract
   seek
   find
   pick
   fully
   cnt
   sum
   maxi
   mini
   fish
   by





Input/Output



   path
   in
   out
   err
   ctl
   input
   output
   fd
   tty
   prompt
   ipid
   opid
   pipe
   any
   sym
   str
   load
   hear
   tell
   key
   poll
   peek
   char
   skip
   eol
   eof
   from
   till
   line
   format
   scl
   read
   print
   println
   printsp
   prin
   prinl
   msg
   space
   beep
   tab
   flush
   rewind
   ext
   rd
   pr
   wr
   wait
   sync
   echo
   info
   file
   dir
   open
   close
   port
   listen
   accept
   host
   connect
   udp
   script
   once
   finish
   rc
   acquire
   release
   tmp
   pretty
   pp
   show
   view
   here
   prEval
   mail





Object Orientation



   *Class
   class
   dm
   rel
   var
   var:
   new
   type
   isa
   method
   meth
   send
   try
   object
   extend
   super
   extra
   this
   with
   This
   can
   dep





Database



   pool
   pool2
   journal
   id
   blk
   seq
   lieu
   lock
   commit
   rollback
   mark
   free
   dbck
   tree
   genKey
   genStrKey
   useKey
   +relation
   +Any
   +Bag
   +Bool
   +Number
   +Date
   +Time
   +Symbol
   +String
   +Link
   +Joint
   +Blob
   +Hook
   +Hook2
   +index
   +Key
   +Ref
   +Ref2
   +Idx
   +Sn
   +Fold
   +IdxFold
   +Aux
   +UB
   +Dep
   +List
   +Need
   +Mis
   +Alt
   +Swap
   +Entity
   blob
   dbSync
   new!
   set!
   put!
   inc!
   blob!
   upd
   dbs
   db:
   db
   aux
   collect
   search
   forall
   rel
   request
   request!
   obj
   create
   root
   fetch
   store
   count
   leaf
   minKey
   maxKey
   init
   step
   scan
   iter
   ubIter
   prune
   zapTree
   chkTree
   db/3
   db/4
   db/5
   val/3
   lst/3
   map/3
   isa/2
   same/3
   bool/3
   range/3
   head/3
   fold/3
   part/3
   tolr/3
   select/3
   remote/2
   revolve/2





Pilog



   prove
   ->
   unify
   be
   clause
   repeat
   asserta
   assertz
   retract
   rules
   goal
   fail
   pilog
   solve
   query
   ?
   repeat/0
   fail/0
   true/0
   not/1
   call/1
   or/2
   nil/1
   equal/2
   different/2
   append/3
   member/2
   delete/3
   permute/2
   uniq/2
   asserta/1
   assertz/1
   retract/1
   clause/2
   show/1
   for/2
   for/3
   for/4
   db/3
   db/4
   db/5
   val/3
   lst/3
   map/3
   isa/2
   same/3
   bool/3
   range/3
   head/3
   fold/3
   part/3
   tolr/3
   select/3
   remote/2





Debugging



   pretty
   pp
   show
   loc
   *Dbg
   help
   docs
   doc
   more
   less
   what
   who
   can
   dep
   debug
   -debug
   d
   unbug
   u
   v
   vi
   trace
   -trace
   untrace
   traceAll
   proc
   hd
   bench
   bt
   lint
   lintAll
   select





System Functions



   cmd
   argv
   opt
   version
   gc
   tty
   prompt
   raw
   alarm
   sigio
   kids
   protect
   heap
   stack
   adr
   byte
   env
   trail
   up
   sys
   date
   time
   usec
   rt
   stamp
   dat$
   $dat
   datSym
   datStr
   strDat
   expDat
   day
   week
   ultimo
   tim$
   $tim
   telStr
   expTel
   locale
   allowed
   allow
   pwd
   cd
   chdir
   ctty
   info
   dir
   dirname
   basename
   errno
   native
   %@
   struct
   lisp
   exec
   call
   kill
   quit
   task
   fork
   pipe
   timeout
   mail
   assert
   test
   bye





Globals



   NIL
   pico
   *CPU
   *OS
   *DB
   T
   *Solo
   *PPid
   *Pid
   @
   @@
   @@@
   This
   *Dbg
   *Prompt
   remark
   complete
   reflect
   *Zap
   *Scl
   *Rule
   *Class
   *Dbs
   *Run
   *Hup
   *Sig1
   *Sig2
   *TStp1
   *TStp2
   *Term
   ^
   *Err
   *Msg
   *Uni
   *Adr
   *Allow
   *Fork
   *Bye





Download
The PicoLisp system can be downloaded from the PicoLisp Download page.







================================================
FILE: doc/refA.html
================================================






A





A



*Adr


A global variable holding the IP address of last recently accepted client.
See also listen and accept.


: *Adr
-> "127.0.0.1"




(adr 'var) -> num


(adr 'num) -> var


Converts, in the first form, a variable var (a symbol or a cons
pair) into num (actually an encoded pointer). This pointer can be
passed to native or struct. The second form converts a pointer
back into the original var. Note that this original
var may be garbage collected if it is not referred from other data,
giving unpredictable results. See also byte.


: (setq X (box 7))
-> $370237372176
: (adr X)
-> 533244889064
: (adr @)
-> $370237372176
: (val @)
-> 7
: (struct (adr X) 'N)
-> 114
$: (struct (adr X) T)
-> 7




*Allow


A global variable holding allowed access patterns. If its value is
non-NIL, it should contain a list where the CAR is an idx tree of allowed items, and the CDR a list of
prefix strings. See also allow,
allowed and pre?.


: (allowed ("app/")  # Initialize
   "!start" "!stop" "lib.css" "!psh" )
-> NIL
: (allow "!myFoo")  # additional item
-> "!myFoo"
: (allow "myDir/" T)  # additional prefix
-> "myDir/"

: *Allow
-> (("!start" ("!psh" ("!myFoo")) "!stop" NIL "lib.css") "app/" "myDir/")

: (idx *Allow)  # items
-> ("!myFoo" "!psh" "!start" "!stop" "lib.css")
: (cdr *Allow)  # prefixes
-> ("app/" "myDir/")




+Alt


Prefix class specifying an alternative class for a +relation. This allows indexes or other
side effects to be maintained in a class different from the current one. See
also Database.


(class +EuOrd +Ord)                    # EU-specific order subclass
(rel nr (+Alt +Key +Number) +XyOrd)    # Maintain the key in the +XyOrd index




+Any


Class for unspecified relations, a subclass of +relation. Objects of that class accept
and maintain any type of Lisp data. Used often when there is no other suitable
relation class available. See also Database.


In the following example +Any is used simply for the reason that
there is no direct way to specify dotted pairs:


(rel loc (+Any))  # Locale, e.g. ("DE" . "de")




+Aux


Prefix class maintaining auxiliary keys for +relations, in addition to +Ref or +Idx indexes. Expects a list of auxiliary
attributes of the same object, and combines all keys in that order into a single
index key. See also +UB, aux and Database.


(rel nr (+Ref +Number))                # Normal, non-unique index
(rel nm (+Aux +Ref +String) (nr txt))  # Combined name/number/text index
(rel txt (+Aux +Sn +Idx +String) (nr)) # Text/number plus tolerant text index




(abort 'cnt . prg) -> any


Aborts the execution of prg if it takes longer than
cnt seconds, and returns NIL. Otherwise, the result of
prg is returned. alarm
is used internally, so care must be taken not to interfer with other calls to
alarm.


: (abort 20 (in Sock (rd)))  # Wait maximally 20 seconds for socket data




(abs 'num) -> num


Returns the absolute value of the num argument.


: (abs -7)
-> 7
: (abs 7)
-> 7




(accept 'cnt) -> cnt | NIL


Accepts a connection on descriptor cnt (as received by port), and returns the new socket descriptor
cnt. The global variable *Adr is set to the IP address
of the client. See also listen,
connect and *Adr.


: (setq *Socket
   (accept (port 6789)) )  # Accept connection at port 6789
-> 4




(accu 'var 'any 'num ['var2])


Accumulates num into a sum, using the key any in
an association list stored in var. If var2 is given,
it is used as an idx for faster
lookups. See also assoc.


: (off Sum)
-> NIL
: (accu 'Sum 'a 1)
-> (a . 1)
: (accu 'Sum 'a 5)
-> 6
: (accu 'Sum 22 100)
-> NIL
: Sum
-> ((22 . 100) (a . 6))




(acquire 'sym) -> flg


Tries to acquire the mutex represented by the file sym, by
obtaining an exclusive lock on that file with ctl, and then trying to write the PID of the
current process into that file. It fails if the file already holds the PID of
some other existing process. See also release, *Pid and rc.


: (acquire "sema1")
-> 28255




(alarm 'cnt . prg) -> cnt


Sets an alarm timer scheduling prg to be executed after
cnt seconds, and returns the number of seconds remaining until any
previously scheduled alarm was due to be delivered. Calling (alarm
0) will cancel an alarm. See also abort, sigio, *Hup, *Winch, *Sig[12], *TStp[12] and *Term.


: (prinl (tim$ (time) T)) (alarm 10 (prinl (tim$ (time) T)))
16:36:14
-> 0
: 16:36:24

: (alarm 10 (bye 0))
-> 0
$




(align 'cnt 'any) -> sym


(align 'lst 'any ..) -> sym


Returns a transient symbol with all any arguments packed in an aligned format. In the first form,
any will be left-aligned if cnt is negative, otherwise
right-aligned. In the second form, all any arguments are packed
according to the numbers in lst. See also tab, center and wrap.


: (align 4 "a")
-> "   a"
: (align -4 12)
-> "12  "
: (align (4 4 4) "a" 12 "b")
-> "   a  12   b"




(all ['T | '0 | 'sym]) -> lst


Returns a new list of all internal symbols
in the current namespace search order (if called without arguments, or with
NIL), all current transient
symbols (if the argument is T), all external symbols (if the argument is zero), or all
symbols of the given namespace sym. See also symbols and all*.


: (all)  # All internal symbols
-> (inc> leaf nil inc! accept ...

# Find all symbols starting with an underscore character
: (filter '((X) (= "_" (car (chop X)))) (all))
-> (_put _nacs _oct _lintq _lst _map _iter _dbg2 _getLine _led ...




(all* 'any ['flg]) -> lst


Returns a sorted list of all (possibly namespaced) symbols and path names
starting with the characters in any. If flg is
T, only symbols, and if it is 0, only path names are
returned. Typically used in TAB-completion routines. See also all, symbols and intern.


: (all* "map")
-> ("map" "map/3" "mapc" "mapcan" "mapcar" "mapcon" "maplist" "maps")
: (all* "llvm~BLK")
-> ("llvm~BLK" "llvm~BLKMASK" "llvm~BLKSIZE" "llvm~BLKTAG")




(allow 'sym ['flg]) -> sym


Maintains an index structure of allowed access patterns in the global
variable *Allow. If the value of
*Allow is non-NIL, sym is added to the
idx tree in the CAR of
*Allow (if flg is NIL), or to the list of
prefix strings (if flg is non-NIL). See also allowed.


: *Allow
-> (("!start" ("!psh") "!stop" NIL "lib.css") "app/")
: (allow "!myFoo")  # additionally allowed item
-> "!myFoo"
: (allow "myDir/" T)  # additionally allowed prefix
-> "myDir/"




(allowed lst [sym ..])


Creates an index structure of allowed access patterns in the global variable
*Allow. lst should
consist of prefix strings (to be checked at runtime with pre?), and the sym arguments
should specify the initially allowed items. Must be called before any GUI
libraries and/or allow calls.


: (allowed ("app/")  # allowed prefixes
   "!start" "!stop" "lib.css" "!psh" )  # allowed items
-> NIL




(and 'any ..) -> any


Logical AND. The expressions any are evaluated from left to
right. If NIL is encountered, NIL is returned
immediately. Else the result of the last expression is returned. See also
nand, or and when.


: (and (= 3 3) (read))
abc  # User input
-> abc
: (and (= 3 4) (read))
-> NIL




(any 'any) -> any


Parses any from the argument. This is the reverse operation of
sym. See also str, (any 'sym) is equivalent to
(car (str 'sym)).


: (any "(a b # Comment\nc d)")
-> (a b c d)
: (any "\"A String\"")
-> "A String"




(append 'lst ..) -> lst


Appends all argument lists. See also conc, insert, delete and remove.


: (append '(a b c) (1 2 3))
-> (a b c 1 2 3)
: (append (1) (2) (3) 4)
-> (1 2 3 . 4)




append/3


Pilog predicate that succeeds if appending the
first two list arguments is equal to the third argument. See also append and member/2.


: (? (append @X @Y (a b c)))
 @X=NIL @Y=(a b c)
 @X=(a) @Y=(b c)
 @X=(a b) @Y=(c)
 @X=(a b c) @Y=NIL
-> NIL




(apply 'fun 'lst ['any ..]) -> any


Applies fun to lst. If additional any
arguments are given, they are applied as leading elements of lst.
(apply 'fun 'lst 'any1 'any2) is equivalent to (apply 'fun
(cons 'any1 'any2 'lst)).


: (apply + (1 2 3))
-> 6
: (apply * (5 6) 3 4)
-> 360
: (apply '((X Y Z) (* X (+ Y Z))) (3 4 5))
-> 27
: (apply println (3 4) 1 2)
1 2 3 4
-> 4




(arg 'cnt) -> any


Can only be used inside functions with a variable number of arguments (with
@). Returns the cnt'th remaining argument. See also
next, args, rest and pass.


: (de foo @
   (println (arg 1) (arg 2))
   (println (next))
   (println (arg 1) (arg 2)) )
-> foo
: (foo 'a 'b 'c)
a b
a
b c
-> c




(args) -> flg


Can only be used inside functions with a variable number of arguments (with
@). Returns T when there are more arguments to be
fetched from the internal list. See also next, arg, rest and pass.


: (de foo @ (println (args)))       # Test for arguments
-> foo
: (foo)                             # No arguments
NIL
-> NIL
: (foo NIL)                         # One argument
T
-> T
: (foo 123)                         # One argument
T
-> T




(argv [var ..] [. sym]) -> lst|sym


If called without arguments, argv returns a list of strings
containing all remaining command line arguments. Otherwise, the
var/sym arguments are subsequently bound to the command line
arguments. A hyphen "-" can be used to inhibit the automatic
loading further arguments. See also cmd, Invocation and
opt.


$ pil -"println 'OK" - abc 123 +
OK
: (argv)
-> ("abc" "123")
: (argv A B)
-> "123"
: A
-> "abc"
: B
-> "123"
: (argv . Lst)
-> ("abc" "123")
: Lst
-> ("abc" "123")




(as 'any1 . any2) -> any2 | NIL


Returns any2 unevaluated when any1 evaluates to
non-NIL. Otherwise NIL is returned. (as Flg A B
C) is equivalent to (and Flg '(A B C)). as is
typically used in read-macros to conditionally
exclude sub-expressions. See also quote.


: (as (= 3 3) A B C)
-> (A B C)

(de foo ()
   (doSomething)
   ~(as (someConditio)
      (doThis)
      (doThat) )
   (doMore) )




(asoq 'any 'lst) -> lst


Searches an association list. Returns the first element from
lst with any as its CAR, or NIL if no
match is found. == is used for
comparison (pointer equality). See also assoc, rasoq, get, push1q, delq, memq, mmeq and Comparing.


: (asoq 'a '((999 1 2 3) (b . 7) ("ok" "Hello")))
-> NIL
: (asoq 'b '((999 1 2 3) (b . 7) ("ok" "Hello")))
-> (b . 7)




(assert exe ..) -> prg | NIL


When in debug mode (*Dbg is
non-NIL), assert returns a prg list which
tests all exe conditions, and issues an error via quit if one of the results evaluates to
NIL. Otherwise, NIL is returned. Used typically in
combination with the ~ tilde read-macro to insert the test code only when
in debug mode. See also test.


# Start in debug mode
$ pil +
: (de foo (N)
   ~(assert (>= 90 N 10))
   (bar N) )
-> foo
: (pp 'foo)                      # Pretty-print 'foo'
(de foo (N)
   (unless (>= 90 N 10)          # Assertion code exists
      (quit "'assert' failed" '(>= 90 N 10)) )
   (bar N) )
-> foo
: (foo 7)                        # Try it
(>= 90 N 10) -- Assertion failed
?

# Start in non-debug mode
$ pil
: (de foo (N)
   ~(assert (>= 90 N 10))
   (bar N) )
-> foo
: (pp 'foo)                      # Pretty-print 'foo'
(de foo (N)
   (bar N) )                     # Assertion code does not exist
-> foo




(asserta 'lst) -> lst


Inserts a new Pilog fact or rule before all
other rules. See also be, clause, assertz and retract.


: (be a (2))            # Define two facts
-> a
: (be a (3))
-> a

: (asserta '(a (1)))    # Insert new fact in front
-> ((1))

: (? (a @N))            # Query
 @N=1
 @N=2
 @N=3
-> NIL




asserta/1


Pilog predicate that inserts a new fact or rule
before all other rules. See also asserta, assertz/1 and retract/1.


: (? (asserta (a (2))))
-> T
: (? (asserta (a (1))))
-> T
: (rules 'a)
1 (be a (1))
2 (be a (2))
-> a




(assertz 'lst) -> lst


Appends a new Pilog fact or rule behind all
other rules. See also be, clause, asserta and retract.


: (be a (1))            # Define two facts
-> a
: (be a (2))
-> a

: (assertz '(a (3)))    # Append new fact at the end
-> ((3))

: (? (a @N))            # Query
 @N=1
 @N=2
 @N=3
-> NIL




assertz/1


Pilog predicate that appends a new fact or rule
behind all other rules. See also assertz, asserta/1 and retract/1.


: (? (assertz (a (1))))
-> T
: (? (assertz (a (2))))
-> T
: (rules 'a)
1 (be a (1))
2 (be a (2))
-> a




(assoc 'any 'lst) -> lst


Searches an association list. Returns the first element from
lst with its CAR equal to any, or NIL if
no match is found. See also asoq and
rassoc.


: (assoc "b" '((999 1 2 3) ("b" . 7) ("ok" "Hello")))
-> ("b" . 7)
: (assoc 999 '((999 1 2 3) ("b" . 7) ("ok" "Hello")))
-> (999 1 2 3)
: (assoc 'u '((999 1 2 3) ("b" . 7) ("ok" "Hello")))
-> NIL




(at '(cnt1 . cnt2|NIL) . prg) -> any


Increments cnt1 (destructively), and returns NIL
when it is less than cnt2. Both cnt1 and
cnt2 should be positive. Otherwise, cnt1 is reset to
zero and prg is executed. Returns the result of prg.
If cnt2 is NIL, nothing is done, and NIL
is returned immediately.


: (do 11 (prin ".") (at (0 . 3) (prin "!")))
...!...!...!..-> NIL




(atom 'any) -> flg


Returns T when the argument any is an atom (a
number or a symbol). See also num?,
sym? and pair.


: (atom 123)
-> T
: (atom 'a)
-> T
: (atom NIL)
-> T
: (atom (123))
-> NIL




(aux 'sym 'cls ['hook] 'any ..) -> sym


Returns a database object of class cls, where the value for
sym corresponds to any and the following arguments.
sym, cls and hook should specify a
tree for cls or one of
its superclasses, for a relation with auxiliary keys. For multi-key accesses,
aux is similar to - but faster than - db, because it
can use a single tree access. See also db, collect, fetch, init, step and +Aux.


(class +PS +Entity)
(rel par (+Dep +Joint) (sup) ps (+Part))        # Part
(rel sup (+Aux +Ref +Link) (par) NIL (+Supp))   # Supplier
...
   (aux 'sup '+PS                               # Access PS object
      (db 'nr '+Supp 1234)
      (db 'nr '+Part 5678) )







================================================
FILE: doc/refB.html
================================================
B
B



*Blob


A global variable holding the pathname of the database blob directory. See
also blob.


: *Blob
-> "blob/app/"




*Bye


A global variable holding a (possibly empty) prg body, to be
executed just before the termination of the PicoLisp interpreter. See also
bye, finish and tmp.


: (push1 '*Bye '(call "rm" "myfile.tmp"))  # Remove a temporary file
-> (call 'rm "myfile.tmp")




+Bag


Class for a list of arbitrary relations, a subclass of +relation. Objects of that class maintain
a list of heterogeneous relations. Typically used in combination with the
+List prefix class, to maintain small
two-dimensional tables within objects. See also Database.


(rel pos (+List +Bag)         # Positions
   ((+Ref +Link) NIL (+Item))    # Item
   ((+Number) 2)                 # Price
   ((+Number))                   # Quantity
   ((+String))                   # Memo text
   ((+Number) 2) )               # Total amount




+Blob


Class for blob relations, a subclass of +relation. Objects of that class maintain
blobs, as stubs in database objects pointing to actual files for arbitrary
(often binary) data. The files themselves reside below the path specified by the
*Blob variable. See also Database.


(rel jpg (+Blob))  # Picture




+Bool


Class for boolean relations, a subclass of +relation. Objects of that class expect
either T or NIL as value (though, as always, only
non-NIL will be physically stored in objects). See also Database.


(rel ok (+Ref +Bool))  # Indexed flag




(balance 'var 'lst ['flg])


Builds a balanced binary idx tree
in var, from the sorted list in lst. Normally, if
arbitary - or, in the worst case, ordered - data are inserted with
idx, the tree will not be balanced. But if lst is
properly sorted, its contents will be inserted in an optimally balanced way. If
flg is non-NIL, the index tree will be augmented
instead of being overwritten. See also Comparing and sort.


# Normal idx insert
: (off I)
-> NIL
: (for X (1 4 2 5 3 6 7 9 8) (idx 'I X T))
-> NIL
: (depth I)
-> (7 . 4)

# Balanced insert
: (balance 'I (sort (1 4 2 5 3 6 7 9 8)))
-> NIL
: (depth I)
-> 4

# Augment
: (balance 'I (sort (10 40 20 50 30 60 70 90 80)) T)
-> NIL
: (idx 'I)
-> (1 2 3 4 5 6 7 8 9 10 20 30 40 50 60 70 80 90)




(basename 'any) -> sym


Returns the filename part of a path name any. See also dirname and path.


: (basename "a/b/c/d")
-> "d"




(be sym . any) -> sym


Declares a Pilog fact or rule for the
sym argument, by concatenating the any argument to the
T property of sym. Groups of declarations are
collected for a given sym. When sym changes, i.e. when
it differs from the one in the previous declaration, the current group is
considered to be complete and a new group is started. Later be
declarations for a previously completed symbol will reset its rules, to allow
repeated reloading of source files.
See also *Rule, clause, asserta, assertz, retract, rules, goal and prove.


: (be likes (John Mary))
-> likes
: (be likes (John @X) (likes @X wine) (likes @X food))
-> likes

: (get 'likes T)
-> (((John Mary)) ((John @X) (likes @X wine) (likes @X food)))

: (rules 'likes)
1 (be likes (John Mary))
2 (be likes (John @X) (likes @X wine) (likes @X food))
-> likes

: (? (likes John @X))
 @X=Mary
-> NIL




(beep) -> NIL


Send the bell character to the console. See also space, prin and char.


: (beep)
-> NIL




(bench . prg) -> any


(Debug mode only) Benchmarks prg, by printing the time it took
to execute, and returns the result. See also usec.


: (bench (wait 2000))
2.003 sec
-> NIL

: (bench (wait 123456))
[00:02] 123.557 sec
-> NIL




(bin 'num ['num]) -> sym


(bin 'sym) -> num


Converts a number num to a binary string, or a binary string
sym to a number. In the first case, if the second argument is
given, the result is separated by spaces into groups of such many digits. See
also oct, hex, hax and format.


: (bin 73)
-> "1001001"
: (bin "1001001")
-> 73
: (bin 1234567 4)
-> "1 0010 1101 0110 1000 0111"




(bind 'sym|lst . prg) -> any


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
saved (and the symbols bound to the values in the case of pairs),
prg is executed, then the symbols are restored to their original
values. During execution of prg, the values of the symbols can be
temporarily modified. The return value is the result of prg. See
also let, job and use.


: (setq X 123)                               # X is 123
-> 123
: (bind 'X (setq X "Hello") (println X))  # Set X to "Hello", print it
"Hello"
-> "Hello"
: (bind '((X . 3) (Y . 4)) (println X Y) (* X Y))
3 4
-> 12
: X
-> 123                                       # X is restored to 123




(bit? 'num ..) -> num | NIL


Returns the first num argument when all bits which are 1 in the
first argument are also 1 in all following arguments, otherwise
NIL. When one of those arguments evaluates to NIL, it
is returned immediately. See also &,
| and x|.


: (bit? 7 15 255)
-> 7
: (bit? 1 3)
-> 1
: (bit? 1 2)
-> NIL




(blk 'fd 'cnt 'siz ['fd2]) -> lst


(blk 'fd 0) -> (cnt . siz)


Reads raw object data from the cnt'th block in the file open on
descriptor fd. Returns a cons pair of the value and property list
of that database object, or NIL for an invalid block. If
cnt is zero, a cons pair of the total number of blocks in the file
and the file's block size scale factor is returned. Otherwise, siz
should be the block size scale factor. If fd2 is given, a read
(shared) lock is set on that file during the read operation. See also pool, pool2, id, ctl
and qsym.


: (show '{4})
{4} (+Role)
   usr ({15} {13} {11})
   perm (Customer Item Order Report ..)
   nm "Accounting"
-> {4}
: (open "db/app/@")
-> 15
: (blk 15 4 3 15)
-> ((+Role) (({15} {13} {11}) . usr) ((Customer Item Order Report Delete) . perm) ("Accounting" . nm))




(blob 'obj 'sym) -> sym


Returns the blob file name for var in obj. See
also *Blob, blob! and pack.


: (show (db 'nr '+Item 1))
{B1} (+Item)
   jpg
   pr 29900
   inv 100
   sup {C1}
   nm "Main Part"
   nr 1
-> {B1}
: (blob '{B1} 'jpg)
-> "blob/app/3/-/1.jpg"




(blob! 'obj 'sym 'file)


Stores the contents of file in a blob. See also put!>.


(blob! *ID 'jpg "picture.jpg")




(bool 'any) -> flg


Returns T when the argument any is
non-NIL. This function is only needed when T is
strictly required for a "true" condition (Usually, any non-NIL
value is considered to be "true"). See also flg?.


: (and 3 4)
-> 4
: (bool (and 3 4))
-> T




bool/3


(Deprecated since version 25.5.30) Pilog
predicate that succeeds if the first argument has the same truth value as the
result of applying the get algorithm to
the following arguments. Typically used as filter predicate in select/3 database queries. See also
bool, isa/2, same/3, range/3, head/3, fold/3, part/3 and tolr/3.


: (? @OK T           # Find orders where the 'ok' flag is set
   (db nr +Ord @Ord)
   (bool @OK @Ord ok) )
 @OK=T @Ord={B7}
-> NIL




(box 'any) -> sym


Creates and returns a new anonymous symbol. The initial value is set to the
any argument. See also new
and box?.


: (show (box '(A B C)))
$134425627 (A B C)
-> $134425627




(box? 'any) -> sym | NIL


Returns the argument any when it is an anonymous symbol,
otherwise NIL. See also box, str? and ext?.


: (box? (new))
-> $134563468
: (box? 123)
-> NIL
: (box? 'a)
-> NIL
: (box? NIL)
-> NIL




(bt ['flg]) -> flg


(Debug mode only) Formatted stack backtrace printing (see trail) for the current point of program
execution. For each bind frame, the function call (reduced with less) is pretty-printed, followed by indented
variable-value-pairs. If flg is NIL, bt
then waits for a key, and terminates when ESC is pressed (like more). See also up and env.


: (de f (A B)
   (let F 7
      (g (inc A) (dec B)) ) )
-> f
: (de g (C D)
   (let G 8
      (/ C D) ) )
-> g

: (f 2 1)
!? (/ C D)
Div/0
? (bt)
(g (inc A) (dec B))
   C 3
   D 0
   G 8
(f 2 1)
   A 2
   B 1
   F 7
-> NIL
?




(buf sym 'cnt . prg) -> any


Creates a temporary local memory buffer on the stack, and binds
sym to the pointer during the execution of prg. The
current value of sym is saved and restored appropriately. The
return value is the result of prg. See also let, native, struct and %@.


(buf Buf BUFSIZ
   (%@ "read" 'I Fd Buf BUFSIZ)
   (%@ "write" 'I Fd2 Buf BUFSIZ) )



This is functionally equivalent to (but more efficient than)


(let Buf (%@ "malloc" 'P BUFSIZ)
   (%@ "read" 'I Fd Buf BUFSIZ)
   (%@ "write" 'I Fd2 Buf BUFSIZ)
   (%@ "free" NIL Buf) )




(by 'fun1 'fun2 'lst ..) -> lst


Applies fun1 to each element of lst. When
additional lst arguments are given, their elements are also passed
to fun1. Each result of fun1 is CONSed with its
corresponding argument from the original lst, and collected into a
list which is passed to fun2. For the list returned from
fun2, the CAR elements returned by fun1 are
(destructively) removed from each element ("decorate-apply-undecorate" idiom).


: (let (A 1 B 2 C 3) (by val sort '(C A B)))
-> (A B C)
: (by '((N) (bit? 1 N)) group (3 11 6 2 9 5 4 10 12 7 8 1))
-> ((3 11 9 5 7 1) (6 2 4 10 12 8))




(bye ['cnt])


Executes all pending finally
expressions, closes all open files, executes the VAL of the global
variable *Bye (should be a
prg), flushes standard output, and then exits the PicoLisp
interpreter. The process return value is cnt, or 0 if the argument
is missing or NIL.


: (setq *Bye '((println 'OK) (println 'bye)))
-> ((println 'OK) (println 'bye))
: (bye)
OK
bye
$




(byte 'num ['cnt]) -> cnt


Returns - if the second argument is not given - a byte value (0 .. 255) from
the memory location pointed to by num. Otherwise cnt
is stored in the memory location and returned. See also adr.


: (hex (byte (>> -4 (adr (1)))))
-> "12"                             # Short number '1'
: (hex (byte (>> -4 (adr (2)))))
-> "22"                             # Short number '2'

: (setq P (native "@" "malloc" 'N 8))  # Set pointer to a new buffer
-> 25084048
: (byte P (char "A"))                  # Store byte 'A'
-> 65
: (byte (inc P) (char "B"))            # Store byte 'B'
-> 66
: (byte (+ P 2) (char "C"))            # Store byte 'C'
-> 67
: (byte (+ P 3) 0)                     # Store null byte
-> 0
: (native "@" "strdup" 'S P)           # Read bytes as string
-> "ABC"
: (native "@" "free" 'N P)             # Free buffer
-> 0




(bytes 'any) -> cnt


Returns the number of bytes any would occupy in encoded binary
format (as generated by pr). See also
size and length.


: (bytes "abc")
-> 4
: (bytes "äbc")
-> 5
: (bytes 127)
-> 2
: (bytes 128)
-> 3
: (bytes (101 (102) 103))
-> 10
: (bytes (101 102 103 .))
-> 9







================================================
FILE: doc/refC.html
================================================
C
C



*CPU


A global variable holding the target CPU (architecture). Typical values are
"aarch64", "x86-64" etc. See also *OS and version.


: *CPU
-> "x86-64"




*Class


A global variable holding the current class. See also OO Concepts, class, extend, dm and var and rel.


: (class +Test)
-> +Test
: *Class
-> +Test




(cache 'var 'any [. prg]) -> any


Speeds up some calculations by maintaining a tree of previously calculated
results in an idx structure
("memoization") in var. A hash of the argument any is used
internally to build the index key. If no prg is given, the internal
var holding a previously stored value is returned (note that
var may have a name which is not human-readable).


: (de fibonacci (N)
   (cache '(NIL) N
      (if (>= 2 N)
         1
         (+ (fibonacci (dec N)) (fibonacci (- N 2))) ) ) )
-> fibonacci

: (fibonacci 22)
-> 17711

: (fibonacci 10000)
-> 3364476487643178326662161200510754331030 ...  # (2090 digits)




: (off C)
-> NIL
: (cache 'C 1234 (* 3 4))
-> 12
: (inc (cache 'C 1234))
-> 13
: (val (cache 'C 1234))
-> 13




(call 'any ..) -> flg


Calls an external system command. The any arguments specify the
command and its arguments. Returns T if the command was executed
successfully. The (system dependent) exit status code of the child process is
stored in the global variable @@. See
also exec.


: (when (call 'test "-r" "file.l")  # Test if file exists and is readable
   (load "file.l")  # Load it
   (call 'rm "file.l") )  # Remove it

: (cons (call "sh" "-c" "kill -SEGV $$") @@ (hex @@))
-> (NIL 11 . "B")




call/1


Pilog predicate that succeeds if the argument
term can be proven.


: (be mapcar (@ NIL NIL))
-> mapcar
: (be mapcar (@P (@X . @L) (@Y . @M))
   (call @P @X @Y)                        # Call the given predicate
   (mapcar @P @L @M) )
-> mapcar
: (? (mapcar permute ((a b c) (d e f)) @X))
 @X=((a b c) (d e f))
 @X=((a b c) (d f e))
 @X=((a b c) (e d f))
 ...
 @X=((a c b) (d e f))
 @X=((a c b) (d f e))
 @X=((a c b) (e d f))
 ...




(can 'msg) -> lst


(Debug mode only) Returns a list of all classes that accept the message
msg. See also OO Concepts, class, has, dep, what and who.


: (can 'zap>)
-> ((zap> . +relation) (zap> . +Blob) (zap> . +Entity))
: (more @ pp)
(dm (zap> . +relation) (Obj Val))

(dm (zap> . +Blob) (Obj Val)
   (and
      Val
      (call 'rm "-f" (blob Obj (: var))) ) )

(dm (zap> . +Entity) NIL
   (for X (getl This)
      (let V (or (atom X) (pop 'X))
         (and (meta This X) (zap> @ This V)) ) ) )

-> NIL




(car 'var) -> any


List access: Returns the value of var if it is a symbol, or the
first element if it is a list. See also cdr and c..r.


: (car (1 2 3 4 5 6))
-> 1

































(c[ad]*ar 'var) -> any


(c[ad]*dr 'lst) -> any


List access shortcuts. Combinations of the car and cdr functions, with up to four letters 'a' and
'd'.


: (cdar '((1 . 2) . 3))
-> 2




(case 'any (any1 . prg1) (any2 . prg2) ..) -> any


Multi-way branch: any is evaluated and compared to the CAR
elements anyN of each clause. If one of them is a list,
any is in turn compared to all elements of that list.
T is a catch-all for any value. If a comparison succeeds,
prgN is executed, and the result returned. Otherwise
NIL is returned. See also casq and state .


: (case (char 66) ("A" (+ 1 2 3)) (("B" "C") "Bambi") ("D" (* 1 2 3)))
-> "Bambi"
: (case 'b (a 1) ("b" 2) (b 3) (c 4))
-> 2




(casq 'any (any1 . prg1) (any2 . prg2) ..) -> any


Multi-way branch: any is evaluated and compared to the CAR
elements anyN of each clause. == is used for comparison (pointer equality). If
one of them is a list, any is in turn compared to all elements of
that list. T is a catch-all for any value. If a comparison
succeeds, prgN is executed, and the result returned. Otherwise
NIL is returned. See also case and state.


: (casq 'b (a 1) ("b" 2) (b 3) (c 4))
-> 3
: (casq 'b (a 1) ("b" 2) ((a b c) 3) (c 4))
-> 3




(catch 'any . prg) -> any


Sets up the environment for a non-local jump which may be caused by throw or by a runtime error. If
any is an atom, it is used by throw as a jump label
(with T being a catch-all for any label), and a throw
called during the execution of prg will immediately return the
thrown value. Otherwise, any should be a list of strings, to catch
any error whose message contains one of these strings, and
catch will immediately return the matching string. If
neither throw nor an error occurred, the result of
prg is returned. The global variable @@ is set to T if a
throw or error occurred, otherwise NIL. See
also finally, quit, if@@ and Error Handling.


: (catch 'OK (println 1) (throw 'OK 999) (println 2))
1
-> 999
: (catch '("No such file") (in "doesntExist" (foo)))
-> "No such file"




Pattern for catching and logging errors:


(if@@
   (catch '(NIL)
      (...) )
   (nil (msg *Msg))  # If an error was thrown, log it and return NIL
   @ ) ) )  # else return the value returned from catch




(cd 'any) -> sym


Changes the current directory to any. The old directory is
returned on success, otherwise NIL. See also chdir, dir and pwd.


: (when (cd "lib")
   (println (length (dir)))
   (cd @) )
99




(cdr 'lst) -> any


List access: Returns all but the first element of lst. See also
car and c..r.


: (cdr (1 2 3 4 5 6))
-> (2 3 4 5 6)




(center 'cnt|lst 'any ..) -> sym


Returns a transient symbol with all any arguments packed in a centered format. Trailing blanks
are omitted. See also align, tab and wrap.


: (center 4 12)
-> " 12"
: (center 4 "a")
-> " a"
: (center 7 "a")
-> "   a"
: (center (3 3 3) "a" "b" "c")
-> " a  b  c"




(chain 'any ..) -> any


Concatenates (destructively) one or several new list elements
any to the end of the list in the current make environment. This operation is efficient
also for long lists, because a pointer to the last element of the result list is
maintained. chain returns the last linked argument. See also
link, yoke and made.


: (make (chain (list 1 2 3) NIL (cons 4)) (chain (list 5 6)))
-> (1 2 3 4 5 6)




(char) -> sym


(char 'cnt) -> sym


(char T) -> sym


(char 'sym) -> cnt


When called without arguments, the next character from the current input
stream is returned as a single-character transient symbol, or NIL
upon end of file. When called with a number cnt, a character with
the corresponding unicode value is returned. As a special case, T
is accepted to produce a byte value greater than any first byte in a UTF-8
character (used as a top value in comparisons). Otherwise, when called with a
symbol sym, the numeric unicode value of the first character of the
name of that symbol is returned. See also peek, skip, key, line, till and eof.


: (char)                   # Read character from console
A                          # (typed 'A' and a space/return)
-> "A"
: (char 100)               # Convert unicode to symbol
-> "d"
: (char "d")               # Convert symbol to unicode
-> 100

: (char T)                 # Special case
-> # (not printable)

: (char 0)
-> NIL
: (char NIL)
-> 0




(chdir 'any . prg) -> any


Changes the current directory to any with cd during the execution of prg. Then
the previous directory will be restored and the result of prg
returned. See also dir and pwd.


: (pwd)
-> "/usr/abu/pico"
: (chdir "src" (pwd))
-> "/usr/abu/pico/src"
: (pwd)
-> "/usr/abu/pico"




(chkTree 'sym ['fun]) -> num


Checks a database tree node (and recursively all sub-nodes) for consistency.
Returns the total number of nodes checked. Optionally, fun is
called with the key and value of each node, and should return NIL
for failure. See also tree and
root.


: (show *DB '+Item)
{40} 6
   nr (6 . {H1})
   pr (6 . {H3})
   sup (6 . {H2})
   nm (67 . {I3})
-> {40}
: (chkTree '{H1})   # Check that node
-> 6




(chop 'any) -> lst


Returns any as a list of single-character strings. If
any is NIL or a symbol with no name, NIL
is returned. A list argument is returned unchanged.


: (chop 'car)
-> ("c" "a" "r")
: (chop "Hello")
-> ("H" "e" "l" "l" "o")




(circ 'any ..) -> lst


Produces a circular list of all any arguments by consing them to a list and then connecting the
CDR of the last cell to the first cell. See also circ? and list.


: (circ 'a 'b 'c)
-> (a b c .)




(circ? 'any) -> any


Returns the circular list tail if any is a circular list, else
NIL. See also circ.


: (circ? 'a)
-> NIL
: (circ? (1 2 3))
-> NIL
: (circ? (1 . (2 3 .)))
-> (2 3 .)




(class sym . typ) -> obj


Defines sym as a class with the superclass(es)
typ. As a side effect, the global variable *Class is set to obj. See also
extend, dm, var,
rel, type, isa and object.


: (class +A +B +C +D)
-> +A
: +A
-> (+B +C +D)
: (dm foo> (X) (bar X))
-> foo>
: +A
-> ((foo> (X) (bar X)) +B +C +D)




(clause '(sym . any)) -> sym


Declares a Pilog fact or rule for the
sym argument, by concatenating the any argument to the
T property of sym. See also *Rule and be.


: (clause '(likes (John Mary)))
-> likes
: (clause '(likes (John @X) (likes @X wine) (likes @X food)))
-> likes
: (? (likes @X @Y))
 @X=John @Y=Mary
-> NIL




clause/2


Pilog predicate that succeeds if the first
argument is a predicate which has the second argument defined as a clause.


: (? (clause append ((NIL @X @X))))
-> T

: (? (clause append @C))
 @C=((NIL @X @X))
 @C=(((@A . @X) @Y (@A . @Z)) (append @X @Y @Z))
-> NIL




(clip 'lst) -> lst


Returns a copy of lst with all whitespace characters or
NIL elements removed from both sides. See also trim.


: (clip '(NIL 1 NIL 2 NIL))
-> (1 NIL 2)
: (clip '(" " a " " b " "))
-> (a " " b)




(close 'cnt) -> cnt | NIL


Closes a file descriptor cnt, and returns it when successful.
Should not be called inside an out body
for that descriptor. See also open,
poll,
listen and connect.


: (close 2)                            # Close standard error
-> 2




(cmd ['any]) -> sym


When called without an argument, the name of the command that invoked the
picolisp interpreter is returned. Otherwise, the command name is set to
any. 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 argv, file and Invocation.


$ pil +
: (cmd)
-> "/usr/bin/picolisp"
: (cmd "!/bin/picolust")
-> "!/bin/picolust"
: (cmd)
-> "!/bin/picolust"




(cnt 'fun 'lst ..) -> cnt


Applies fun to each element of lst. When
additional lst arguments are given, their elements are also passed
to fun. Returns the count of non-NIL values returned
from fun.


: (cnt cdr '((1 . T) (2) (3 4) (5)))
-> 2




(co ['any [. prg]]) -> any


Starts, resumes or stops a coroutine with
the tag given by any. If called without arguments, the tag of the
currently running coroutine is returned. If prg is not given, a
coroutine with that tag will be stopped. Otherwise, if a coroutine running with
that tag is found (pointer equality is used for comparison), its execution is
resumed. Else a new coroutine with that tag is initialized and started.
prg will be executed until it either terminates normally, or until
yield is called. In the latter case
co returns, or transfers control to some other, already running,
coroutine. A coroutine cannot call or stop itself directly or indirectly. See
also stack, catch and throw.


: (de pythag (N)   # A generator function
   (if (=T N)
      (co 'rt)  # Stop
      (co 'rt
         (for X N
            (for Y (range X N)
               (for Z (range Y N)
                  (when (= (+ (* X X) (* Y Y)) (* Z Z))
                     (yield (list X Y Z)) ) ) ) ) ) ) )

: (pythag 20)
-> (3 4 5)
: (pythag 20)
-> (5 12 13)
: (pythag 20)
-> (6 8 10)





(collect 'sym 'cls ['hook] ['any|beg ['end [sym|cnt ..]]])


Returns a list of all database objects of class cls, where the
values for the sym arguments correspond to the any
arguments, or where the values for the sym arguments are in the
range beg .. end. sym, cls
and hook should specify a tree for cls or one of its
superclasses. If additional sym|cnt arguments are given, the final
values for the result list are obtained by applying the get algorithm. See also db, aux,
fetch, init, step and and search.


: (collect 'nr '+Item)
-> ({B1} {B2} {B3} {B4} {B5} {B6} {B8})
: (collect 'nr '+Item 3 6 'nr)
-> (3 4 5 6)
: (collect 'nr '+Item 3 6 'nm)
-> ("Auxiliary Construction" "Enhancement Additive" "Metal Fittings" "Gadget Appliance")
: (collect 'nm '+Item "Main Part")
-> ({B1})




(commit ['any] [exe1] [exe2]) -> T


Closes a transaction, by writing all new or modified external symbols to,
and removing all deleted external symbols from the database. When
any is given, it is implicitly sent (with all modified objects) via
the tell mechanism to all family
members. If exe1 or exe2 are given, they are executed
as pre- or post-expressions while the database is locked and protected. See also rollback.


: (pool "db")
-> T
: (put '{1} 'str "Hello")
-> "Hello"
: (commit)
-> T




(complete 'any) -> T | lst


Global variable holding a (possibly empty) function, which will be
called when TAB is pressed in readline(3) to complete the
text before the current input point. If it is NIL,
readline's default filename generator function is used. Otherwise, it
should be a function which returns the next match (if any
is NIL), some default value (if any is
T, meaning there is no partial word to be completed), or
initializes the generator with the given text and returns the first
result.


: (pp 'complete)
(de complete (S)
   (when S
      (setq "*Cmpl"
         (if (=T S) (list "   ") (flip (all* S))) ) )
   (pop '"*Cmpl") )
-> complete




(con 'lst 'any) -> any


Connects any to the first cell of lst, by
(destructively) storing any in the CDR of lst. See
also set and conc.


: (setq C (1 . a))
-> (1 . a)
: (con C '(b c d))
-> (b c d)
: C
-> (1 b c d)




(conc 'lst ..) -> lst


Concatenates all argument lists (destructively). See also append and con.


: (setq  A (1 2 3)  B '(a b c))
-> (a b c)
: (conc A B)                        # Concatenate lists in 'A' and 'B'
-> (1 2 3 a b c)
: A
-> (1 2 3 a b c)                    # Side effect: List in 'A' is modified!




(cond ('any1 . prg1) ('any2 . prg2) ..) -> any


Multi-way conditional: If any of the anyN conditions evaluates
to non-NIL, prgN is executed and the result returned.
Otherwise (all conditions evaluate to NIL), NIL is
returned. See also nond, if, and,
if2 and when.


: (cond
   ((= 3 4) (println 1))
   ((= 3 3) (println 2))
   (T (println 3)) )
2
-> 2




(connect 'any1 'any2) -> cnt | NIL


Tries to establish a TCP/IP connection to a server listening at host
any1, port any2. any1 may be either a
hostname or a standard internet address in numbers-and-dots/colons notation
(IPv4/IPv6). any2 may be either a port number or a service name.
Returns a socket descriptor cnt, or NIL if the
connection cannot be established. See also listen and udp.


: (connect "localhost" 4444)
-> 3
: (connect "some.host.org" "http")
-> 4




(cons 'any ['any ..]) -> lst


Constructs a new list cell with the first argument in the CAR and the second
argument in the CDR. If more than two arguments are given, a corresponding chain
of cells is built. (cons 'a 'b 'c 'd) is equivalent to (cons
'a (cons 'b (cons 'c 'd))). See also list.


: (cons 1 2)
-> (1 . 2)
: (cons 'a '(b c d))
-> (a b c d)
: (cons '(a b) '(c d))
-> ((a b) c d)
: (cons 'a 'b 'c 'd)
-> (a b c . d)




(copy 'any) -> any


Copies the argument any. For lists, the top level cells are
copied, while atoms are returned unchanged.


: (=T (copy T))               # Atoms are not copied
-> T
: (setq L (1 2 3))
-> (1 2 3)
: (== L L)
-> T
: (== L (copy L))             # The copy is not identical to the original
-> NIL
: (= L (copy L))              # But the copy is equal to the original
-> T




(count 'tree) -> num


Returns the number of nodes in a database tree. See also tree and root.


: (count (tree 'nr '+Item))
-> 7




(create 'typ 'sym 'lst . prg)


Creates or updates database objects of the type
typ with the properties in sym and lst.
It handles large amounts of data, by sorting and traversing each database index
separately. prg is executed repeatedly - and should return a list
of values for the properties in sym and lst - until it
returns NIL. If the fin of
the list is NIL, a new object of type typ is created,
otherwise it should be an existing object to be updated. If sym is
non-NIL, the first column of the input data is assigned to the
sym property and should already be sorted. The rest of the input
data is assigned to the properties in lst. create
allocates heap memory, and builds temporary files which increase disk
requirements while it runs. No explicit lock should be established on the database, and
no other processes should operate on this database while it runs. When creating
more than a few hundred million index entries per file, it might be necessary to
increase the number of open files with e.g. ulimit -n 10000. See
also dbs, new, commit and prune.


# Minimal E/R model
(class +Cls +Entity)          # Class
(rel key (+Key +Number))      # with a unique numeric key,
(rel num (+Ref +Number))      # an indexed number,
(rel str (+Ref +String))      # and an indexed string

(dbs
   (0 +Cls)
   (4 (+Cls key))             # Each index in a different file
   (4 (+Cls num))
   (4 (+Cls str)) )

# Generating random data
(create '(+Cls) 'key '(num str)
   (co 'go                 # Use a coroutine as generator
      (for Key 100000000   # Key is sorted in input
         (yield            # Return keys, numbers and single-char strings
            (list Key (rand) (char (rand 97 122))) ) ) ) )

# Reading from a file in PLIO format
(create '(+Cls) 'key '(num str)
   (rd) )

# Reading from a TAB-separated CSV file
(create '(+Cls) 'key '(num str)
   (when (split (line) "\t")
      (list
         (format (car @))
         (format (cadr @))
         (pack (caddr @)) ) ) )

# Direct, naive approach (without using 'create')
# Don't try this at home! Takes forever due to disk trashing
(prune 0)
(gc 400 200)
(for Key 100000000
   (new `(db: +Cls) '(+Cls)
      'key Key
      'num (rand)
      'str (char (rand 97 122)) )
   (at (0 . 10000) (commit) (prune 7)) )
(commit)
(prune)
(gc 0)




(ctl 'sym . prg) -> any


Waits until a write (exclusive) lock (or a read (shared) lock if the first
character of sym is "+") can be set on the file
sym, then executes prg and releases the lock. If the
file does not exist, it will be created. When sym is
NIL, a shared lock is tried on the current innermost I/O channel,
and when it is T, an exclusive lock is tried instead. See also
in, out, err and pipe.


$ echo 9 >count                           # Write '9' to file "count"
$ pil +
: (ctl ".ctl"                             # Exclusive control, using ".ctl"
   (in "count"
      (let Cnt (read)                     # Read '9'
         (out "count"
            (println (dec Cnt)) ) ) ) )   # Write '8'
-> 8
:
$ cat count                               # Check "count"
8




(ctty 'pid) -> pid


(ctty 'any) -> any | NIL


Unless called with a short number, ctty changes the current TTY
device to any (or just sets standard I/O to a PTY if
any is NIL). Otherwise, the local console is prepared
for serving the PicoLisp process with the process ID pid. See also
raw.


: (ctty "/dev/tty")
-> "/dev/tty"




(curry lst . fun) -> fun


Builds a new function from the list of symbols or symbol-value pairs
lst and the functional expression fun. Each member in
lst that is a pat? symbol
is substituted inside fun by its value. All other symbols in
lst are collected into a job environment. curry is a general
higher-order function, not limited to strict currying (which generates only
single-argument functions).


: (de multiplier (@X)
   (curry (@X) (N) (* @X N)) )
-> multiplier
: (multiplier 7)
-> ((N) (* 7 N))
: ((multiplier 7) 3)
-> 21

: (def 'fiboCounter
   (curry ((N1 . 0) (N2 . 1)) (Cnt)
      (do Cnt
         (println
            (prog1
               (+ N1 N2)
               (setq N1 N2  N2 @) ) ) ) ) )
-> fiboCounter
: (pp 'fiboCounter)
(de fiboCounter (Cnt)
   (job '((N2 . 1) (N1 . 0))
      (do Cnt
         (println
            (prog1 (+ N1 N2) (setq N1 N2 N2 @)) ) ) ) )
-> fiboCounter
: (fiboCounter 5)
1
2
3
5
8
-> 8
: (fiboCounter 5)
13
21
34
55
89
-> 89




(cut 'cnt 'var) -> lst


Pops the first cnt elements (CAR) from the stack in
var. See also pop,
rid and del.


: (setq S '(1 2 3 4 5 6 7 8))
-> (1 2 3 4 5 6 7 8)
: (cut 3 'S)
-> (1 2 3)
: S
-> (4 5 6 7 8)







================================================
FILE: doc/refD.html
================================================
D
D



*DB


A global variable holding the external symbol {1} (the database root) while a database is open, otherwise
NIL. All external symbols in a database can be reached from that
root. Except during debugging, any explicit literal access to symbols in the
database should be avoided, because otherwise a memory leak might occur (The
garbage collector temporarily sets *DB to NIL and
restores its value after collection, thus disposing of all external symbols not
currently used in the program).


: (show *DB)
{1} NIL
   +City {P}
   +Person {3}
-> {1}
: (show '{P})
{P} NIL
   nm (566 . {AhDx})
-> {P}
: (show '{3})
{3} NIL
   tel (681376 . {Agyl})
   nm (1461322 . {2gu7})
-> {3}




*Dbg


A boolean variable indicating "debug mode". It can be conveniently switched
on with a trailing + command line argument (see Invocation). When non-NIL, the $ (tracing) and ! (breakpoint) functions are enabled, and the
current line number and file name will be stored in symbol properties by
de, def, dm
and symbols. See also debug, trace and lint.


: (de foo (A B) (* A B))
-> foo
: (trace 'foo)
-> foo
: (foo 3 4)
 foo : 3 4
 foo = 12
-> 12
: (let *Dbg NIL (foo 3 4))
-> 12




*Dbs


A global variable holding a list of numbers (block size scale factors, as
needed by pool). It is typically set
by dbs.


: *Dbs
-> (1 2 1 0 2 3 3 3)




+Date


Class for calender dates (as calculated by date), a subclass of +Number. See also Database.


(rel dat (+Ref +Date))  # Indexed date




+Dep


+Joint prefix class for maintaining
dependencies between +relations.
Expects a list of (symbolic) attributes that depend on this relation. Whenever
this relations is cleared (receives a value of NIL), the dependent
relations will also be cleared, triggering all required side-effects. See also
Database.


In the following example, the index entry for the item pointing to the
position (and, therefore, to the order) is cleared in case the order is deleted,
or this position is deleted from the order:


(class +Pos +Entity)                # Position class
(rel ord (+Dep +Joint)              # Order of that position
   (itm)                               # 'itm' specifies the dependency
   pos (+Ord) )                        # Arguments to '+Joint'
(rel itm (+Ref +Link) NIL (+Item))  # Item depends on the order




(d) -> T


(Debug mode only) Inserts !
breakpoints into all subexpressions of the current breakpoint. Typically used
when single-stepping a function or method with debug. See also u and unbug.


! (d)                            # Debug subexpression(s) at breakpoint
-> T




(daemon 'sym . prg) -> fun


(daemon '(sym . cls) . prg) -> fun


(daemon '(sym sym2 [. cls]) . prg) -> fun


Inserts prg in the beginning of the function (first form), the
method body of sym in cls (second form) or in the
class obtained by getting
sym2 from *Class (or
cls if given) (third form). Built-in functions (SUBRs) are
automatically converted to Lisp expressions. See also trace, expr, patch and redef.


: (de hello () (prinl "Hello world!"))
-> hello

: (daemon 'hello (prinl "# This is the hello world program"))
-> (NIL (prinl "# This is the hello world program") (prinl "Hello world!"))
: (hello)
# This is the hello world program
Hello world!
-> "Hello world!"

: (daemon '* (msg 'Multiplying))
-> (@ (msg 'Multiplying) (pass $134532148))
: *
-> (@ (msg 'Multiplying) (pass $134532148))
: (* 1 2 3)
Multiplying
-> 6




(dat$ 'dat ['sym]) -> sym


Formats a date dat in
ISO format, with an optional delimiter character sym. See also
$dat, tim$, datStr and datSym.


: (dat$ (date))
-> "20070601"
: (dat$ (date) "-")
-> "2007-06-01"




(datStr 'dat ['flg]) -> sym


Formats a date according to the
current locale. If flg
is non-NIL, the year will be formatted modulo 100. See also
dat$, datSym, strDat, expDat, expTel and day.


: (datStr (date))
-> "2007-06-01"
: (locale "DE" "de")
-> NIL
: (datStr (date))
-> "01.06.2007"
: (datStr (date) T)
-> "01.06.07"




(datSym 'dat) -> sym


Formats a date dat in
symbolic format (DDmmmYY). See also dat$ and datStr.


: (datSym (date))
-> "01jun07"




(date ['T]) -> dat


(date 'dat) -> (y m d)


(date 'y 'm 'd) -> dat | NIL


(date '(y m d)) -> dat | NIL


Calculates a (gregorian) calendar date. It is represented as a day number,
starting first of March of the year 0 AD. When called without arguments, the
current date is returned. When called with a T argument, the
current Coordinated Universal Time (UTC) is returned. When called with a single
number dat, it is taken as a date and a list with the corresponding
year, month and day is returned. When called with three numbers (or a list of
three numbers) for the year, month and day, the corresponding date is returned
(or NIL if they do not represent a legal date). See also time, stamp, $dat, dat$, datSym, datStr, strDat, expDat, day, week and ultimo.


: (date)                         # Today
-> 730589
: (date 2000 6 12)               # 12-06-2000
-> 730589
: (date 2000 22 5)               # Illegal date
-> NIL
: (date (date))                  # Today's year, month and day
-> (2000 6 12)
: (- (date) (date 2000 1 1))     # Number of days since first of January
-> 163




(day 'dat ['lst]) -> sym


Returns the name of the day for a given date dat, in the language of the
current locale. If lst
is given, it should be a list of alternative weekday names. See also week, datStr and strDat.


: (day (date))
-> "Friday"
: (locale "DE" "de")
-> NIL
: (day (date))
-> "Freitag"
: (day (date) '("Mo" "Tu" "We" "Th" "Fr" "Sa" "Su"))
-> "Fr"




(db 'sym 'cls ['hook] 'any ['sym 'any ..]) -> sym | NIL


(Deprecated since version 25.5.30) Returns a database object of
class cls, where the values for the sym
arguments correspond to the any arguments. If a matching
object cannot be found, NIL is returned. sym,
cls and hook should specify a tree for cls or one of its
superclasses. See also aux,
collect, request, fetch, init and step.


: (db 'nr '+Item 1)
-> {B1}
: (db 'nm '+Item "Main Part")
-> {B1}




db/3


db/4


db/5


(Deprecated since version 25.5.30) Pilog database predicate that returns objects
matching the given key-value (and optional hook) relation. The relation
should be of type +index.
For the key pattern applies:


    

  • a symbol (string) returns all entries which start with that string

  • other atoms (numbers, external symbols) match as they are

  • cons pairs constitute a range, returning objects
   
      
   
    • in increasing order if the CDR is greater than the CAR
   
    • in decreasing order otherwise
   
    

  • other lists are matched for +Aux
key combinations




The optional hook can be supplied as the third argument. See also select/3 and remote/2.


: (? (db nr +Item @Item))              # No value given
 @Item={B1}
 @Item={B2}
 @Item={B3}
 @Item={B4}
 @Item={B5}
 @Item={B6}
-> NIL

: (? (db nr +Item 2 @Item))            # Get item no. 2
 @Item={B2}
-> NIL

: (? (db nm +Item Spare @Item) (show @Item))  # Search for "Spare.."
{B2} (+Item)
   pr 1250
   inv 100
   sup {C2}
   nm "Spare Part"
   nr 2
 @Item={B2}
-> NIL




(db: cls ..) -> num


Returns the database file number for objects of the type given by the
cls argument(s). Needed, for example, for the creation of new objects. See also dbs.


: (db: +Item)
-> 3




(dbSync 'obj) -> flg


Starts a database transaction, by trying to obtain a lock on the database root object *DB (or obj if given), and then
calling sync to synchronize with
possible changes from other processes. When all desired modifications to
external symbols are done, (commit
'upd) should be called. See also Database.


(let? Obj (rd)             # Get object?
   (dbSync)                # Yes: Start transaction
   (put> Obj 'nm (rd))     # Update
   (put> Obj 'nr (rd))
   (put> Obj 'val (rd))
   (commit 'upd) )         # Close transaction




(dbck ['cnt] 'flg) -> any


Performs a low-level integrity check of the current (or cnt'th)
database file, and returns NIL (or the number of blocks and symbols
if flg is non-NIL) if everything seems correct.
Otherwise, a string indicating an error is returned. As a side effect, possibly
unused blocks (as there might be when a rollback is done before committing newly allocated (new) external symbols) are appended to the free
list.


: (pool "db")
-> T
: (dbck)
-> NIL




(dbs . lst)


Initializes the global variable *Dbs. Each element in lst has a
number in its CAR (the block size scale factor of a database file, to be stored
in *Dbs). The CDR elements are either classes (so that objects of
that class are later stored in the corresponding file), or lists with a class in
the CARs and a list of relations in the CDRs (so that index trees for these
relations go into that file). See also pool.


(dbs
   (3 +Role +User +Sal (+User pw))              # 512 Prevalent objects
   (0 +Pos)                                     # A:64 Tiny objects
   (1 +Item +Ord)                               # B:128 Small objects
   (2 +CuSu)                                    # C:256 Normal objects
   (2 (+Role nm) (+User nm) (+Sal nm))          # D:256 Small indexes
   (4 (+CuSu nr plz tel mob))                   # E:1024 Normal indexes
   (4 (+CuSu nm))                               # F:1024
   (4 (+CuSu ort))                              # G:1024
   (4 (+Item nr sup pr))                        # H:1024
   (4 (+Item nm))                               # I:1024
   (4 (+Ord nr dat cus))                        # J:1024
   (4 (+Pos itm)) )                             # K:1024

: *Dbs
-> (3 0 1 2 2 4 4 4 4 4 4 4)
: (get '+Item 'Dbf)
-> (3 . 128)
: (get '+Item 'nr 'dbf)
-> (9 . 1024)




(de sym . any) -> sym


Assigns a definition to the sym argument, by setting its
VAL to the any argument. If the symbol has already
another value, a "redefined" message is issued. When the value of the global
variable *Dbg is non-NIL, the current
line number and file name (if any) are stored in the *Dbg property
of sym. de is the standard way to define a function.
See also def, dm and undef.


: (de foo (X Y) (* X (+ X Y)))  # Define a function
-> foo
: (foo 3 4)
-> 21

: (de *Var . 123)  # Define a variable value
: *Var
-> 123




(debug 'sym)


(debug 'sym 'cls)


(debug '(sym . cls))


(Debug mode only) Inserts a !
breakpoint function call at the beginning and all top-level expressions of the
function or method body of sym, to allow a stepwise execution.
Typing (d) at a breakpoint will also
debug the current subexpression, and (e)
will evaluate the current subexpression. The current subexpression is stored in
the global variable ^. See also
unbug, *Dbg, trace and lint.


: (de tst (N)                    # Define tst
   (println (+ 3 N)) )
-> tst
: (debug 'tst)                   # Set breakpoints
-> T
: (pp 'tst)
(de tst (N)
   (! println (+ 3 N)) )         # Breakpoint '!'
-> tst
: (tst 7)                        # Execute
(println (+ 3 N))                # Stopped at beginning of 'tst'
! (d)                            # Debug subexpression
-> T
!                                # Continue
(+ 3 N)                          # Stopped in subexpression
! N                              # Inspect variable 'N'
-> 7
!                                # Continue
10                               # Output of print statement
-> 10                            # Done
: (unbug 'tst)
-> T
: (pp 'tst)                      # Restore to original
(de tst (N)
   (println (+ 3 N)) )
-> tst




(-debug)


(Debug mode only) Command line frontend to debug. See also -trace.


$ ./pil --debug tst +




(dec 'num) -> num


(dec 'var ['num]) -> num


The first form returns the value of num decremented by 1. The
second form decrements the VAL of var by 1, or by
num. If the first argument is NIL, it is returned
immediately. (dec Num) is equivalent to (- Num 1) and
(dec 'Var) is equivalent to (set 'Var (- Var 1)). See
also inc and -.


: (dec -1)
-> -2
: (dec 7)
-> 6
: (setq N 7)
-> 7
: (dec 'N)
-> 6
: (dec 'N 3)
-> 3




(def 'sym 'any) -> sym


(def 'sym1 'sym2|cnt 'any) -> sym1


The first form assigns a definition to the first sym argument,
by setting its VAL's to any. The second form defines a
property value any for the first argument's sym2 key
(or the symbol value for zero). If any of these values existed and was changed
in the process, a "redefined" message is issued. When the value of the global
variable *Dbg is non-NIL, the current
line number and file name (if any) are stored in the *Dbg property
of sym. See also de and
dm.


: (def 'b '((X Y) (* X (+ X Y))))
-> b
: (def 'b 999)
# b redefined
-> b




(default var 'any ..) -> any


Stores new values any in the var arguments only if
their current values are NIL. Otherwise, their values are left
unchanged. In any case, the last var's value is returned.
default is used typically in functions to initialize optional
arguments.


: (de foo (A B)               # Function with two optional arguments
   (default  A 1  B 2)        # The default values are 1 and 2
   (list A B) )
-> foo
: (foo 333 444)               # Called with two arguments
-> (333 444)
: (foo 333)                   # Called with one arguments
-> (333 2)
: (foo)                       # Called without arguments
-> (1 2)




(del 'any 'var ['flg]) -> lst


Deletes any from the list in the value of var, and
returns the remaining list. If flg is NIL and
any is contained more than once in the value of var,
only the first occurrence is deleted. (del 'any 'var) is equivalent
to (set 'var (delete 'any var)). See also delete, rid, cut and pop.


: (setq S '((a b c) (d e f)))
-> ((a b c) (d e f))
: (del '(d e f) 'S)
-> ((a b c))
: (del 'b S)
-> (a c)




(delete 'any 'lst ['flg]) -> lst


Deletes any from lst. If flg is
NIL and any is contained more than once in
lst, only the first occurrence is deleted. See also delq, del, remove and insert.


: (delete 2 (1 2 3))
-> (1 3)
: (delete (3 4) '((1 2) (3 4) (5 6) (3 4)))
-> ((1 2) (5 6) (3 4))




delete/3


Pilog predicate that succeeds if deleting the
first argument from the list in the second argument is equal to the third
argument. See also delete and
member/2.


: (? (delete b (a b c) @X))
 @X=(a c)
-> NIL




(delq 'any 'lst ['flg]) -> lst


Deletes any from lst. If flg is
NIL and any is contained more than once in
lst, only the first occurrence is deleted. == is used for comparison (pointer equality). See
also delete, asoq, push1q, memq, mmeq and Comparing.


: (delq 'b '(a b c))
-> (a c)
: (delq (2) (1 (2) 3))
-> (1 (2) 3)




(dep 'cls) -> cls


(Debug mode only) Displays the "dependencies" of cls, i.e. the
tree of superclasses and the tree of subclasses. See also OO Concepts, methods, class, what, who, has and and can.


: (dep '+Number)           # Dependencies of '+Number'
   +relation               # Single superclass is '+relation'
+Number
   +Date                   # Subclasses are '+Date' and '+Time'
   +Time
-> +Number




(depth 'lst) -> (cnt1 . cnt2)


Returns the maximal (cnt1) and the average (cnt2)
"depth" of a tree structure as maintained by idx. The total number of nodes is stored in the
global variable @@. See also length and size.


: (off X)                                    # Clear variable
-> NIL
: (for N (1 2 3 4 5 6 7) (idx 'X N T))       # Build a degenerated tree
-> NIL
: X
-> (1 NIL 2 NIL 3 NIL 4 NIL 5 NIL 6 NIL 7)   # Only right branches
: (depth X)
-> (7 . 4)                                   # Depth is 7, average 4

: (balance 'X (1 2 3 4 5 6 7))               # Build a balanced tree
-> NIL
: (depth X)
-> (3 . 2)                                   # Depth is 3, average 2




(detach) -> pid | NIL


Detach the current process from its PicoLisp parent, and return the parent's
process ID. This causes the parent to "forget" this child process (freeing
resources like buffers and pipes), effectively disabling family IPC via tell. See also fork and kids.


: (unless (fork)
   (detach)
   (runAlone)
   (bye) )




(diff 'lst1 'lst2) -> lst


Returns the difference of list arguments, all elements of lst1
which are not in lst2. See also sect.


: (diff (1 2 3 4 5) (2 4))
-> (1 3 5)
: (diff (1 2 3) (1 2 3))
-> NIL




different/2


Pilog predicate that succeeds if the two
arguments are different. See also equal/2.


: (? (different 3 4))
-> T




(dir ['any] ['flg]) -> lst


Returns a list of all filenames in the directory any. Names
starting with a dot '.' are ignored, unless flg is
non-NIL. See also cd and
info.


: (filter '((F) (tail '(. c) (chop F))) (dir "@src/"))
-> ("main.c" "subr.c" "gc.c" "io.c" "big.c" "sym.c" "tab.c" "flow.c" ..




(dirname 'any) -> sym


Returns the directory part of a path name any. See also
basename and path.


: (dirname "a/b/c/d")
-> "a/b/c/"




(dm sym . fun|cls2) -> sym


(dm (sym . cls) . fun|cls2) -> sym


(dm (sym sym2 [. cls]) . fun|cls2) -> sym


Defines a method for the message sym in the current class,
implicitly given by the value of the global variable *Class, or - in the second form - for the
explicitly given class cls. In the third form, the class object is
obtained by getting sym2
from *Class (or cls if
given). If the method for that class existed and was changed in the process, a
"redefined" message is issued. If - instead of a method fun - a
symbol specifying another class cls2 is given, the method from that
class is used (explicit inheritance). When the value of the global variable *Dbg is non-NIL, the current line number
and file name (if any) are stored in the *Dbg property of
sym. See also OO Concepts, de, undef, class, rel, var, method, send and try.


: (dm start> ()
   (super)
   (mapc 'start> (: fields))
   (mapc 'start> (: arrays)) )

: (dm foo> . +OtherClass)  # Explicitly inherit 'foo>' from '+OtherClass'




(do 'flg|num ['any | (NIL 'any . prg) | (T 'any . prg) ..]) -> any


Counted loop with multiple conditional exits: The body is executed at most
num times (or never (if the first argument is NIL), or
an infinite number of times (if the first argument is T)). If a
clause has NIL or T as its CAR, the clause's second
element is evaluated as a condition and - if the result is NIL or
non-NIL, respectively - the prg is executed and the
result returned. Otherwise (if count drops to zero), the result of the last
expression is returned. See also loop
and for.


: (do 4 (printsp 'OK))
OK OK OK OK -> OK
: (do 4 (printsp 'OK) (T (= 3 3) (printsp 'done)))
OK done -> done




(doc ['sym1] ['sym2])


(Debug mode only) Opens a browser, and tries to display the reference
documentation for sym1. sym2 may be the name of a
browser. If not given, the value of the environment variable
BROWSER, or the w3m browser is tried. If
sym1 is NIL, the PicoLisp
Reference manual is opened. See also Function
Reference, docs and vi.


: (doc '+)  # Function reference
-> NIL
: (doc '+relation)  # Class reference
-> NIL
: (doc)  # Reference manual
-> NIL
:  (doc 'vi "firefox")  # Use alternative browser
-> NIL




(docs 'any)


(Debug mode only) Parses all files with names of the form "ref@.html" in the
directory any, to set the doc property for later calls
to doc.


: (docs "@doc/")
-> NIL




(download 'host 'src 'dst) -> any


Tries to download the file src from host with
"@bin/ssl", and stores it in dst. Returns non-NIL if
successful. See also ssl.


: (download "de.wikipedia.org" "static/images/wikimedia-button.png" "button.png")
-> 0
: (info "button.png")
-> (2426 736804 . 35589)







================================================
FILE: doc/refE.html
================================================
E
E



*Err


A global variable holding a (possibly empty) prg body, which
will be executed during error processing. See also Error Handling, *Msg and ^.


: (de *Err (prinl "Fatal error!"))
-> *Err
: (/ 3 0)
!? (/ 3 0)
Div/0
Fatal error!
?




*Ext


A global variable holding a sorted list of cons pairs. The CAR of each pair
specifies an external symbol offset (suitable for ext), and the CDR should be a function taking a
single external symbol as an argument. This function should return a list, with
the value for that symbol in its CAR, and the property list (in the format used
by getl and putl) in its CDR. The symbol will be set to
this value and property list upon access. Typically this function will access
the corresponding symbol in a remote database process. See also qsym and external symbols.


### On the local machine ###
: (setq *Ext  # Define extension functions
   (mapcar
      '((@Host @Ext)
         (cons @Ext
            (curry (@Host @Ext (Sock)) (Obj)
               (when (or Sock (setq Sock (connect @Host 4040)))
                  (ext @Ext
                     (out Sock (pr (cons 'qsym Obj)))
                     (prog1
                        (in Sock (rd))
                        (unless @
                           (close Sock)
                           (off Sock) ) ) ) ) ) ) )
      '("10.10.12.1" "10.10.12.2" "10.10.12.3" "10.10.12.4")
      (20 40 60 80) ) )

### On the remote machines ###
(de go ()
   ...
   (task (port 4040)                      # Set up background query server
      (let? Sock (accept @)               # Accept a connection
         (unless (fork)                   # In child process
            (in Sock
               (while (rd)                # Handle requests
                  (sync)
                  (tell)
                  (out Sock
                     (pr (eval @)) ) ) )
            (bye) )                       # Exit child process
         (close Sock) ) )
   ...





+Entity


Base class of all database objects. See also +relation and Database.


Messages to entity objects include


zap> ()              # Clean up relational structures, for removal from the DB
url> (Tab)           # Call the GUI on that object (in optional Tab)
gui> ()              # Generate object-specific GUI fragment
upd> (X Old)         # Callback method when object is created/modified/deleted
has> (Var Val)       # Check if value is present
rel?> (Var Val)      # Check if relations for value are correctly maintained
put> (Var Val)       # Put a new value
put!> (Var Val)      # Put a new value, single transaction
del> (Var Val)       # Delete value (also partial)
del!> (Var Val)      # Delete value (also partial), single transaction
inc> (Var Val)       # Increment numeric value
inc!> (Var Val)      # Increment numeric value, single transaction
dec> (Var Val)       # Decrement numeric value
dec!> (Var Val)      # Decrement numeric value, single transaction
mis> (Var Val)       # Return error message if value or type mismatch
lose1> (Var)         # Delete relational structures for a single attribute
lose> (Lst)          # Delete relational structures (excluding 'Lst')
lose!> ()            # Delete relational structures, single transaction
keep1> (Var)         # Restore relational structures for single attribute
keep> (Lst)          # Restore relational structures (excluding 'Lst')
keep?> (Lst)         # Test for restauration (excluding 'Lst')
keep!> ()            # Restore relational structures, single transaction
set> (Val)           # Set the value (type, i.e. class list)
set!> (Val)          # Set the value, single transaction
clone> ()            # Object copy
clone!> ()           # Object copy, single transaction




(e . prg) -> any


Used in a breakpoint. Evaluates prg in the execution
environment, or the currently executed expression if prg is not
given. See also debug, !, ^ and
*Dbg.


: (! + 3 4)
(+ 3 4)
! (e)
-> 7




(echo ['cnt ['cnt]] | ['sym ..]) -> sym


Reads the current input channel, and writes to the current output channel.
If cnt is given, only that many bytes are actually echoed. In case
of two cnt arguments, the first one specifies the number of bytes
to skip in the input stream. Otherwise, if one or more sym
arguments are given, the echo process stops as soon as one of the symbol's names
is encountered in the input stream. In this case the name will be read and
returned, but not written. Returns non-NIL if the operation was
successfully completed. See also from.


: (in "x.l" (echo))  # Display file on console
 ..

: (out "x2.l" (in "x.l" (echo)))  # Copy file "x.l" to "x2.l"




(enum 'var 'cnt ['cnt ..]) -> lst


(enum 'var ['flg]) -> lst


Enumerates cells by maintaining a binary tree in var. The keys
are implicit from the enumerated cnts, and the resulting tree is
balanced (independent from the insertion order). In the first form, the
corresponding cell is returned. If it does not exist yet, it is (destructively)
inserted into the tree. If more than one cnt argument is given, the
returned cell is subsequently taken as the next tree to be processed. The second
form returns an unsorted association list of all key-value pairs (or value-key
pairs if flg is non-NIL) in the tree.
enum can be used to emulate (possibly sparse) arrays. See also
enum?, idx and hash.


: (off E)
-> NIL
: (for (I . S) '(a b c d e f g h i j k l m n o)
   (set (enum 'E I) S) )
-> o
: E
-> (a (b (d (h) l) f (j) n) c (e (i) m) g (k) o)
: (view E T)
         o
      g
         k
   c
         m
      e
         i
a
         n
      f
         j
   b
         l
      d
         h
-> NIL
: (enum 'E 6)
-> (f (j) n)
: (val (enum 'E 6))
-> f
: (val (enum 'E 1))
-> a
: (val (enum 'E 12))
-> l
: (enum 'E)
-> ((8 . h) (4 . d) (12 . l) (2 . b) (10 . j) (6 . f) (14 . n) (1 . a) (9 . i) (5 . e) (13 . m) (3 . c) (11 . k) (7 . g) (15 . o))
: (enum 'E T)
-> ((h . 8) (d . 4) (l . 12) (b . 2) (j . 10) (f . 6) (n . 14) (a . 1) (i . 9) (e . 5) (m . 13) (c . 3) (k . 11) (g . 7) (o . 15))

: (let A NIL  # 2-dimensional array
   (for I 4
      (for J 4
         (set (enum 'A I J) (pack I "-" J)) ) )
   (for I 4
      (for J 4
         (prin " " (val (enum 'A I J))) )
      (prinl) ) )
 1-1 1-2 1-3 1-4
 2-1 2-2 2-3 2-4
 3-1 3-2 3-3 3-4
 4-1 4-2 4-3 4-4
-> NIL




(enum? 'lst 'cnt ['cnt ..]) -> lst | NIL


Tests a binary enum tree for the
keys in the cnt arguments. Returns the corresponding cell, or
NIL if not found. The tree is not modified. See also lup.


: (enum? E 7)
-> (g (k) o)
: (enum? E 16)
-> NIL




(env ['lst] | ['sym 'val] ..) -> lst


Return a list of symbol-value pairs of all dynamically bound symbols if
called without arguments, or of the symbols or symbol-value pairs in
lst, or the explicitly given sym-val
arguments. See also bind, job, trail and up.


: (env)
-> NIL
: (let (A 1 B 2) (env))
-> ((A . 1) (B . 2))
: (let (A 1 B 2) (env '(A B)))
-> ((B . 2) (A . 1))
: (let (A 1 B 2) (env 'X 7 '(A B (C . 3)) 'Y 8))
-> ((Y . 8) (C . 3) (B . 2) (A . 1) (X . 7))




(eof ['flg]) -> flg


Returns the end-of-file status of the current input channel. If
flg is non-NIL, the channel's status is forced to
end-of-file, so that the next call to eof will return
T, and calls to char,
peek, line, from, till, read or skip will return NIL. Note that
eof cannot be used with the binary rd function. See also eol.


: (in "file" (until (eof) (println (line T))))
...




(eol) -> flg


Returns the end-of-line status of the current input channel.
See also eof.


: (make (until (prog (link (read)) (eol))))  # Read line into a list
a b c (d e f) 123
-> (a b c (d e f) 123)




equal/2


Pilog predicate that succeeds if the two
arguments are equal. See also =, different/2 and member/2.


: (? (equal 3 4))
-> NIL
: (? (equal @N 7))
 @N=7
-> NIL




(err 'sym . prg) -> any


Redirects the standard error stream to sym during the execution
of prg. The current standard error stream will be saved and
restored appropriately. If the argument is NIL, the current output
stream will be used. Otherwise, sym is taken as a file name (opened
in "append" mode if the first character is "+"), where standard error is to be
written to. See also in, out and ctl.


: (err "/dev/null"             # Suppress error messages
   (call 'ls 'noSuchFile) )
-> NIL




(errno) -> cnt


Returns the value of the standard I/O 'errno' variable. See also native.


: (in "foo")                           # Produce an error
!? (in "foo")
"foo" -- Open error: No such file or directory
? (errno)
-> 2                                   # Returned 'ENOENT'




(eval 'any ['cnt]) -> any


Evaluates any. Note that because of the standard argument
evaluation, any is actually evaluated twice. If an offset
cnt is given, the value of @ in the cnt'th call environment
is used during the second evaluation. cnt should be greater than
zero. See also run and up.


: (eval (list '+ 1 2 3))
-> 6
: (setq X 'Y  Y 7)
-> 7
: X
-> Y
: Y
-> 7
: (eval X)
-> 7




(exec 'any ..)


Executes an external system command. The any arguments specify
the command and its arguments. Does not return to the caller; the current
process is replaced with a new process image. See also fork and call.


: (pipe (exec 'echo 123 "abc")  # Equivalent to (in '(echo 123 "abc") ..)
   (list (read) (read)) )
-> (123 abc)

(unless (fork)
   (exec "@bin/ssl"  # Start replication process
      "10.11.12.13" 443
      "app/!replica" "key/app" "fifo/app" "db/app/blob/" 20 ) )




(expDat 'sym) -> dat


Expands a date string according to
the current locale (delimiter, and
order of year, month and day). Accepts abbreviated input, without delimiter and
with only the day, or the day and month, or the day, month and year of current
century. A single dot "." expands to "today", and a signed number to a date such
many days in the past or future. See also datStr, day, expTel.


: (date)
-> 733133
: (date (date))
-> (2007 5 31)
: (expDat "31")
-> 733133
: (expDat "315")
-> 733133
: (expDat "3105")
-> 733133
: (expDat "31057")
-> 733133
: (expDat "310507")
-> 733133
: (expDat "2007-05-31")
-> 733133
: (expDat "7-5-31")
-> 733133

: (locale "DE" "de")
-> NIL
: (expDat "31.5")
-> 733133
: (expDat "31.5.7")
-> 733133




(expTel 'sym) -> sym


Expands a telephone number string. Multiple spaces or hyphens are coalesced.
A leading + or 00 is removed, a leading national trunk
prefix is replaced with the current country code. Otherwise, NIL is
returned. See also telStr, expDat and locale.


: (expTel "+49 1234 5678-0")
-> "49 1234 5678-0"
: (expTel "0049 1234 5678-0")
-> "49 1234 5678-0"
: (expTel "01234 5678-0")
-> NIL
: (locale "DE" "de")
-> NIL
: (expTel "01234 5678-0")
-> "49 1234 5678-0"




(export . lst) -> lst


Intern all symbols in lst explicitly in the second namespace in the current search order. See also
pico, symbols, private, local, import and intern.


: (symbols 'myLib 'pico)
-> (pico)
myLib: (export foo bar)  # Intern 'foo' and 'bar' in 'pico'




(expr 'sym) -> fun


Converts a built-in function (SUBR) to a Lisp-function. Useful only for
normal functions (i.e. functions that evaluate all arguments). See also subr.


: car
-> 67313448
: (expr 'car)
-> (@ (pass $385260187))
: (car (1 2 3))
-> 1




(ext 'cnt . prg) -> any


During the execution of prg, all external symbols processed by rd, pr,
plio,
blk or udp are modified by an offset cnt
suitable for mapping via the *Ext
mechanism. All external symbol's file numbers are decremented by
cnt during output, and incremented by cnt during
input.


: (out 'a (ext 5 (pr '({A2} ({C4} . a) ({B7} . b)))))
-> ({A2} ({C4} . a) ({B7} . b))

: (in 'a (rd))
-> ({OOOL2} ({OOON4} . a) ({OOOM7} . b))

: (in 'a (ext 5 (rd)))
-> ({A2} ({C4} . a) ({B7} . b))




(ext? 'any ['flg]) -> sym | NIL


Returns the argument any when it is an external symbol,
otherwise NIL. If flg is non-NIL, also
physical existence is checked. See also sym?, box?, str?, extern and lieu.


: (ext? *DB)
-> {1}
: (ext? 'abc)
-> NIL
: (ext? "abc")
-> NIL
: (ext? 123)
-> NIL




(extend cls) -> cls


Extends the class cls, by storing it in the global variable
*Class. As a consequence, all
following method, relation and class variable definitions are applied to that
class. See also OO Concepts, class, dm, var,
rel, type and isa.





(extern 'sym) -> sym | NIL


Creates or finds an external symbol. If a symbol with the name
sym is already extern, it is returned. Otherwise, a new external
symbol is returned. NIL is returned if sym does not
exist in the database. See also intern and ext?.


: (extern "A1b")
-> {A1b}
: (extern "{A1b}")
-> {A1b}




(extra ['any ..]) -> any


Can only be used inside methods. Sends the current message to the current
object This, this time starting the search for a method at the
remaining branches of the inheritance tree of the class where the current method
was found. See also OO Concepts, super, method, meth, send and try.


(dm key> (C)            # 'key>' method of the '+Uppc' class
   (uppc (extra C)) )   # Convert 'key>' of extra classes to upper case




(extract 'fun 'lst ..) -> lst


Applies fun to each element of lst. When
additional lst arguments are given, their elements are also passed
to fun. Returns a list of all non-NIL values returned
by fun. (extract 'fun 'lst) is equivalent to
(mapcar 'fun (filter 'fun 'lst)) or, for non-NIL results, to
(mapcan '((X) (and (fun X) (cons @))) 'lst). See also filter, find, pick and mapcan.


: (setq A NIL  B 1  C NIL  D 2  E NIL  F 3)
-> 3
: (filter val '(A B C D E F))
-> (B D F)
: (extract val '(A B C D E F))
-> (1 2 3)







================================================
FILE: doc/refF.html
================================================
F
F



*Fork


A global variable holding a (possibly empty) prg body, to be
executed after a call to fork in the
child process.


: (push '*Fork '(off *Tmp))   # Clear '*Tmp' in child process
-> (off *Tmp)




+Fold


Prefix class for maintaining folded indexes to +String relations. Typically used in
combination with the +Ref or +Idx prefix classes. See also +IdxFold and Database.


(rel nm (+Fold +Idx +String))   # Item Description
...
(rel tel (+Fold +Ref +String))  # Phone number




(fail) -> lst


Constructs an empty Pilog query, i.e. a query
that will always fail. See also goal.


(dm clr> ()                # Clear query chart in search dialogs
   (query> This (fail)) )




fail/0


Pilog predicate that always fails. See also
true/0.


: (? (fail))
-> NIL




(fd ['cnt]) -> cnt


Return the current file descriptor, typically of the closest in or out channel. If a second file descriptor
cnt is given, the current file descriptor is copied to it using a
dup2() system call. See also ipid and opid.


: (in "@lib.l" (fd))
-> 3




(fetch 'tree 'any) -> any


Fetches a value for the key any from a database tree. See also
tree and store.


: (fetch (tree 'nr '+Item) 2)
-> {B2}




(fifo 'var ['any ..]) -> any


Implements a first-in-first-out structure using a circular list. When called
with any arguments, they will be concatenated to end of the
structure. Otherwise, the first element is removed from the structure and
returned. See also queue, push, pop, rid, rot and circ.


: (fifo 'X 1)
-> 1
: (fifo 'X 2 3)
-> 3
: X
-> (3 1 2 .)
: (fifo 'X)
-> 1
: (fifo 'X)
-> 2
: X
-> (3 .)




(file) -> (sym1 sym2 . num) | NIL


Returns for the current input channel the path name sym1, the
file name sym2, and the current line number num. If
the current input channel is not a file, NIL is returned. See also
info, in and load.


: (load (pack (car (file)) "localFile.l"))  # Load a file in same directory




(fill 'any ['sym|lst]) -> any


(fill 'any ['cnt|sym] 'any2) -> any


Non-destructively fills a pattern any, by substituting
sym, or all symbols in lst, or - if no second argument
is given - each pattern symbol in any (see pat?), with its current value. @
itself is not considered a pattern symbol here. In any case, expressions
following the symbol ^ are evaluated and the results
(destructively) spliced into the result. In the second form, all occurrences of
the second argument are simply replaced by any2. In both cases,
unmodified subexpressions are shared.

See also match.


: (setq  @X 1234  @Y (1 2 3 4))
-> (1 2 3 4)
: (fill '@X)
-> 1234
: (fill '(a b (c @X) ((@Y . d) e)))
-> (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)
: (fill (1 ^(+ 2 3) 7))
-> (1 5 7)

: (fill (1 (a (b . 2) c) 3) 'b 7)
-> (1 (a (7 . 2) c) 3)
: (fill (1 (a (b . 2) c) 3) 2 123)
-> (1 (a (b . 123) c) 3)

: (match '(This is @X) '(This is a pen))
-> T
: (fill '(Got ^ @X))
-> (Got a pen)




(filter 'fun 'lst ..) -> lst


Applies fun to each element of lst. When
additional lst arguments are given, their elements are also passed
to fun. Returns a list of all elements of lst where
fun returned non-NIL. See also fish, find, pick and extract.


: (filter num? (1 A 2 (B) 3 CDE))
-> (1 2 3)
: (filter < (2 9 3 8 4 7) (5 4 3 9 9 5))
-> (2 8 4)
: (filter and (1 NIL 3 NIL 5) (2 3 4 5 6) (7 8 NIL 1 1))
-> (1 5)
: (filter and (range 1 22) '(NIL NIL T .))
-> (3 6 9 12 15 18 21)




(fin 'any) -> num|sym


Returns any if it is an atom, otherwise the CDR of its last
cell. See also last and tail.


: (fin 'a)
-> a
: (fin '(a . b))
-> b
: (fin '(a b . c))
-> c
: (fin '(a b c))
-> NIL




(finally exe . prg) -> any


prg is executed, then exe is evaluated, and the
result of prg is returned. exe will also be evaluated
if prg does not terminate normally due to a runtime error or a call
to throw. See also bye, catch, quit and Error
Handling.


: (finally (prinl "Done!")
   (println 123)
   (quit)
   (println 456) )
123
Done!
: (catch 'A
   (finally (prinl "Done!")
      (println 1)
      (throw 'A 123)
      (println 2) ) )
1
Done!
-> 123




(find 'fun 'lst ..) -> any


Applies fun to successive elements of lst until
non-NIL is returned. Returns that element (and stores the
non-NIL value in the global variable @@), or NIL if fun did
not return non-NIL for any element of lst. When
additional lst arguments are given, their elements are also passed
to fun. See also seek,
pick, fully and filter.


: (find pair (1 A 2 (B) 3 CDE))
-> (B)
: (find '((A B) (> A B)) (1 2 3 4 5 6) (6 5 4 3 2 1))
-> 4
: (find > (1 2 3 4 5 6) (6 5 4 3 2 1))  # shorter
-> 4





(finish . prg) -> exe


Pushes the expressions in prg into the global *Bye in reverse order, to be executed just
before the termination of the PicoLisp interpreter. (finish (foo)
(bar)) is equivalent to (push '*Bye '(bar) '(foo)) See also
bye and once.


: (finish (call "rm" "myfile.tmp"))  # Remove a temporary file
-> (call 'rm "myfile.tmp")




(fish 'fun 'any ['any2] ..) -> lst


Applies fun to each element - and recursively to all sublists -
of any. Returns a list of all items where fun returned
non-NIL. If any2 is non-NIL, it may be
returned by fun to cause the corresponding item or (sub-)list to be
skipped. When additional any arguments are given, they are also
passed to fun. See also seek,

See also filter.


: (fish atom '((a b) c (d e)))
-> (a b c d e)
: (fish sym? '(a -2 (1 b (-3 c 2)) 3 d -1 7))
-> (a b c d)
: (fish gt0 '(a -2 (1 b (-3 c 2)) 3 d -1 7))
-> (1 2 3 7)
: (fish < '(a -2 (1 b (-3 c 2)) 3 d -1 7) NIL 2)
-> (-2 1 -3 -1)
: (fish
   '((X)
      (if (and (pair X) (=1 (car X)))
         "skip"  # Transient symbol (pointer equal)
         (gt0 X) ) )
   '(a -2 (1 b (-3 c 2)) 3 d -1 7)
   "skip" )
-> (3 7)
: (fish == '(a 1 (b (3 b)) 3) NIL 'b)
-> (b b)




(flg? 'any) -> flg


Returns T when the argument any is either
NIL or T. See also bool. (flg? X) is equivalent to
(or (not X) (=T X)).


: (flg? (= 3 3))
-> T
: (flg? (= 3 4))
-> T
: (flg? (+ 3 4))
-> NIL




(flip 'lst ['cnt]) -> lst


Returns lst (destructively) reversed. Without the optional
cnt argument, the whole list is flipped, otherwise only the first
cnt elements. See also reverse and rot.


: (flip (1 2 3 4))         # Flip all  four elements
-> (4 3 2 1)
: (flip (1 2 3 4 5 6) 3)   # Flip only the first three elements
-> (3 2 1 4 5 6)




(flood 'lst1 'fun 'lst2) -> lst


Implements a flooding algorithm, returning a list of flooded nodes of a
graph. lst1 is a list of relevant nodes, fun a
function accepting a node and returning a list of connected nodes, and
lst2 a list of seed nodes.


(load "@lib/simul.l")

: (setq *Graph (1 2 3 4 5))         # For simplicity, a one-dimensional "graph"
-> (1 2 3 4 5)

: (simul~flood
   (maplist prog *Graph)            # List of relevant cells
   '((X)                            # Flood the three central cells (2 3 4)
      (when (member (car X) (2 3))  # 2 -> 3 and 3 -> 4
         (list (cdr X)) ) )
   (list (cddr *Graph)) )           # Seed third (middle) cell
-> ((3 4 5) (2 3 4 5) (4 5))        # -> Cells (3 ..) (2 ..) (4 ..)




(flush) -> flg


Flushes the current output stream by writing all buffered data. A call to
flush for standard output is done automatically before a call to
key. Returns T when
successful. See also rewind.


: (flush)
-> T




(fold 'any ['cnt]) -> sym


Folding to a canonical form: If any is not a symbol, it is
returned as it is. Otherwise, a new transient symbol with all digits and all
letters of any, converted to lower case, is returned. If the
cnt argument is given and non-zero, the result is truncated to that
length. See also lowc.


: (fold " 1A 2-b/3")
-> "1a2b3"
: (fold " 1A 2-B/3" 3)
-> "1a2"




fold/3


(Deprecated since version 25.5.30) Pilog predicate that succeeds if the first
argument, after folding it to
a canonical form, is a prefix of the folded string representation
of the result of applying the get algorithm to the following
arguments. Typically used as filter predicate in select/3 database queries. See also
pre?, isa/2, same/3, bool/3, range/3, head/3, part/3 and tolr/3.


: (?
   @Nr (1 . 5)
   @Nm "main"
   (select (@Item)
      ((nr +Item @Nr) (nm +Item @Nm))
      (range @Nr @Item nr)
      (fold @Nm @Item nm) ) )
 @Nr=(1 . 5) @Nm="main" @Item={B1}
-> NIL




(for sym 'cnt ['any | (NIL 'any . prg) | (T 'any . prg) ..]) -> any


(for sym|(sym2 . sym) 'lst ['any | (NIL 'any . prg) | (T 'any . prg) ..]) -> any


(for (sym|(sym2 . sym) 'any1 'any2 [. prg]) ['any | (NIL 'any . prg) | (T 'any . prg) ..]) -> any


Conditional loop with local variable(s) and multiple conditional exits:

In the first form, the value of sym is saved, sym is
bound to 1, and the body is executed with increasing values up to
(and including) cnt.


In the second form, the value of sym is saved, sym is
subsequently bound to the elements of lst, and the body is executed
each time.


In the third form, the value of sym is saved, and sym
is bound to any1. If sym2 is given, it is treated as a
counter variable, first bound to 1 and then incremented for each execution of
the body. While the condition any2 evaluates to
non-NIL, the body is repeatedly executed and, if prg
is given, sym is re-bound to the result of its evaluation.


If a clause has NIL or T as its CAR, the clause's
second element is evaluated as a condition and - if the result is
NIL or non-NIL, respectively - the prg is
executed and the result returned. If the body is never executed,
NIL is returned.


See also do and loop.


# First form:
: (for N 5 (printsp N))
1 2 3 4 5 -> 5
: (for N 5 (printsp N) (NIL (< N 3) (printsp 'enough)))
1 2 3 enough -> enough
: (for N 5 (T (> N 3) (printsp 'enough)) (printsp N))
1 2 3 enough -> enough

# Second form:
: (for X (1 a 2 b) (printsp X))
1 a 2 b -> b
: (for (I . X) '(a b c) (println I X))
1 a
2 b
3 c
-> c

# Third form:
: (for (L (1 2 3 4 5) L) (printsp (pop 'L)))
1 2 3 4 5 -> 5
: (for (N 1 (>= 5 N) (inc N)) (printsp N))
1 2 3 4 5 -> 5
: (for ((I . L) '(a b c d e f) L (cddr L)) (println I L))
1 (a b c d e f)
2 (c d e f)
3 (e f)
-> (e f)




for/2


for/3


for/4


Pilog predicate that generates a sequence of
numbers. See also for and range.


: (? (for @I 3))
 @I=1
 @I=2
 @I=3
-> NIL

: (? (for @I 3 7))
 @I=3
 @I=4
 @I=5
 @I=6
 @I=7
-> NIL

: (? (for @I 7 3 2))
 @I=7
 @I=5
 @I=3
-> NIL

: (? (for @N T))
 @N=1
 @N=2
 @N=3
 ...




(forall 'cls . prg) -> any


(forall '(cnt . cls) . prg) -> any


(forall 'lst . prg) -> any


Runs prg on all database objects of the class cls
(as given by the dbs definition, or
using the cnt'th database file instead of the dbs
default), or on a lst query structure as returned by init or search. In all cases, the global variable
This is bound to each object (and
@@ is bound to the key in case of
init). See also seq and
collect.


: (forall '+Item (println (: nr) (: nm)))
1 "Main Part"
2 "Spare Part"
3 "Auxiliary Construction"
4 "Enhancement Additive"
5 "Metal Fittings"
6 "Gadget Appliance"

: (forall (init '(nr . +Item) 2 4)
   (println @@ (: nr) (: nm)) )
2 2 "Spare Part"
2 3 "Auxiliary Construction"
2 4 "Enhancement Additive"

: (forall
   (search
      (1 . 4) '((nr +Item))
      "pa" '((nm +Item)) )
   (println (: nr) (: nm)) )
1 "Main Part"
2 "Spare Part"




(fork) -> pid | NIL


Forks a child process. Returns NIL in the child, and the
child's process ID pid in the parent. In the child, the
VAL of the global variable *Fork (should be a prg) is
executed. See also exec, detach, kids, pipe and tell.


: (unless (fork) (do 5 (println 'OK) (wait 1000)) (bye))
-> NIL
OK                                              # Child's output
: OK
OK
OK
OK




(format 'num ['cnt ['sym1 ['sym2]]]) -> sym


(format 'sym|lst ['cnt ['sym1 ['sym2]]]) -> num


Converts a number num to a string, or a string
sym|lst to a number. In both cases, optionally a precision
cnt, a decimal-separator sym1 and a
thousands-separator sym2 can be supplied. Returns
NIL if the conversion is unsuccessful. See also Numbers, pad, hex, oct, bin and round.


: (format 123456789)                   # Integer conversion
-> "123456789"
: (format 123456789 2)                 # Fixed point
-> "1234567.89"
: (format 123456789 2 ",")             # Comma as decimal-separator
-> "1234567,89"
: (format 123456789 2 "," ".")         # and period as thousands-separator
-> "1.234.567,89"

: (format "123456789")                 # String to number
-> 123456789
: (format (1 "23" (4 5 6)))
-> 123456
: (format "1234567.89" 4)              # scaled to four digits
-> 12345678900
: (format "1.234.567,89")              # separators not recognized
-> NIL
: (format "1234567,89" 4 ",")
-> 12345678900
: (format "1.234.567,89" 4 ",")        # thousands-separator not recognized
-> NIL
: (format "1.234.567,89" 4 "," ".")
-> 12345678900




(free 'cnt) -> (sym . lst)


Returns, for the cnt'th database file, the next available
symbol sym (i.e. the first symbol greater than any symbol in the
database), and the list lst of free symbols. See also seq, zap and dbck.


: (pool "x")      # A new database
-> T
: (new T)         # Create a new symbol
-> {2}
: (new T)         # Create another symbol
-> {3}
: (commit)        # Commit changes
-> T
: (zap '{2})      # Delete the first symbol
-> {2}
: (free 1)        # Show free list
-> ({4})          # {3} was the last symbol allocated
: (commit)        # Commit the deletion of {2}
-> T
: (free 1)        # Now {2} is in the free list
-> ({4} {2})




(from 'any ..) -> sym


Skips the current input channel until one of the strings any is
found, and starts subsequent reading from that point. The found any
argument (or NIL if none is found) is returned. See also till and echo.


: (and (from "val='") (till "'" T))
test val='abc'
-> "abc"




(full 'any) -> bool


Returns NIL if any is a non-empty list with at
least one NIL element, otherwise T. (full
X) is equivalent to (not (memq NIL X)). See also fully.


: (full (1 2 3))
-> T
: (full (1 NIL 3))
-> NIL
: (full 123)
-> T




(fully 'fun 'lst ..) -> flg


Applies fun to successive elements of lst, and
returns NIL immediately if one of the results is NIL.
Otherwise, T is returned. When additional lst
arguments are given, their elements are also passed to fun.
(fully foo Lst) is equivalent to (not (find '((X) (not (foo
X))) Lst)). See also find and
full.


: (fully gt0 (1 2 3))
-> T
: (fully gt0 (1 -2 3))
-> NIL




(fun 'fun ['any ..]) -> any


Applies fun to the any arguments. (fun foo
'args) is equivalent to (foo 'args), and (fun (expr)
'args) is equivalent to ((expr) 'args). See also apply and pass.


: (find fun '(sym? ((X) (> X 3)) num?) 'a)
-> sym?
: (find fun '(sym? ((X) (> X 3)) num?) 3)
-> num?
: (find fun '(sym? ((X) (> X 3)) num?) 4)
-> ((X) (> X 3))




(fun? 'any) -> any


Returns NIL when the argument any is neither a
number suitable for a code-pointer, nor a list suitable for a lambda expression
(function). Otherwise a number is returned for a code-pointer, T
for a function without arguments, and a single formal parameter or a list of
formal parameters for a function. See also getd.


: (fun? 1000000000)              # Might be a code pointer
-> 1000000000
: (fun? 10000000000000000000)    # Too big for a code pointer
-> NIL
: (fun? '((A B) (* A B)))        # Lambda expression
-> (A B)
: (fun? '((A B) (* A B) . C))    # Not a lambda expression
-> NIL
: (fun? '(1 2 3 4))              # Not a lambda expression
-> NIL
: (fun? '((A 2 B) (* A B)))      # Not a lambda expression
-> NIL







================================================
FILE: doc/refG.html
================================================
G
G



(gc ['cnt [cnt2]]) -> cnt | NIL


Forces a garbage collection. When cnt is given, so many
megabytes of free cells are reserved, increasing the heap size if necessary. If
cnt is zero, all currently unused heap blocks are purged,
decreasing the heap size if possible. If cnt2 is given, the reserve
size (defaults to 1 megabyte) is set to that value. See also heap.


: (gc)
-> NIL
: (heap)
-> 2
: (gc 4)
-> 4
: (heap)
-> 5




(ge0 'any) -> num | NIL


Returns num when the argument is a number and greater or equal
zero, otherwise NIL. See also lt0, le0, gt0, =0
and n0.


: (ge0 -2)
-> NIL
: (ge0 3)
-> 3
: (ge0 0)
-> 0




(genKey 'sym 'cls ['hook ['num1 ['num2]]]) -> num


Generates a key for a database tree. If a minimal key num1
and/or a maximal key num2 is given, the next free number in that
range is returned. Otherwise, the current maximal key plus one is returned. See
also useKey, genStrKey and maxKey.


: (maxKey (tree 'nr '+Item))
-> 8
: (genKey 'nr '+Item)
-> 9




(genStrKey 'sym 'sym 'cls ['hook]) -> sym


Generates a unique string for a database tree, by prepending as many "# "
sequences as necessary. See also genKey.


: (genStrKey "ben" 'nm '+User)
-> "# ben"




(get 'sym1|lst ['sym2|cnt ..]) -> any


Fetches a value any from the properties of a symbol, or from a
list. From the first argument sym1|lst, values are retrieved in
successive steps by either extracting the value (if the next argument is zero)
or a property from a symbol, the CDR of an asoqed element (if the next argument is a
symbol), the n'th element (if the next argument is a positive number) or the
n'th CDR (if the next argument is a negative number) from a list. See also
put, ;, : and
nth.


: (put 'X 'a 1)
-> 1
: (get 'X 'a)
-> 1
: (put 'Y 'link 'X)
-> X
: (get 'Y 'link)
-> X
: (get 'Y 'link 'a)
-> 1
: (get '((a (b . 1) (c . 2)) (d (e . 3) (f . 4))) 'a 'b)
-> 1
: (get '((a (b . 1) (c . 2)) (d (e . 3) (f . 4))) 'd 'f)
-> 4
: (get '(X Y Z) 2)
-> Y
: (get '(X Y Z) 2 'link 'a)
-> 1




(getd 'any) -> fun | NIL


Returns fun if any is a symbol that has a function
definition, otherwise NIL. See also fun?.


: (getd '+)
-> 67327232
: (getd 'script)
-> ((File . @) (load File))
: (getd 1)
-> NIL

: ht:Fmt             # Initially undefined
-> NIL
: (getd 'ht:Fmt)     # Check shared library
-> 8790207171188
: ht:Fmt             # Now defined
-> 8790207171188




(getl 'sym1|lst1 ['sym2|cnt ..]) -> lst


Fetches the complete property list lst from a symbol. That
symbol is sym1 (if no other arguments are given), or a symbol found
by applying the get algorithm to
sym1|lst1 and the following arguments. See also putl and maps.


: (put 'X 'a 1)
-> 1
: (put 'X 'b 2)
-> 2
: (put 'X 'flg T)
-> T
: (getl 'X)
-> (flg (2 . b) (1 . a))




(glue 'any 'lst) -> sym


Builds a new transient symbol (string) by packing the any argument between
the individual elements of lst. See also text.


: (glue "," '(a b c d))
-> "a,b,c,d"




(goal '([pat 'any ..] . lst) ['sym 'any ..]) -> lst


Constructs a Pilog query list from the list of
clauses lst. The head of the argument list may consist of a
sequence of pattern symbols (Pilog variables) and expressions, which are used
together with the optional sym and any arguments to
form an initial environment. See also prove and fail.


: (goal '((likes John @X)))
-> (((1 (0) NIL ((likes John @X)) NIL T)))
: (goal '(@X 'John (likes @X @Y)))
-> (((1 (0) NIL ((likes @X @Y)) NIL ((0 . @X) 1 . John) T)))




(group 'lst ['flg]) -> lst


Builds a list of lists, by grouping all elements of lst with
the same CAR into a common sublist. If the list is known to be pre-grouped, a
non-NIL flg argument may be passed for faster
execution. See also Comparing, by, sort and uniq.


: (group '((1 . a) (1 . b) (1 . c) (2 . d) (2 . e) (2 . f)))
-> ((1 a b c) (2 d e f))
: (by name group '("x" "x" "y" "z" "x" "z"))
-> (("x" "x" "x") ("y") ("z" "z"))
: (by length group '(123 (1 2) "abcd" "xyz" (1 2 3 4) "XY"))
-> ((123 "xyz") ((1 2) "XY") ("abcd" (1 2 3 4))




(gt0 'any) -> num | NIL


Returns num when the argument is a number and greater than
zero, otherwise NIL. See also lt0, le0, ge0, =0
and n0.


: (gt0 -2)
-> NIL
: (gt0 3)
-> 3







================================================
FILE: doc/refH.html
================================================
H
H



*Hup


Global variable holding a (possibly empty) prg body, which will
be executed when a SIGHUP signal is sent to the current process. See also
alarm, sigio, *Winch, *Sig[12], *TStp[12] and *Term.


: (de *Hup (msg 'SIGHUP))
-> *Hup




+Hook


Prefix class for +relations,
typically +Link or +Joint. In essence, this maintains an local
database in the referred object. See also Database.


(rel sup (+Hook +Link) (+Sup))   # Supplier
(rel nr (+Key +Number) sup)      # Item number, unique per supplier
(rel dsc (+Ref +String) sup)     # Item description, indexed per supplier




+Hook2


Prefix class for +index
relations. It maintains both a normal (global) index, and an object-local index
in the corresponding +Hook object.
See also Database.


(rel nm (+Hook2 +IdxFold +String) 3 shop)       # Global and shop-local index




(h) -> flg


(Debug mode only) Edits the history in memory with Vip. Returns
T if Vip was exited with "x" and NIL if exited with
"q". See also history and vi.


: (h)    # Edit history
-> T     # "x"




(has 'any) -> lst


(Debug mode only) Returns a list of all internal symbols which have the
value any. See also who,
can, what and dep.


: +
-> 270310
: (has 270310)
-> (+ @)
: meth
-> 267259
: (has 267259)
-> (@ js> dec> inc> upd> ele> log> chk> val> del> rel> all> url> zap> clr> str> has>




(hash 'any) -> cnt


Generates a 20-bit number (1-1048576) from any, suitable as a
hash value for various purposes, like randomly balanced idx structures. See also cache, enum, rev and seed.


: (hash 0)
-> 1
: (hash 1)
-> 723519
: (hash "abc")
-> 557424




(hax 'num) -> sym


(hax 'sym) -> num


Converts a number num to a string in hexadecimal/alpha
notation, or a hexadecimal/alpha formatted string to a number. The digits are
represented with '@' (zero) and the letters 'A' -
'O' (from "alpha" to "omega"). This format is used internally for
the names of external symbols.
See also hex, bin and oct.


: (hax 7)
-> "G"
: (hax 16)
-> "A@"
: (hax 255)
-> "OO"
: (hax "A")
-> 1




(hd 'sym ['cnt]) -> NIL


(Debug mode only) Displays a hexadecimal dump of the file given by
sym, limited to cnt lines. See also proc.


:  (hd "lib.l" 4)
00000000  23 20 32 33 64 65 63 30 39 61 62 75 0A 23 20 28  # 23dec09abu.# (
00000010  63 29 20 53 6F 66 74 77 61 72 65 20 4C 61 62 2E  c) Software Lab.
00000020  20 41 6C 65 78 61 6E 64 65 72 20 42 75 72 67 65   Alexander Burge
00000030  72 0A 0A 28 64 65 20 74 61 73 6B 20 28 4B 65 79  r..(de task (Key
-> NIL




(head 'cnt|lst 'lst) -> lst


Returns a new list made of the first cnt elements of
lst. If cnt is negative, it is added to the length of
lst. If the first argument is a lst, head
is a predicate function returning that argument list if it is equal
to the head of the second argument, and NIL otherwise. See also
tail and pre?.


: (head 3 '(a b c d e f))
-> (a b c)
: (head 0 '(a b c d e f))
-> NIL
: (head 10 '(a b c d e f))
-> (a b c d e f)
: (head -2 '(a b c d e f))
-> (a b c d)
: (head '(a b c) '(a b c d e f))
-> (a b c)




head/3


(Deprecated since version 25.5.30) Pilog predicate that succeeds if the first
(string) argument is a prefix of the string representation of the result
of applying the get algorithm
to the following arguments. Typically used as filter predicate in
select/3 database queries.
See also pre?, isa/2, same/3, bool/3, range/3, fold/3, part/3 and tolr/3.


: (?
   @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="Muller" @Tel="37" @CuSu={C3} @Name="Miller" @Phone="37 4773 82534"
-> NIL




(heap 'flg) -> cnt


Returns the total size of the cell heap space in megabytes. If
flg is non-NIL, the size of the currently free space
is returned. See also stack and
gc.


: (gc 4)
-> 4
: (heap)
-> 5
: (heap T)
-> 4




(hear 'cnt) -> cnt


Uses the file descriptor cnt as an asynchronous command input
channel. Any executable list received via this channel will be executed in the
background. As this mechanism is also used for inter-family communication (see
tell), hear is usually
only called explicitly by a top level parent process.


: (call 'mkfifo "fifo/cmd")
-> T
: (hear (open "fifo/cmd"))
-> 3




(help 'sym ['flg]) -> sym


(Debug mode only) Dumps the reference documentation for sym to
the current output channel. If flg is non-NIL, the
examples are dumped too. See also Function Reference
and doc.


: (help 'car)
========================================
(car 'var) -> any

List access: Returns the value of var if it is a symbol, or the first element if
it is a list. See also cdr and c..r.

-> car

: (help 'car T)
========================================
(car 'var) -> any

List access: Returns the value of var if it is a symbol, or the first element if
it is a list. See also cdr and c..r.

: (car (1 2 3 4 5 6))
-> 1

-> car




(here ['sym]) -> sym


Echoes the current input stream until sym is encountered, or
until end of file. See also echo.


$ cat hello.l
(html 0 "Hello" "lib.css" NIL
   (<h2> NIL "Hello")
   (here) )
<p>Hello!</p>
<p>This is a test.</p>

$ pil @lib/http.l @lib/xhtml.l hello.l
HTTP/1.0 200 OK
Server: PicoLisp
Date: Sun, 03 Jun 2007 11:41:27 GMT
Cache-Control: max-age=0
Cache-Control: no-cache
Content-Type: text/html; charset=utf-8

<!DOCTYPE html>
<html lang="en">
<head>
<meta name="viewport" content="width=device-width"/>
<title>Hello</title>
<link rel="stylesheet" href="http://:/lib.css" type="text/css"/>
</head>
<body><h2>Hello</h2>
<p>Hello!</p>
<p>This is a test.</p>
</body></html>




(hex 'num ['num]) -> sym


(hex 'sym) -> num


Converts a number num to a hexadecimal string, or a hexadecimal
string sym to a number. In the first case, if the second argument
is given, the result is separated by spaces into groups of such many digits. See
also bin, oct, hax and format.


: (hex 273)
-> "111"
: (hex "111")
-> 273
: (hex 1234567 4)
-> "12 D687"




(history ['lst]) -> lst


When called without argument, history returns the current
readline(3) history. lst is a list of strings.
Otherwise, the history is set to lst. See also Invocation.


: (+ 1 2 3)
-> 6
: (history)
-> ("(+ 1 2 3)" "(history)")




(host 'any) -> sym


Returns the hostname corresponding to the given IP address. See also
*Adr.


: (host "80.190.158.9")
-> "www.leo.org"







================================================
FILE: doc/refI.html
================================================
I
I



+Idx


Prefix class for maintaining non-unique full-text indexes to +String relations, a subclass of +Ref. Accepts optional arguments for the
minimally indexed substring length (defaults to 3), and a +Hook attribute. Often used in combination
with the +Sn soundex index, or the
+Fold index prefix classes. See also
Database.


(rel nm (+Sn +Idx +String))  # Name




+IdxFold


Prefix class for maintaining non-unique indexes to subsequent substrings of
the folded individual words of
+String relations. Accepts optional
arguments for the minimally indexed substring length (defaults to 3), and a
+Hook attribute. See also +Idx and Database.


(rel nm (+IdxFold +String))            # Item Description




+index


Abstract base class of all database B-Tree index relations (prefix classes
for +relations). The class
hierarchy includes +Key, +Ref, +Idx and +IdxFold. See also Database.


(isa '+index Rel)  # Check for an index relation




(id 'num ['num]) -> sym


(id 'sym [NIL]) -> num


(id 'sym T) -> (num . num)


Converts one (the internal block number) or two (file and block) numbers to
an external symbol, or an external symbol to a number or a pair of numbers.


: (id 7)
-> {7}
: (id 1 2)
-> {2}
: (id '{A2})
-> 2
: (id '{A2} T)
-> (2 . 2)




(idx 'var 'any 'flg) -> lst


(idx 'var 'any) -> lst


(idx 'var) -> lst


Maintains an index tree in var, and checks for the existence of
any. If any is contained in var, the
corresponding subtree is returned, otherwise NIL. In the first
form, any is destructively inserted into the tree if
flg is non-NIL (and any was not already
there), or deleted from the tree if flg is NIL. If all
elements are inserted in sorted order, the tree degenerates into a linear list.
In such cases, 0 may be passed for flg to randomize
the insertion order. The second form only checks for existence, but does not
change the index tree. In the third form (when called with a single
var argument) the contents of the tree are returned as a sorted
list.

See also lup, enum, hash, rev, depth, sort, balance and member.


: (idx 'X 'd T)                              # Insert data
-> NIL
: (idx 'X 2 T)
-> NIL
: (idx 'X '(a b c) T)
-> NIL
: (idx 'X 17 T)
-> NIL
: (idx 'X 'A T)
-> NIL
: (idx 'X 'd T)
-> (d (2 NIL 17 NIL A) (a b c))              # 'd' already existed
: (idx 'X T T)
-> NIL
: X                                          # View the index tree
-> (d (2 NIL 17 NIL A) (a b c) NIL T)
: (idx 'X 'A)                                # Check for 'A'
-> (A)
: (idx 'X 'B)                                # Check for 'B'
-> NIL
: (idx 'X)
-> (2 17 A d (a b c) T)                      # Get list
: (idx 'X 17 NIL)                            # Delete '17'
-> (17 NIL A)
: X
-> (d (2 NIL A) (a b c) NIL T)               # View it again
: (idx 'X)
-> (2 A d (a b c) T)                         # '17' is deleted

: (off X Y)
-> NIL
: (for I 9 (idx 'X I T))                     # Sorted insert order
-> NIL
: (for I 9 (idx 'Y I 0))                     # Randomize
-> NIL
: (view X T)
                        9
                     8
                  7
               6
            5
         4
      3
   2
1
-> NIL
: (view Y T)
         9
      8
         7
   6
      5
         4
3
   2
      1
-> NIL




(if 'any1 any2 . prg) -> any


Conditional execution: If the condition any1 evaluates to
non-NIL, any2 is evaluated and returned. Otherwise,
prg is executed and the result returned. See also ifn, cond, when and if2.


: (if (> 4 3) (println 'OK) (println 'Bad))
OK
-> OK
: (if (> 3 4) (println 'OK) (println 'Bad))
Bad
-> Bad




(if2 'any1 'any2 any3 any4 any5 . prg) -> any


Four-way conditional execution for two conditions: If both conditions
any1 and any2 evaluate to non-NIL,
any3 is evaluated and returned. Otherwise, any4 or
any5 is evaluated and returned if any1 or
any2 evaluate to non-NIL, respectively. If none of the
conditions evaluate to non-NIL, prg is executed and
the result returned. See also if and
cond.


: (if2 T T 'both 'first 'second 'none)
-> both
: (if2 T NIL 'both 'first 'second 'none)
-> first
: (if2 NIL T 'both 'first 'second 'none)
-> second
: (if2 NIL NIL 'both 'first 'second 'none)
-> none




(if@@ 'any1 any2 . prg) -> any


Conditional execution: If the value of the global variable @@ is non-NIL after the evaluation
of any1, any2 is evaluated and returned. Otherwise,
prg is executed and the result returned. In both cases, @ will hold the value of any1. See
also if and if2.


: (de foo (N)
   (if (lt0 N)
      (throw 'lt0 N)
      (sqrt N) ) )
-> foo

: (if@@ (catch 'lt0 (foo 64))
   (msg @ " negative")
   @ )
-> 8

: (if@@ (catch 'lt0 (foo -64))
   (msg @ " negative")
   @ )
-64 negative
-> -64




(ifn 'any1 any2 . prg) -> any


Conditional execution ("If not"): If the condition any1
evaluates to NIL, any2 is evaluated and returned.
Otherwise, prg is executed and the result returned. See also
if, nor, nand, unless and nond.


: (ifn (= 3 4) (println 'OK) (println 'Bad))
OK
-> OK




(import . lst) -> lst


Wrapper function for intern.
Typically used to import symbols from other namespaces, as created by symbols. lst should be
a list of symbols. See also pico, private and local and export.


: (import libA~foo libB~bar)
-> (foo bar)




(in 'any . prg) -> any


Opens any as input channel during the execution of
prg. The current input channel will be saved and restored
appropriately. If the argument is NIL, standard input is used. If
the argument is a symbol, it is used as a file name (opened in read-only mode).
If it is a positive number, it is used as the descriptor of an open file. If it
is a negative number, the saved input channel such many levels above the current
one is used. Otherwise (if it is a list), it is taken as a command with
arguments, and a pipe is opened for input. The (system dependent) exit status
code of the child process is stored in the global variable @@. See also out, err, fd, ipid, call, load, file, poll, pipe and ctl.


: (in "a" (list (read) (read) (read)))  # Read three items from file "a"
-> (123 (a b c) def)

: (in '(file "-b" "--mime" "bin/picolisp")  # Get the mime type
   (line T) )
-> "application/x-executable; charset=binary"




(inc 'num) -> num


(inc 'var ['num]) -> num


The first form returns the value of num incremented by 1. The
second form increments the VAL of var by 1, or by
num. If the first argument is NIL, it is returned
immediately. (inc Num) is equivalent to (+ Num 1) and
(inc 'Var) is equivalent to (set 'Var (+ Var 1)). See
also dec and +.


: (inc 7)
-> 8
: (inc -1)
-> 0
: (zero N)
-> 0
: (inc 'N)
-> 1
: (inc 'N 7)
-> 8
: N
-> 8

: (setq L (1 2 3 4))
-> (1 2 3 4)
: (inc (cdr L))
-> 3
: L
-> (1 3 3 4)




(inc! 'obj 'sym ['num]) -> num


Transaction wrapper function for inc. num defaults to 1. Note that
for incrementing a property value of an entity typically the inc!> message is used. See also
new!, request!, set! and put!.


(inc! Obj 'cnt 0)  # Incrementing a property of a non-entity object




(index 'any 'lst) -> cnt | NIL


Returns the cnt position of any in
lst, or NIL if it is not found. See also offset and sub?.


: (index 'c '(a b c d e f))
-> 3
: (index '(5 6) '((1 2) (3 4) (5 6) (7 8)))
-> 3




(info 'any ['flg]) -> (cnt|flg dat . tim)


Returns information about a file with the name any: The current
size cnt in bytes, and the modification date and time (UTC, or
local time if flg is zero). For directories, T is
returned instead of the size, and NIL for other non-regular files.
The file argument itself is stored in the global variable @@). If flg is non-NIL
and any is the name of a symbolic link, then the link itself is
used, not the file that it refers to. See also dir, date and time.


$ ls -l x.l
-rw-r--r--   1 abu      users         208 Jun 17 08:58 x.l
$ pil +
: (info "x.l")
-> (208 730594 . 32315)
: (stamp 730594 32315)
-> "2000-06-17 08:58:35"




(init 'tree ['any1] ['any2]) -> lst


Initializes a structure for stepping iteratively through a database tree.
any1 and any2 may specify a range of keys. If
any1 is greater than any2, the traversal will be in
opposite direction. See also tree,
step, iter and scan.


: (init (tree 'nr '+Item) 3 5)
-> (((3 . 5) ((3 NIL . {B3}) (4 NIL . {B4}) (5 NIL . {B5}) (6 NIL . {B6}))))




(input exe . prg) -> any


Establishes an input stream, by redirecting the current input channel during
the execution of prg. The current input channel will be saved and
restored appropriately. exe is executed (in the context of the
original input channel) whenever a character is required by read calls in
prg, and should return a single character upon each execution. See
also output, in and pipe.


: (input "A" (char))
-> "A"
: (let L (chop "(+ 2 (* 3 4))")
   (input (++ L) (read)) )
-> (+ 2 (* 3 4))
: (let L (chop "AQIDBAUGBw==")
   (input (++ L)
      (while (ext:Base64)
         (printsp @) ) ) )
1 2 3 4 5 6 7 -> 7




(insert 'cnt 'lst 'any) -> lst


Inserts any into lst at position cnt.
This is a non-destructive operation. See also remove, place, append, delete and replace.


: (insert 3 '(a b c d e) 777)
-> (a b 777 c d e)
: (insert 1 '(a b c d e) 777)
-> (777 a b c d e)
: (insert 9 '(a b c d e) 777)
-> (a b c d e 777)




(intern 'any ['nsp]) -> sym


Creates or finds an internal symbol. If a symbol with the name
any is already intern, it is returned. Otherwise, any
is interned in the current namespace
and returned. If nsp is non-NIL,
any is always interned in the current namespace (if
nsp is T) or in the given namespace, even if
it is found in other namespaces. See also symbols, zap, import and extern.


: (intern "abc")
-> abc
: (intern 'car)
-> car
: ((intern "car") (1 2 3))
-> 1
: ((intern '("c" "a" "r")) (1 2 3))
-> 1




(ipid) -> pid | NIL


Returns the corresponding process ID when the current input channel is
reading from a pipe, otherwise NIL. See also opid, in, pipe and load.


: (in '(ls "-l") (println (line T)) (kill (ipid)))
"total 7364"
-> T




(isa 'cls|typ 'obj) -> obj | NIL


Returns obj when it is an object that inherits from
cls or type. See also OO
Concepts, class, type, new and object.


: (isa '+Address Obj)
-> {A17}
: (isa '(+Male +Person) Obj)
-> NIL




isa/2


(Deprecated since version 25.5.30) Pilog predicate that succeeds if the second
argument is of the type or class given by the first argument, according
to the isa function. Typically
used in db/3 or select/3 database queries. See also
same/3, bool/3, range/3, head/3, fold/3, part/3 and tolr/3.


: (? (db nm +Person @Prs) (isa +Woman @Prs) (val @Nm @Prs nm))
 @Prs={A44} @Nm="Alexandra of Denmark"
 @Prs={A124} @Nm="Alice Maud Mary"
 @Prs={A21} @Nm="Anne"
 @Prs={A57} @Nm="Augusta Victoria".  # Stop




(iter 'tree ['fun] ['any1] ['any2] ['flg]) -> NIL


Iterates through a database tree by applying fun to all values.
fun defaults to println. any1 and
any2 may specify a range of keys. If any1 is greater
than any2, the traversal will be in opposite direction. Note that
the keys need not to be atomic, depending on the application's index structure.
If flg is non-NIL, partial keys are skipped. See also
tree, ubIter, scan, init and step.


: (iter (tree 'nr '+Item))
{B1}
{B2}
{B3}
{B4}
{B5}
{B6}
-> NIL
: (iter (tree 'nr '+Item) '((This) (println (: nm))))
"Main Part"
"Spare Part"
"Auxiliary Construction"
"Enhancement Additive"
"Metal Fittings"
"Gadget Appliance"
"Testartikel"
-> NIL







================================================
FILE: doc/refJ.html
================================================
J
J



+Joint


Class for bidirectional object relations, a subclass of +Link. Expects a (symbolic) attribute, a list
of classes as type of the referred
database object (of class +Entity),
and two optional functions called when 'put'ting and/or 'get'ting a value. A
+Joint corresponds to two +Links, where the attribute
argument is the relation of the back-link in the referred object. See also Database.


(class +Ord +Entity)                   # Order class
(rel pos (+List +Joint) ord (+Pos))    # List of positions in that order
...
(class +Pos +Entity)                   # Position class
(rel ord (+Joint) pos (+Ord))          # Back-link to the parent order




(job 'lst . prg) -> any


Executes a job within its own environment (as specified by symbol-value
pairs in lst). The current values of all symbols are saved, the
symbols are bound to the values in lst, prg is
executed, then the (possibly modified) symbol values are (destructively) stored
in the environment list, and the symbols are restored to their original values.
The return value is the result of prg. Typically used in curried functions and *Run tasks. See also env, bind, let, use and state.


: (de tst ()
   (job '((A . 0) (B . 0))
      (println (inc 'A) (inc 'B 2)) ) )
-> tst
: (tst)
1 2
-> 2
: (tst)
2 4
-> 4
: (tst)
3 6
-> 6
: (pp 'tst)
(de tst NIL
   (job '((A . 3) (B . 6))
      (println (inc 'A) (inc 'B 2)) ) )
-> tst




(journal ['T] 'any ..) -> T


Reads journal data from the files with the names any, and
writes all changes to the database. If the first argument is T, the
replication journal and transaction logs are disabled. See also pool.


: (journal "db.log")
-> T







================================================
FILE: doc/refK.html
================================================
K
K



+Key


Prefix class for maintaining unique indexes to +relations, a subclass of +index. Accepts an optional argument for a
+Hook attribute. See also Database.


(rel nr (+Need +Key +Number))  # Mandatory, unique Customer/Supplier number




(key ['cnt ['var]]) -> sym


Returns the next character from standard input as a single-character
transient symbol. The console is set to raw mode. While waiting for a key press,
a poll(2) system call is executed for all file descriptors and
timers in the VAL of the global variable *Run. If cnt is
non-NIL, that amount of milliseconds is waited maximally, and
NIL is returned upon timeout. Otherwise, the remaining milliseconds
are optionally stored in var. See also raw and wait.


: (key)           # Wait for a key
-> "a"            # 'a' pressed




(kids) -> lst


Returns a list of process IDs of all running child processes. See also
fork, detach, pipe, tell, proc and kill.


: (unless (fork) (wait 60000) (bye))
-> NIL
: (unless (fork) (wait 60000) (bye))
-> NIL

: (proc 'pil)
  PID  PPID  STARTED  SIZE %CPU WCHAN  CMD
 2205 22853 19:45:24  1336  0.1 -      /usr/bin/picolisp /usr/lib/picolisp/lib.l /usr/bin/pil +
 2266  2205 19:45:30  1336  0.0 -        /usr/bin/picolisp /usr/lib/picolisp/lib.l /usr/bin/pil +
 2300  2205 19:45:33  1336  0.0 -        /usr/bin/picolisp /usr/lib/picolisp/lib.l /usr/bin/pil +
-> T

: (kids)
-> (2300 2266)




(kill 'pid ['cnt]) -> flg


Sends a signal with the signal number cnt (or SIGTERM if
cnt is not given) to the process with the ID pid.
Returns T if successful.


: (kill *Pid 20)                                # Stop current process

[2]+  Stopped               pil +               # Unix shell
$ fg                                            # Job control: Foreground
pil +
-> T                                            # 'kill' was successful







================================================
FILE: doc/refL.html
================================================
L
L



+Link


Class for object relations, a subclass of +relation. Expects a list of classes as
type of the referred database object
(of class +Entity). See also Database.


(rel sup (+Ref +Link) NIL (+CuSu))  # Supplier (class Customer/Supplier)




+List


Prefix class for a list of identical relations. Objects of that class
maintain a list of Lisp data of uniform type. See also Database.


(rel pos (+List +Joint) ord (+Pos))  # Positions
(rel nm (+List +Ref +String))        # List of indexed strings
(rel val (+Ref +List +Number))       # Indexed list of numeric values




(last 'lst) -> any


Returns the last element of lst. See also fin and tail.


: (last (1 2 3 4))
-> 4
: (last '((a b) c (d e f)))
-> (d e f)




(later 'var . prg) -> var


Executes prg in a pipe'ed child process. The return value of
prg will later be available in var. Note that
later uses pr and rd to communicate the result, so prg
should not write any data to standard output as a side effect.


: (prog1  # Parallel background calculation of square numbers
   (mapcan '((N) (later (cons) (* N N))) (1 2 3 4))
   (wait NIL (full @)) )
-> (1 4 9 16)




(le0 'any) -> num | NIL


Returns num when the argument is a number less or equal zero,
otherwise NIL. See also lt0, ge0, gt0, =0
and n0.


: (le0 -2)
-> -2
: (le0 0)
-> 0
: (le0 3)
-> NIL




(leaf 'tree) -> any


Returns the first leaf (i.e. the value of the smallest key) in a database
tree. See also tree, minKey, maxKey and step.


: (leaf (tree 'nr '+Item))
-> {B1}
: (db 'nr '+Item (minKey (tree 'nr '+Item)))
-> {B1}




(length 'any) -> cnt | T


Returns the "length" of any. For numbers this is the number of
decimal digits in the value (plus 1 for negative values), for symbols it is the
number of characters in the name, and for lists it is the number of cells (or
T for circular lists). See also size and bytes.


: (length "abc")
-> 3
: (length "äbc")
-> 3
: (length 123)
-> 3
: (length (1 (2) 3))
-> 3
: (length (1 2 3 .))
-> T




(less 'any ['cnt]) -> any


Returns a reduced form of any, where for each list and its
sublists only the first cnt elements (default 4), possibly followed
by .., are retained.


: (less '(a b c d e f))
-> (a b c d ..)
: (less '((a b c) ((d e f g h i) (j k l m n))))
-> ((a b c) ((d e f ..) (j k ..)))
: (less '((a b c) ((d e f g h i) (j k l m n))) 2)
-> ((a b ..) ((d ..) ..))




(let sym 'any . prg) -> any


(let (sym|lst 'any ..) . prg) -> any


Defines local variables. The value of the symbol sym - or the
values of the symbols sym in the list of the second form - are
saved and the symbols are bound to the evaluated any arguments. The
lst arguments in the second form may consist only of symbols and
sublists, and match the any argument (destructuring bind).
prg is executed, then the symbols are restored to their original
values. The result of prg is returned. It is an error condition to
pass NIL as a sym argument. In destructuring patterns,
NIL denotes a "don't care" position. See also let?, bind, recur, with, for, job and use.


: (setq  X 123  Y 456)
-> 456
: (let X "Hello" (println X))
"Hello"
-> "Hello"
: (let (X "Hello" Y "world") (prinl X " " Y))
Hello world
-> "world"
: X
-> 123
: Y
-> 456

: (let (A 1  (B . C) (2 3)  D 4)
   (list A B C D) )
-> (1 2 (3) 4)

: (let (((A . B) (C) . D) '((1 2 3) (4 5 6) 7 8 9))
   (list A B C D) )
-> (1 (2 3) 4 (7 8 9))

: (let (((A . NIL) NIL NIL D) '((1 2 3) (4 5 6) 7 8 9))
   (trail T) )
-> (A 1 D 8)




(let? sym 'any . prg) -> any


Conditional local variable binding and execution: If any
evaluates to NIL, NIL is returned. Otherwise, the
value of the symbol sym is saved and sym is bound to
the evaluated any argument. prg is executed, then
sym is restored to its original value. The result of
prg is returned. It is an error condition to pass NIL
as the sym argument. (let? sym 'any ..) is equivalent
to (when 'any (let sym @ ..)). See also let, bind, job and use.


: (setq Lst (1 NIL 2 NIL 3))
-> (1 NIL 2 NIL 3)
: (let? A (pop 'Lst) (println 'A A))
A 1
-> 1
: (let? A (pop 'Lst) (println 'A A))
-> NIL




(lieu 'any) -> sym | NIL


Returns the argument any when it is an external symbol and
currently manifest in heap space, otherwise NIL. See also ext?.


: (lieu *DB)
-> {1}




(line 'flg ['cnt ..]) -> lst|sym


Reads a line of characters from the current input channel. End of line is
recognized as linefeed (hex "0A"), carriage return (hex "0D"), or the
combination of both. (Note that a single carriage return may not work on network
connections, because the character look-ahead to distinguish from
return+linefeed can block the connection.) If flg is
NIL, a list of single-character transient symbols is returned. When
cnt arguments are given, subsequent characters of the input line
are grouped into sublists, to allow parsing of fixed field length records. If
flg is non-NIL, strings are returned instead of
single-character lists. NIL is returned upon end of file. See also
char, read, till and eof.


: (line)
abcdefghijkl
-> ("a" "b" "c" "d" "e" "f" "g" "h" "i" "j" "k" "l")
: (line T)
abcdefghijkl
-> "abcdefghijkl"
: (line NIL 1 2 3)
abcdefghijkl
-> (("a") ("b" "c") ("d" "e" "f") "g" "h" "i" "j" "k" "l")
: (line T 1 2 3)
abcdefghijkl
-> ("a" "bc" "def" "g" "h" "i" "j" "k" "l")




(link 'any ..) -> any


Links one or several new elements any to the end of the list in
the current make environment. This
operation is efficient also for long lists, because a pointer to the last
element of the list is maintained. link returns the last linked
argument. See also yoke, chain and made.


: (make
   (println (link 1))
   (println (link 2 3)) )
1
3
-> (1 2 3)




(lint 'sym) -> lst


(lint 'sym 'cls) -> lst


(lint '(sym . cls)) -> lst


(Debug mode only) 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 an association list of diagnoses, where var
indicates improper variables, dup duplicate parameters,
def an undefined function, bnd an unbound variable,
and use unused variables. See also noLint, lintAll, debug, trace and *Dbg.


: (de foo (R S T R)     # 'T' is an improper parameter, 'R' is duplicated
   (let N 7             # 'N' is unused
      (bar X Y) ) )     # 'bar' is undefined, 'X' and 'Y' are not bound
-> foo
: (lint 'foo)
-> ((var T) (dup R) (def bar) (bnd Y X) (use N))




(lintAll ['sym ..]) -> lst


(Debug mode only) Applies lint to
all internal symbols - and optionally
to all files sym - and returns a list of diagnoses. See also
noLint.


: (more (lintAll "file1.l" "file2.l"))
...




(lisp 'sym ['fun]) -> num


Installs under the tag sym a callback function
fun, and returns a pointer num suitable to be passed
to a C function via 'native'. If fun is NIL, the
corresponding entry is freed. Maximally 24 callback functions can be installed
that way. 'fun' should be a function of maximally five numbers, and should
return a number. "Numbers" in this context are 64-bit scalars, and may not only
represent integers, but also pointers or other encoded data. See also native and struct.


(load "@lib/clang.l")

(clang "ltest" NIL
   (cbTest (Fun) cbTest 'N Fun) )

long cbTest(int(*fun)(int,int,int,int,int)) {
   return fun(1,2,3,4,5);
}
/**/

: (cbTest
   (lisp 'cbTest
      '((A B C D E)
         (msg (list A B C D E))
         (* A B C D E) ) ) )
(1 2 3 4 5)
-> 120




(list 'any ['any ..]) -> lst


Returns a list of all any arguments. See also cons.


: (list 1 2 3 4)
-> (1 2 3 4)
: (list 'a (2 3) "OK")
-> (a (2 3) "OK")




lst/3


Pilog predicate that returns subsequent list
elements, after applying the get
algorithm to that object and the following arguments. Often used in database
queries. See also map/3.


: (? (db nr +Ord 1 @Ord) (lst @Pos @Ord pos))
 @Ord={B7} @Pos={A1}
 @Ord={B7} @Pos={A2}
 @Ord={B7} @Pos={A3}
-> NIL




(lst? 'any) -> flg


Returns T when the argument any is a (possibly
empty) list (NIL or a cons pair). See also pair.


: (lst? NIL)
-> T
: (lst? (1 . 2))
-> T
: (lst? (1 2 3))
-> T




(listen 'cnt1 ['cnt2]) -> cnt | NIL


Listens at a socket descriptor cnt1 (as received by port) for an incoming connection, and returns
the new socket descriptor cnt. While waiting for a connection, a
poll(2) system call is executed for all file descriptors and timers
in the VAL of the global variable *Run. If cnt2 is
non-NIL, that amount of milliseconds is waited maximally, and
NIL is returned upon timeout. The global variable *Adr
is set to the IP address of the client. See also accept, connect, *Adr.


: (setq *Socket
   (listen (port 6789) 60000) )  # Listen at port 6789 for max 60 seconds
-> 4
: *Adr
-> "127.0.0.1"




(lit 'any) -> any


Returns the literal (i.e. quoted) value of any, by
consing it with the quote function if necessary. See also strip.


: (lit T)
-> T
: (lit 1)
-> 1
: (lit '(1))
-> (1)
: (lit '(a))
-> '(a)




(load 'any ..) -> any


Loads all any arguments. Normally, the name of each argument is
taken as a file to be executed in a read-eval loop. The argument semantics are
identical to that of in, with the
exception that if an argument is a symbol and its first character is a hyphen
'-', then that argument is parsed as an executable list (without the surrounding
parentheses). When any is T, all remaining command
line arguments are loaded recursively. When any is
NIL, standard input is read, a prompt is issued before each read
operation, the results are printed to standard output (read-eval-print loop),
and load terminates when an empty line is entered. In any case,
load terminates upon end of file, or when NIL is read.
The index for transient symbols is cleared before and after the load, so that
all transient symbols in a file have a local scope. If the namespace was
switched (with symbols) while
executing a file, it is restored to the previous one. Returns the value of the
last evaluated expression. See also script, ipid, call, file, in, out
and str.


: (load "lib.l" "-* 1 2 3")
-> 6




(loc 'sym 'lst) -> sym


Locates in lst a transient symbol with the same name as
sym. Allows to get hold of otherwise inaccessible symbols.


: (loc "X" curry)
-> "X"
: (== @ "X")
-> NIL




(local) sym|lst


Intern symbols locally in the current namespace. (local) expects a
single symbol or a list of symbols immediately following in the current
input stream. See also pico,
symbols, private, export, import and intern.


: (symbols 'myLib 'pico)
-> (pico)
myLib: (local) (foo bar)

myLib: (de foo (A)  # 'foo' is local to 'myLib'
   ...
myLib: (de bar (B)  # 'bar' is local to 'myLib'
   ...




(locale 'sym1 'sym2 ['sym ..])


Sets the current locale to that given by the country file sym1
and the language file sym2 (both located in the "loc/" directory),
and optional application-specific directories sym. The locale
influences the language, and numerical, date and other formats. See also
*Uni, datStr, strDat, expDat, day, telStr, expTel and and money.


: (locale "DE" "de" "app/loc/")
-> NIL
: ,"Yes"
-> "Ja"




(lock ['sym]) -> cnt | NIL


Write-locks an external symbol sym (file record locking), or
the whole database root file if sym is NIL. Returns
NIL if successful, or the ID of the process currently holding the
lock. When sym is non-NIL, the lock is released at the
next call to commit or rollback, otherwise only when another
database is opened with pool, or when
the process terminates. See also *Solo.


: (lock '{1})        # Lock single object
-> NIL
: (lock)             # Lock whole database
-> NIL




(loop ['any | (NIL 'any . prg) | (T 'any . prg) ..]) -> any


Endless loop with multiple conditional exits: The body is executed an
unlimited number of times. If a clause has NIL or T as
its CAR, the clause's second element is evaluated as a condition and - if the
result is NIL or non-NIL, respectively - the
prg is executed and the result returned. See also do and for.


: (let N 3
   (loop
      (prinl N)
      (T (=0 (dec 'N)) 'done) ) )
3
2
1
-> done




(low? 'any) -> sym | NIL


Returns any when the argument is a string (symbol) that starts
with a lowercase character. See also lowc and upp?


: (low? "a")
-> "a"
: (low? "A")
-> NIL
: (low? 123)
-> NIL
: (low? ".")
-> NIL




(lowc 'any) -> any


Lower case conversion: If any is not a symbol, it is returned
as it is. Otherwise, a new transient symbol with all characters of
any, converted to lower case, is returned. See also uppc, fold and low?.


: (lowc 123)
-> 123
: (lowc "ABC")
-> "abc"




(lt0 'any) -> num | NIL


Returns num when the argument is a number and less than zero,
otherwise NIL. See also le0, ge0, gt0, =0
and n0.


: (lt0 -2)
-> -2
: (lt0 3)
-> NIL




(lup 'lst 'any) -> lst


(lup 'lst 'any 'any2) -> lst


Looks up any in the CAR-elements of cons pairs stored in the
index tree lst, as built-up by idx. In the first form, the first found cons
pair is returned, in the second form a list of all pairs whose CAR is in the
range any .. any2. If the tree is empty,
NIL is returned immediately. See also enum? and assoc.


: (idx 'A 'a T)
-> NIL
: (idx 'A (1 . b) T)
-> NIL
: (idx 'A 123 T)
-> NIL
: (idx 'A (1 . a) T)
-> NIL
: (idx 'A (1 . c) T)
-> NIL
: (idx 'A (2 . d) T)
-> NIL
: (idx 'A)
-> (123 a (1 . a) (1 . b) (1 . c) (2 . d))
: (lup A 1)
-> (1 . b)
: (lup A 2)
-> (2 . d)
: (lup A 1 1)
-> ((1 . a) (1 . b) (1 . c))
: (lup A 1 2)
-> ((1 . a) (1 . b) (1 . c) (2 . d))







================================================
FILE: doc/refM.html
================================================
M
M



*Msg


A global variable holding the last recently issued error message. See also
Error Handling, *Err and ^.


: (+ 'A 2)
!? (+ 'A 2)
A -- Number expected
?
:
: *Msg
-> "Number expected"




+Mis


Prefix class to explicitly specify validation functions for +relations. Expects a function that takes
a value and an entity object, and returns NIL if everything is
correct, or an error string. See also Database.


(class +Ord +Entity)            # Order class
(rel pos (+Mis +List +Joint)    # List of positions in that order
   ((Val Obj)
      (when (memq NIL Val)
         "There are empty positions" ) )
   ord (+Pos) )




(macro prg) -> any


Substitues all pat? symbols in
prg (using fill), and
executes the result with run. Used
occasionally to call functions which otherwise do not evaluate their arguments.


: (de timerMessage (@N . @Prg)
   (setq @N (- @N))
   (macro
      (task @N 0 . @Prg) ) )
-> timerMessage
: (timerMessage 6000 (println 'Timer 6000))
-> (-6000 0 (println 'Timer 6000))
: (timerMessage 12000 (println 'Timer 12000))
-> (-12000 0 (println 'Timer 12000))
: (more *Run)
(-12000 2616 (println 'Timer 12000))
(-6000 2100 (println 'Timer 6000))
-> NIL
: Timer 6000
Timer 12000
...




(made ['lst1 ['lst2]]) -> lst


Initializes a new list value for the current make environment. All list elements already
produced with chain, link and yoke are discarded, and lst1 is
used instead. Optionally, lst2 can be specified as the new linkage
cell, otherwise the last cell of lst1 is used. When called without
arguments, made does not modify the environment. In any case, the
current list is returned.


: (make
   (link 'a 'b 'c)         # Link three items
   (println (made))        # Print current list (a b c)
   (made (1 2 3))          # Discard it, start new with (1 2 3)
   (link 4) )              # Link 4
(a b c)
-> (1 2 3 4)




(mail 'any 'cnt|lst 'sym1|lst2 'sym2|lst3 'sym3 'lst4 . prg)'


Sends an eMail via SMTP to a mail server at host any, port
cnt. If the second argument is a list, it should be a structure
(user password . port), and "@bin/ssl" will be called to establish
an encrypted connection. sym1|lst2 should be the "from" address (or
a cons pair of "reply-to" and "from"), sym2|lst3 the "to"
address(es), and sym3 the subject. lst4 is a list of
attachments, each one specified by three elements for path, name and mime type.
prg generates the mail body with prEval. See also connect.


(mail "localhost" 25                               # Local mail server
   "a@bc.de"                                       # "From" address
   "abu@software-lab.de"                           # "To" address
   "Testmail"                                      # Subject
   (quote
      "img/go.png" "go.png" "image/png"            # First attachment
      "img/7fach.gif" "7fach.gif" "image/gif" )    # Second attachment
   "Hello,"                                        # First line
   NIL                                             # (empty line)
   (prinl (pack "This is mail #" (+ 3 4))) )       # Third line




(make .. [(made 'lst ..)] .. [(link 'any ..)] ..) -> any


Initializes and executes a list-building process with the made, chain, link and yoke functions, and returns the resulting list.
The final linkage cell is stored in the global variable @@. For efficiency, pointers to the head and the
tail of the list are maintained internally.


: (make (link 1) (link 2 3) (link 4))
-> (1 2 3 4)
: (make (made (1 2 3)) (link 4))
-> (1 2 3 4)




(map 'fun 'lst ..) -> lst


Applies fun to lst and all successive CDRs. When
additional lst arguments are given, they are passed to
fun in the same way. Returns the result of the last application.
See also mapc, maplist, mapcar, mapcon, mapcan and filter.


: (map println (1 2 3 4) '(A B C))
(1 2 3 4) (A B C)
(2 3 4) (B C)
(3 4) (C)
(4) NIL
-> NIL




map/3


Pilog predicate that returns a list and
subsequent CDRs of that list, after applying the get algorithm to that object and the following
arguments. Often used in database queries. See also lst/3.


: (? (db nr +Ord 1 @Ord) (map @L @Ord pos))
 @Ord={B7} @L=({A1} {A2} {A3})
 @Ord={B7} @L=({A2} {A3})
 @Ord={B7} @L=({A3})
-> NIL




(mapc 'fun 'lst ..) -> any


Applies fun to each element of lst. When
additional lst arguments are given, their elements are also passed
to fun. Returns the result of the last application. See also
map, maplist, mapcar, mapcon, mapcan and filter.


: (mapc println (1 2 3 4) '(A B C))
1 A
2 B
3 C
4 NIL
-> NIL




(mapcan 'fun 'lst ..) -> lst


Applies fun to each element of lst. When
additional lst arguments are given, their elements are also passed
to fun. Returns a (destructively) concatenated list of all results.
See also map, mapc, maplist, mapcar, mapcon, filter.


: (mapcan reverse '((a b c) (d e f) (g h i)))
-> (c b a f e d i h g)




(mapcar 'fun 'lst ..) -> lst


Applies fun to each element of lst. When
additional lst arguments are given, their elements are also passed
to fun. Returns a list of all results. See also map, mapc, maplist, mapcon, mapcan and filter.


: (mapcar + (1 2 3) (4 5 6))
-> (5 7 9)
: (mapcar + (1 2 3) 5)
-> (6 7 8)
: (mapcar '((X Y) (+ X (* Y Y))) (1 2 3 4) (5 6 7 8))
-> (26 38 52 68)




(mapcon 'fun 'lst ..) -> lst


Applies fun to lst and all successive CDRs. When
additional lst arguments are given, they are passed to
fun in the same way. Returns a (destructively) concatenated list of
all results. See also map, mapc, maplist, mapcar, mapcan and filter.


: (mapcon copy '(1 2 3 4 5))
-> (1 2 3 4 5 2 3 4 5 3 4 5 4 5 5)




(maplist 'fun 'lst ..) -> lst


Applies fun to lst and all successive CDRs. When
additional lst arguments are given, they are passed to
fun in the same way. Returns a list of all results. See also
map, mapc, mapcar, mapcon, mapcan and filter.


: (maplist cons (1 2 3) '(A B C))
-> (((1 2 3) A B C) ((2 3) B C) ((3) C))




(maps 'fun 'sym ['lst ..]) -> any


Applies fun to all properties of sym. When
additional lst arguments are given, their elements are also passed
to fun. Returns the result of the last application. Note that
'maps' should only be used when the property list is not modified by
fun. Otherwise it is better to use a loop over the result of
getl. See also putl.


: (put 'X 'a 1)
-> 1
: (put 'X 'b 2)
-> 2
: (put 'X 'flg T)
-> T
: (getl 'X)
-> (flg (2 . b) (1 . a))
: (maps println 'X '(A B))
flg A
(2 . b) B
(1 . a) NIL
-> NIL




(mark 'sym|0 ['NIL | 'T | '0]) -> flg


Tests, sets or resets a mark for sym in the database (for a
second argument of NIL, T or 0,
respectively), and returns the old value. The marks are local to the current
process (not stored in the database), and vanish when the process terminates. If
the first argument is zero, all marks are cleared.


: (pool "db")
-> T
: (mark '{1} T)      # Mark
-> NIL
: (mark '{1})        # Test
-> T                 # -> marked
: (mark '{1} 0)      # Unmark
-> T
: (mark '{1})        # Test
-> NIL               # -> unmarked




(match 'lst1 'lst2) -> flg


Takes lst1 as a pattern to be matched against
lst2, and returns T when successful. Atoms must be
equal, and sublists must match recursively. Symbols in the pattern list with
names starting with an at-mark "@" (see pat?) are taken as wildcards. They can match
zero, one or more elements, and are bound to the corresponding data. See also
chop, split and fill.


: (match '(@A is @B) '(This is a test))
-> T
: @A
-> (This)
: @B
-> (a test)
: (match '(@X (d @Y) @Z) '((a b c) (d (e f) g) h i))
-> T
: @X
-> ((a b c))
: @Y
-> ((e f) g)
: @Z
-> (h i)




(max 'any1 'any2 ..) -> any


(max 'lst) -> any


Returns the largest of all any arguments, or of all elements in
lst. See also min and Comparing.


: (max 2 'a 'z 9)
-> z
: (max (5) (2 3) 'X)
-> (5)
: (max (2 4 1 3))
-> 4




(maxKey 'tree ['any1 ['any2]]) -> any


Returns the largest key in a database tree. If a minimal key
any1 and/or a maximal key any2 is given, the largest
key from that range is returned. See also tree, leaf, minKey and genKey.


: (maxKey (tree 'nr '+Item))
-> 7
: (maxKey (tree 'nr '+Item) 3 5)
-> 5




(maxi 'fun 'lst ..) -> any


Applies fun to each element of lst. When
additional lst arguments are given, their elements are also passed
to fun. Returns that element from lst for which
fun returned a maximal value (and stores the maximal value in the
global variable @@). See also mini and sort.


: (setq A 1  B 2  C 3)
-> 3
: (maxi val '(A B C))
-> C
: (maxi                          # Symbol with largest list value
   '((X)
      (and (pair (val X)) (size @)) )
   (all) )
-> pico




(member 'any 'lst) -> any


Returns the tail of lst that starts with any when
any is a member of lst, otherwise NIL.
See also memq, assoc and idx.


: (member 3 (1 2 3 4 5 6))
-> (3 4 5 6)
: (member 9 (1 2 3 4 5 6))
-> NIL
: (member '(d e f) '((a b c) (d e f) (g h i)))
-> ((d e f) (g h i))




member/2


Pilog predicate that succeeds if the the first
argument is a member of the list in the second argument. See also equal/2 and member.


:  (? (member @X (a b c)))
 @X=a
 @X=b
 @X=c
-> NIL




(memq 'any 'lst) -> any


Returns the tail of lst that starts with any when
any is a member of lst, otherwise NIL.
== is used for comparison (pointer
equality). See also member, mmeq, asoq, push1q, delq and Comparing.


: (memq 'c '(a b c d e f))
-> (c d e f)
: (memq (2) '((1) (2) (3)))
-> NIL




(meta 'obj|typ 'sym ['sym2|cnt ..]) -> any


Fetches a property value any, by searching the property lists
of the classes and superclasses of obj, or the classes in
typ, for the property key sym, and by applying the
get algorithm to the following optional
arguments. See also var:.


: (setq A '(B))            # Be 'A' an object of class 'B'
-> (B)
: (put 'B 'a 123)
-> 123
: (meta 'A 'a)             # Fetch 'a' from 'B'
-> 123




(meth 'obj ['any ..]) -> any


This function is usually not called directly, but is used by  dm as a template to initialize the
VAL of message symbols. It searches for itself in the methods of
obj and its classes and superclasses, and executes that method. An
error "Bad message" is issued if the search is unsuccessful. See
also OO Concepts, method, send and try.


: meth
-> 67283504    # Value of 'meth'
: rel>
-> 67283504    # Value of any message




(method 'msg 'obj) -> fun


Returns the function body of the method that would be executed upon sending
the message msg to the object obj. If the message
cannot be located in obj, its classes and superclasses,
NIL is returned. See also OO Concepts,
send, try, meth, super, extra, class.


: (method 'mis> '+Number)
-> ((Val Obj) (and Val (not (num? Val)) "Numeric input expected"))




(methods 'sym) -> lst


(Debug mode only) Returns a list of method specifications for the object or
class sym, as they are inherited from sym's classes
and superclasses. See also OO Concepts, dep, class and can.


: (more (methods '+Joint))
(keep> . +Joint)
(lose> . +Joint)
(rel> . +Joint)
(mis> . +Joint)
(T . +Joint)
(print> . +relation)
(zap> . +relation)
(del> . +relation)
(put> . +relation)
(has> . +relation)
(ele> . +relation)




(min 'any1 'any2 ..) -> any


(min 'lst) -> any


Returns the smallest of all any arguments, or of all elements
in lst. See also max and Comparing.


: (min 2 'a 'z 9)
-> 2
: (min (5) (2 3) 'X)
-> X
: (min (2 4 1 3))
-> 1




(minKey 'tree ['any1 ['any2]]) -> any


Returns the smallest key in a database tree. If a minimal key
any1 and/or a maximal key any2 is given, the smallest
key from that range is returned. See also tree, leaf, maxKey and genKey.


: (minKey (tree 'nr '+Item))
-> 1
: (minKey (tree 'nr '+Item) 3 5)
-> 3




(mini 'fun 'lst ..) -> any


Applies fun to each element of lst. When
additional lst arguments are given, their elements are also passed
to fun. Returns that element from lst for which
fun returned a minimal value (and stores the minimal value in the
global variable @@). See also maxi and sort.


: (setq A 1  B 2  C 3)
-> 3
: (mini val '(A B C))
-> A




(mix 'lst cnt|'any ..) -> lst


Builds a list from the elements of the argument lst, as
specified by the following cnt|'any arguments. If such an argument
is a positive number, the n'th element from lst is taken. If it is
a negative number, the n'th CDR. Otherwise that argument is evaluated and the
result is used.


: (mix '(a b c d) 3 4 1 2)
-> (c d a b)
: (mix '(a b c d) -2 1)
-> ((c d) a)
: (mix '(a b c d) 1 'A 4 'D)
-> (a A d D)




(mmeq 'lst 'lst) -> any


Returns the tail of the second argument lst that starts with a
member of the first argument lst, otherwise NIL.
== is used for comparison (pointer
equality). See also member, memq, asoq and delq.


: (mmeq '(a b c) '(d e f))
-> NIL
: (mmeq '(a b c) '(d b x))
-> (b x)




(money 'num ['sym]) -> sym


Formats a number num into a digit string with two decimal
places, according to the current locale. If an additional currency name is
given, it is appended (separated by a space). See also telStr, datStr and format.


: (money 123456789)
-> "1,234,567.89"
: (money 12345 "EUR")
-> "123.45 EUR"
: (locale "DE" "de")
-> NIL
: (money 123456789 "EUR")
-> "1.234.567,89 EUR"




(more 'lst ['fun]) -> flg


(more 'cls) -> any


(Debug mode only) Displays the elements of lst (first form), or
the type and methods of cls (second form). fun
defaults to println. In the second
form, the method definitions of cls are pretty-printed with
pp. After each step, more
waits for a key, and terminates when ESC is pressed. In that case,
T is returned, otherwise (when end of data is reached)
NIL. See also query and
show.


: (more (all))                         # Display all internal symbols
!
$
%
&
*
-> T

: (more (all) show)                    # 'show' all internal symbols
! 27131845007
   doc "@doc/ref_.html"
   *Dbg ((1458 "@src/flow.l" llvm pico))
$ 27131845049
   doc "@doc/ref_.html"
   *Dbg ((1508 "@src/flow.l" llvm pico))
% -27131839417
   doc "@doc/ref_.html"
   *Dbg ((1245 "@src/big.l" llvm pico))
& -27131839537
   doc "@doc/ref_.html"
   *Dbg ((1380 "@src/big.l" llvm pico))
* -27131839339
   doc "@doc/ref_.html"
   *Dbg ((1174 "@src/big.l" llvm pico))
...

: (more '+Link)                        # Display a class
(+relation)
(dm mis> (Val Obj)
   (and
      Val
      (nor (isa (: type) Val) ("canQuery" Val))
      "Type error" ) )
(dm T (Var Lst)
   (unless (=: type (car Lst)) (quit "No Link" Var))
   (super Var) )
-> NIL




(msg 'any ['any ..]) -> any


Prints any with print, followed by all any
arguments (printed with prin) and a
newline, to standard error. The first any argument is returned.


: (msg (1 a 2 b 3 c) " is a mixed " "list")
(1 a 2 b 3 c) is a mixed list
-> (1 a 2 b 3 c)







================================================
FILE: doc/refN.html
================================================
N
N



+Need


Prefix class for mandatory +relations. Note that this does not
enforce any requirements by itself, it only returns an error message if the
mis> message is explicitly called, e.g. by GUI functions. See
also Database.


(rel nr (+Need +Key +Number))  # Item number is mandatory




+Number


Class for numeric relations, a subclass of +relation. Accepts an optional argument
for the fixpoint scale (currently not used). See also Database.


(rel pr (+Number) 2)  # Price, with two decimal places




(n== 'any ..) -> flg


Returns T when not all any arguments are the same
(pointer equality). (n== 'any ..) is equivalent to (not (==
'any ..)). See also == and Comparing.


: (n== 'a 'a)
-> NIL
: (n== (1) (1))
-> T




(n0 'any) -> flg


Returns T when any is not a number with value
zero. See also =0, lt0, le0, ge0 and gt0.


: (n0 (- 6 3 2 1))
-> NIL
: (n0 'a)
-> T




(nT 'any) -> flg


Returns T when any is not the symbol
T. See also =T.


: (nT 0)
-> T
: (nT "T")
-> T
: (nT T)
-> NIL




(name 'sym) -> sym


Returns a new transient symbol with the name of sym. See also
str, sym, symbols, zap and intern.


: (name 'abc)
-> "abc"
: (name "abc")
-> "abc"
: (name '{A17})
-> "A17"
: (name (new))
-> NIL




(namespaces ['flg]) -> lst


(Debug mode only) Returns a list of all namespaces nested in the current search
order. When flg is non-NIL, their nested tree
is printed as a side effect. See also symbols and shadows.


$ pil +
: (namespaces)
-> (pico vip llvm priv)
: (namespaces T)
   pico
      vip
      llvm
      priv
-> (pico vip llvm priv)

$ pty  # After starting "steps", "browser" and "chess" in PilBox
chess: (namespaces T)
   chess
   simul
   android
      steps
      browser
   pico
      svg
      vip
      gis
      llvm
      priv
-> (chess simul android steps browser pico svg vip gis llvm priv)




(nand 'any ..) -> flg


Logical NAND. The expressions any are evaluated from left to
right. If NIL is encountered, T is returned
immediately. Else NIL is returned. (nand ..) is
equivalent to (not (and ..)). See also and, nor, unless, ifn and nond.


: (nand (lt0 7) (read))
-> T
: (nand (lt0 -7) (read))
abc
-> NIL
: (nand (lt0 -7) (read))
NIL
-> T




(native 'cnt1|sym1 'cnt2|sym2 'any 'any ..) -> any


Calls a native function. The first argument should specify a shared object
library, either "@" (the current main program), sym1
(a library path name), or cnt1 (a library handle obtained by a
previous call). The second argument should be a symbol name sym2,
or a function handle cnt2 obtained by a previous call).
Practically, the first two arguments will be always passed as transient symbols,
which will get the library handle and function handle assigned as values to be
cached and used in subsequent calls. The third argument any is a
result specification, while all following arguments are the arguments to the
native function. The functionality is described in detail in Native C Calls.


The result specification may either be one of the
atoms


   NIL   void
   B     byte        # Byte (unsigned 8 bit)
   C     char        # Character (UTF-8, 1-4 bytes)
   W     short       # Word (signed 16 bit)
   I     int         # Integer (signed 32 bit)
   U     unsigned    # Unsigned integer (32 bit)
   N     long        # Number (signed 64 bit)
   P     void*       # Pointer (unsigned 64 bit)
   S     string      # String (UTF-8)
  -1.0   float       # Scaled fixpoint number
  +1.0   double      # Scaled fixpoint number
   T                 # Direct Lisp value




or nested lists of these atoms with size specifications to denote arrays and
structures, e.g.


   (N . 4)        # long[4];           -> (1 2 3 4)
   (N (C . 4))    # {long; char[4];}   -> (1234 ("a" "b" "c" NIL))
   (N (B . 7))    # {long; byte[7];}   -> (1234 (1 2 3 4 5 6 7))




Arguments can be

    

  • integers (up to 64-bit) or pointers, passed as numbers

  • strings, passed as symbols

  • Lisp expressions, passed as cons pairs with T in the CAR

  • fixpoint numbers, passed as cons pairs consisting of a the value and the
   scale (if the scale is positive, the number is passed as a
   double, otherwise as a float)

  • structures, passed as lists with
   
      
   
    • a variable in the CAR (to receive the returned structure data, ignored
      when the CAR is NIL)
   
    • a cons pair for the size and result specification in the CADR (see
      above), and
   
    • an optional sequence of initialization items in the
      CDDR, where each may be
      
        
      
      • a positive number, stored as an unsigned byte value
      
      • a negative number, whose absolute value is stored as an unsigned
         integer
      
      • a pair (num . cnt) where 'num' is stored in
         a field of 'cnt' bytes
      
      • a pair (sym . cnt) where 'sym' is stored as
         a null-terminated string in a field of 'cnt' bytes
      
      • a list (1.0 num ...) where the 'num'
         elements (scaled fixpoint numbers) are stored as a sequence of double
         precision floating point numbers
      
      • a list (-1.0 num ...) where the 'num'
         elements (scaled fixpoint numbers) are stored as a sequence of single
         precision floating point numbers
      
      
      If the last CDR of the initialization sequence is a number, it is used
      as a fill-byte value for the remaining space in the structure.
   
    




native takes care of allocating memory for strings, arrays or
structures, and frees that memory when done.


For NaN or negative infinity fixpoint values NIL, and for
positive infinity T is returned.


See also %@, struct, adr, lisp and errno.


: (native "@" "unlink" 'I "file")  # Same as (%@ "unlink" 'I "file")
-> 0
: (native "libcrypto.so" "SHA1" '(B . 20) "abcd" 4 0)
-> (129 254 139 254 135 87 108 62 203 34 66 111 142 87 132 115 130 145 122 207)




(need 'cnt ['lst ['any]]) -> lst


(need 'cnt ['num|sym]) -> lst


Produces a list of at least cnt elements. When called without
optional arguments, a list of cnt NIL's is returned.
When lst is given, it is extended to the left (if cnt
is positive) or (destructively) to the right (if cnt is negative)
with any elements. In the second form, a list of cnt
atomic values is returned. See also range.


: (need 5)
-> (NIL NIL NIL NIL NIL)  # Allocate 5 cells
: (need 5 '(a b c))
-> (NIL NIL a b c)
: (need -5 '(a b c))
-> (a b c NIL NIL)
: (need 5 '(a b c) " ")  # String alignment
-> (" " " " a b c)
: (need 7 0)
-> (0 0 0 0 0 0 0)
: (need 5 (2 3) 1)
-> (1 1 1 2 3)




(new ['flg|num|sym] ['typ ['any ..]]) -> obj


Creates and returns a new object. If the first (optional) argument is
T or a number, the new object will be an external symbol (created
in database file 1 if T, or in the corresponding database file if
num is given). If it is a symbol, it is used directly.
typ (a list of classes) is assigned to the VAL, and
the initial T message is sent with the arguments any
to the new object. If no T message is defined for the classes in
typ or their superclasses, the any arguments should
evaluate to alternating keys and values for the initialization of the new
object. See also box, object, class, type, isa, send and Database.


: (new)
-> $134426427
: (new T '(+Address))
-> {A3}




(new! 'typ ['any ..]) -> obj


Transaction wrapper function for new. (new! '(+Cls) 'key 'val ...)
is equivalent to (dbSync) (new (db: +Cls) '(+Cls) 'key 'val ...) (commit
'upd). See also request!, set!, put! and inc!.


: (new! '(+Item)  # Create a new item
   'nr 2                      # Item number
   'nm "Spare Part"           # Description
   'sup (db 'nr '+CuSu 2)     # Supplier
   'inv 100                   # Inventory
   'pr 12.50 )                # Price






Can only be used inside functions with a variable number of arguments (with
@). Returns the next argument from the internal list. See also
args, arg, rest, and pass.


: (de foo @ (println (next)))          # Print next argument
-> foo
: (foo)
NIL
-> NIL
: (foo 123)
123
-> 123




(nil . prg) -> NIL


Executes prg, and returns NIL. See also t, prog,
prog1 and prog2.


: (nil (println 'OK))
OK
-> NIL




nil/1


Pilog predicate expects an argument variable,
and succeeds if that variable is bound to NIL. See also not/1.


: (? @X NIL (nil @X))
 @X=NIL
-> NIL




(noLint 'sym)


(noLint 'sym|(sym . cls) 'sym2)


(Debug mode only) Excludes the check for a function definition of
sym (in the first form), or for variable binding and usage of
sym2 in the function definition, file contents or method body of
sym (second form), during calls to lint. See also lintAll.


: (de foo ()
   (bar FreeVariable) )
-> foo
: (lint 'foo)
-> ((def bar) (bnd FreeVariable))
: (noLint 'bar)
-> bar
: (noLint 'foo 'FreeVariable)
-> (foo . FreeVariable)
: (lint 'foo)
-> NIL




(nond ('any1 . prg1) ('any2 . prg2) ..) -> any


Negated ("non-cond") multi-way conditional: If any of the anyN
conditions evaluates to NIL, prgN is executed and the
result returned. Otherwise (all conditions evaluate to non-NIL),
NIL is returned. See also cond, ifn, unless, nor and nand.


: (nond
   ((= 3 3) (println 1))
   ((= 3 4) (println 2))
   (NIL (println 3)) )
2
-> 2




(nor 'any ..) -> flg


Logical NOR. The expressions any are evaluated from left to
right. If a non-NIL value is encountered, NIL is
returned immediately. Else T is returned. (nor ..) is
equivalent to (not (or ..)). See also or, nand, unless, ifn and nond.


: (nor (lt0 7) (= 3 4))
-> T




(not 'any) -> flg


Logical negation. Returns T if any evaluates to
NIL.


: (not (== 'a 'a))
-> NIL
: (not (get 'a 'a))
-> T




not/1


Pilog predicate that succeeds if and only if
the goal cannot be proven. See also nil/1, true/0 and fail/0.


: (? (equal 3 4))
-> NIL
: (? (not (equal 3 4)))
-> T




(nsp 'sym) -> sym


Returns the (first) namespace
where sym is found in, according to the current symbols search order. See also
pico.


(load "@lib/gis.l")

: (symbols '(gis pico))
-> (pico)
gis: (nsp 'gis)
-> pico
gis: (nsp 'Zoom)
-> gis
gis: (nsp 'osmStat)
-> gis




(nth 'lst 'cnt ..) -> lst


Returns the tail of lst starting from the cnt'th
element of lst. Successive cnt arguments operate on
the CARs of the results in the same way. (nth 'lst 2) is equivalent
to (cdr 'lst). See also get.


: (nth '(a b c d) 2)
-> (b c d)
: (nth '(a (b c) d) 2 2)
-> (c)
: (cdadr '(a (b c) d))
-> (c)




(num? 'any) -> num | NIL


Returns any when the argument any is a number,
otherwise NIL. See also sym?, atom and pair.


: (num? 123)
-> 123
: (num? (1 2 3))
-> NIL







================================================
FILE: doc/refO.html
================================================
O
O



*ObjIdx


Holds an idx tree of objects
created by obj.





*Once


Holds an idx tree of already
loaded source locations (as returned
by file) See also once.


: *Once
-> (("lib/" "misc.l" . 11) (("lib/" "http.l" . 9) (("lib/" "form.l" . 11))))




*OS


A global constant holding the name of the operating system. Possible values
include "Linux", "Android", "FreeBSD",
"OpenBSD", "SunOS", "Darwin" or
"Cygwin". See also *CPU
and version.


: *OS
-> "Linux"




(obj (typ sym [hook] val ..) [var1 val1 ..]) -> obj


(obj typ any [var1 val1 ..]) -> obj


Finds or creates a database object, and initializes additional properties
using the varN and valN arguments. In the first form,
a request for (typ sym [hook]
val ..) is called, while the second form uses cache to maintain objects without unique
+Keys by indexing *ObjIdx with the any argument.


: (obj ((+Item) nr 2) nm "Spare Part" sup `(db 'nr '+CuSu 2) inv 100 pr 1250)
-> {B2}




(object 'sym 'any ['sym2 'any2 ..]) -> obj


Defines sym to be an object with the value (or type)
any. The property list is initialized with all optionally supplied
key-value pairs. See also OO Concepts, new, type and isa.


: (object 'Obj '(+A +B +C) 'a 1 'b 2 'c 3)
-> Obj
: (show 'Obj)
Obj (+A +B +C)
   c 3
   b 2
   a 1
-> Obj




(oct 'num ['num]) -> sym


(oct 'sym) -> num


Converts a number num to an octal string, or an octal string
sym to a number. In the first case, if the second argument is
given, the result is separated by spaces into groups of such many digits. See
also bin, hex, hax and format.


: (oct 73)
-> "111"
: (oct "111")
-> 73
: (oct 1234567 3)
-> "4 553 207"




(off var ..) -> NIL


Stores NIL in all var arguments. See also on, onOff, zero and one.


: (off A B)
-> NIL
: A
-> NIL
: B
-> NIL




(offset 'lst1 'lst2) -> cnt | NIL


Returns the cnt position of the tail list lst1 in
lst2, or NIL if it is not found. See also index, sub? and tail.


: (offset '(c d e f) '(a b c d e f))
-> 3
: (offset '(c d e) '(a b c d e f))
-> NIL




(on var ..) -> T


Stores T in all var arguments. See also off, onOff, zero and one.


: (on A B)
-> T
: A
-> T
: B
-> T




(once . prg) -> any


Executes prg once, when the current file is loaded the first time. Subsequent loads at a
later time will not execute prg, and once returns
NIL. See also *Once and
finish.


(once
   (zero *Cnt1 *Cnt2)  # Init counters
   (load "file1.l" "file2.l") )  # Load other files

`(once T)  # Ignore next time the rest of this file




(one var ..) -> 1


Stores 1 in all var arguments. See also zero, on, off
and onOff.


: (one A B)
-> 1
: A
-> 1
: B
-> 1




(onOff var ..) -> flg


Logically negates the values of all var arguments. Returns the
new value of the last symbol. See also on, off,
zero and one.


: (onOff A B)
-> T
: A
-> T
: B
-> T
: (onOff A B)
-> NIL
: A
-> NIL
: B
-> NIL




(open 'any ['flg]) -> cnt | NIL


Opens the file with the name any in read/write mode (or
read-only if flg is non-NIL), and returns a file
descriptor cnt (or NIL on error). A leading
"@" character in any is substituted with the
PicoLisp Home Directory, as it was remembered during interpreter startup.
If flg is NIL and the file does not exist, it is
created. The file descriptor can be used in subsequent calls to in and out. See also close and poll.


: (open "x")
-> 3




(opid) -> pid | NIL


Returns the corresponding process ID when the current output channel is
writing to a pipe, otherwise NIL. See also ipid and out.


: (out '(cat) (call 'ps "-p" (opid)))
  PID TTY          TIME CMD
 7127 pts/3    00:00:00 cat
-> T




(opt) -> sym


Return the next command line argument ("option", as would be processed by
load) as a string, and remove it from
the remaining command line arguments. See also Invocation and argv.


$ pil  -"de f () (println 'opt (opt))"  -f abc  -bye
opt "abc"




(or 'any ..) -> any


Logical OR. The expressions any are evaluated from left to
right. If a non-NIL value is encountered, it is returned
immediately. Else the result of the last expression is returned. See also
nor, and and unless.


: (or (= 3 3) (read))
-> T
: (or (= 3 4) (read))
abc
-> abc




or/2


Pilog predicate that takes an arbitrary number
of clauses, and succeeds if one of them can be proven. See also not/1.


: (?
   (or
      ((equal 3 @X) (equal @X 4))
      ((equal 7 @X) (equal @X 7)) ) )
 @X=7
-> NIL




(out 'any . prg) -> any


Opens any as output channel during the execution of
prg. The current output channel will be saved and restored
appropriately. If the argument is NIL, standard output is used. If
the argument is a symbol, it is used as a file name (opened in read/write-append
mode if the first character is "+"). If it is a positive number, it
is used as the descriptor of an open file. If it is a negative number, the saved
output channel such many levels above the current one is used. Otherwise (if it
is a list), it is taken as a command with arguments, and a pipe is opened for
output. The (system dependent) exit status code of the child process is stored
in the global variable @@. In all cases,
flush is called when prg
is done. See also in,  err,  fd, opid,  call, ctl, pipe,  poll,  close and load.


: (out "a" (println 123 '(a b c) 'def))  # Write one line to file "a"
-> def
: (out '(lpr) (prinl "Hello"))  # Send line to line printer
-> "Hello"




(output exe . prg) -> any


Establishes an output stream, by redirecting the current output channel
during the execution of prg. The current output channel will be
saved and restored appropriately. exe is executed (in the context
of the original output channel) whenever a character needs to be output by print
calls in prg. That character is passed in the global variable
@@, and the following character in the
stream in @@@ (single-character
look-ahead). See also input, out and pipe.


: (output (prin (uppc @@)) (prinl "abc"))
ABC
-> "abc"
: (output (println @@ @@@) (prin "abc"))
"a" "b"
"b" "c"
"c" NIL
-> "abc"
: (pack
   (make
      (output (link @@)
         (print '(+ 2 (* 3 4))) ) ) )
-> "(+ 2 (* 3 4))"
: (pack
   (make
      (let L (1 2 3 4 5 6 7)
         (output (link @@)
            (while L
               (ext:Base64 (++ L) (++ L) (++ L)) ) ) ) ) )
-> "AQIDBAUGBw=="







================================================
FILE: doc/refP.html
================================================
P
P



*PPid


A global constant holding the process-id of the parent picolisp process, or
NIL if the current process is a top level process.


: (println *PPid *Pid)
NIL 5286

: (unless (fork) (println *PPid *Pid) (bye))
5286 5522




*Pid


A global constant holding the current process-id.


: *Pid
-> 6386
: (call "ps")  # Show processes
  PID TTY          TIME CMD
 .... ...      ........ .....
 6386 pts/1    00:00:00 pil   # <- current process
 6388 pts/1    00:00:00 ps
-> T




*Prompt


Global variable holding a (possibly empty) prg body, which is
executed - and the result printed -
every time before a prompt is output to the console in the
"read-eval-print-loop" (REPL).


: (de *Prompt (pack "[" (stamp) "]"))
# *Prompt redefined
-> *Prompt
[2011-10-11 16:50:05]: (+ 1 2 3)
-> 6
[2011-10-11 16:50:11]:




(pack 'any ..) -> sym


Returns a transient symbol whose name is concatenated from all arguments
any. A NIL arguments contributes nothing to the result
string, a number is converted to a digit string, a symbol supplies the
characters of its name, and for a list its elements are taken. See also text and glue.


: (pack 'car " is " 1 '(" symbol " name))
-> "car is 1 symbol name"




(pad 'cnt 'any) -> sym


Returns a transient symbol with any packed with leading '0' characters, up to a
field width of cnt. See also format and align.


: (pad 5 1)
-> "00001"
: (pad 5 123456789)
-> "123456789"




(pair 'any) -> any


Returns any when the argument is a cons pair. See also atom, num?, sym? and lst?.


: (pair NIL)
-> NIL
: (pair (1 . 2))
-> (1 . 2)
: (pair (1 2 3))
-> (1 2 3)




part/3


(Deprecated since version 25.5.30) Pilog predicate that succeeds if the first
argument, after folding it to
a canonical form, is a substring of the folded string
representation of the result of applying the get algorithm to the following
arguments. Typically used as filter predicate in select/3 database queries. See also
sub?, isa/2, same/3, bool/3, range/3, head/3, fold/3 and tolr/3.


: (?
   @Nr (1 . 5)
   @Nm "part"
   (select (@Item)
      ((nr +Item @Nr) (nm +Item @Nm))
      (range @Nr @Item nr)
      (part @Nm @Item nm) ) )
 @Nr=(1 . 5) @Nm="part" @Item={B1}
 @Nr=(1 . 5) @Nm="part" @Item={B2}
-> NIL




(pass 'fun ['any ..]) -> any


Passes to fun all arguments any, and all remaining
variable arguments (@) as they would be returned by rest. (pass 'fun 'any) is
equivalent to (apply 'fun (rest) 'any). See also apply.


: (de bar (A B . @)
   (println 'bar A B (rest)) )
-> bar
: (de foo (A B . @)
   (println 'foo A B)
   (pass bar 1)
   (pass bar 2) )
-> foo
: (foo 'a 'b 'c 'd 'e 'f)
foo a b
bar 1 c (d e f)
bar 2 c (d e f)
-> (d e f)




(pat? 'any) -> pat | NIL


Returns any when the argument any is a symbol
whose name starts with an at-mark "@", otherwise NIL.


: (pat? '@)
-> @
: (pat? "@Abc")
-> "@Abc"
: (pat? "ABC")
-> NIL
: (pat? 123)
-> NIL




(patch 'lst 'any . prg) -> any


Destructively replaces all sub-expressions of lst which
match the pattern any,
by the result of the execution of prg. See also daemon and redef.


: (pp 'hello)
(de hello NIL
   (prinl "Hello world!") )
-> hello

: (patch hello 'prinl 'println)
-> NIL
: (pp 'hello)
(de hello NIL
   (println "Hello world!") )
-> hello

: (patch hello '(prinl @S) (fill '(println "We said: " . @S)))
-> NIL
: (hello)
We said: Hello world!
-> "Hello world!"




(path 'any) -> sym


Substitutes any leading "@" or "~" character in
the any argument with the PicoLisp or User Home
Directory respectively, as they were remembered during interpreter startup.
Optionally, the name may be preceded by a "+" character (as used by
in and out). This mechanism is used internally by all
I/O functions. See also Invocation, basename and dirname.


$ /usr/bin/picolisp /usr/lib/picolisp/lib.l
: (path "a/b/c")
-> "a/b/c"
: (path "@a/b/c")
-> "/usr/lib/picolisp/a/b/c"
: (path "+@a/b/c")
-> "+/usr/lib/picolisp/a/b/c"




(peek) -> sym


Single character look-ahead: Returns the same character as the next call to
char would return. Note that if the
next character is a multi-byte character, only the first byte is
returned. See also skip.


$ cat a
# Comment
abcd
$ pil +
: (in "a" (list (peek) (char)))
-> ("#" "#")




permute/2


Pilog predicate that succeeds if the second
argument is a permutation of the list in the second argument. See also append/3.


: (? (permute (a b c) @X))
 @X=(a b c)
 @X=(a c b)
 @X=(b a c)
 @X=(b c a)
 @X=(c a b)
 @X=(c b a)
-> NIL




(pick 'fun 'lst ..) -> any


Applies fun to successive elements of lst until
non-NIL is returned. Returns that value, or NIL if
fun did not return non-NIL for any element of
lst. When additional lst arguments are given, their
elements are also passed to fun. (pick 'fun 'lst) is
equivalent to (fun (find 'fun 'lst)). See also seek, find and extract.


: (setq A NIL  B 1  C NIL  D 2  E NIL  F 3)
-> 3
: (find val '(A B C D E))
-> B
: (pick val '(A B C D E))
-> 1




pico


A global constant holding the initial (default) namespace of internal symbols. Its value
is two cons pairs of the symbol ~ (as a marker) and two
'idx' trees, one for symbols
with short names and one for symbols with long names (more than 7 bytes
in the name). See also symbols, nsp, import and intern.


: (symbols)
-> (pico)
: (cdr pico)
-> (rollback (*NoTrace (*CtryCode (+IdxFold) genStrKey) basename ...




(pilog 'lst . prg) -> any


Evaluates a Pilog query, and executes
prg for each result set with all Pilog variables bound to their
matching values. See also solve,
?, goal and prove.


: (pilog '((append @X @Y (a b c))) (println @X '- @Y))
NIL - (a b c)
(a) - (b c)
(a b) - (c)
(a b c) - NIL
-> NIL




(pipe exe) -> cnt


(pipe exe . prg) -> any


Executes exe in a fork'ed child process (which terminates
thereafter). In the first form, pipe just returns a file descriptor
to write to the standard input and read from the standard output of that
process. In the second form, it opens the standard output of that process as
input channel during the execution of prg. The current input
channel will be saved and restored appropriately, and the (system dependent)
exit status code of the child process is stored in the global variable @@. See also later, ipid, in and out.


: (pipe                                # equivalent to 'any'
   (prinl "(a b # Comment\nc d)")         # Child
   (read) )                               # Parent
-> (a b c d)

: (pipe                                # pipe through an external program
   (out '(tr "[a-z]" "[A-Z]")             # Child
      (prinl "abc def ghi") )
   (line T) )                             # Parent
-> "ABC DEF GHI"

: (setq P
     (pipe
        (in NIL                           # Child: Read stdin
           (while (line T)
              (prinl (uppc @))            # and write to stdout
              (flush) ) ) ) )
-> 3
: (out P (prinl "abc def"))               # Parent: Send line to child
-> "abc def"
: (in P (line))                           # Parent: Read reply
-> ("A" "B" "C" " " "D" "E" "F")




(place 'cnt 'lst 'any) -> lst


Places any into lst at position cnt.
This is a non-destructive operation. See also insert, remove, append, delete and replace.


: (place 3 '(a b c d e) 777)
-> (a b 777 d e)
: (place 1 '(a b c d e) 777)
-> (777 b c d e)
: (place 9 '(a b c d e) 777)
-> (a b c d e 777)




(plio 'num) -> any


(plio 'num 'cnt 'any) -> cnt


The first form returns one item stored in PLIO format at the memory location
pointed to by num. The second form stores an item any
in a buffer of size cnt. See also byte and struct.


: (buf P 64
   (plio P 64 (1 a (2 b c) d))  # Store expression
   (plio P) )                   # Fetch it
-> (1 a (2 b c) d)




(poll 'cnt) -> cnt | NIL


Checks for the availability of data for reading on the file descriptor
cnt. See also open,
in and close.


: (and (poll *Fd) (in @ (read)))  # Prevent blocking




(pool ['sym1 ['lst] ['sym2] ['sym3]]) -> T


Opens the file sym1 as a database file in read/write mode. If
the file does not exist, it is created. A currently open database is closed.
lst is a list of block size scale factors (i.e. numbers),
defaulting to (2) (for a single file with a 256 byte block size). If
lst is given, an individual database file is opened for each item.
If sym2 is non-NIL, it is opened in append-mode as an
asynchronous replication journal. If sym3 is non-NIL,
it is opened for reading and appending, to be used as a synchronous transaction
log during commits. Calling
(pool) without arguments just closes the current database. See also
dbs, *Dbs and journal.


: *Dbs
-> (1 2 2 4)
: (pool "dbFile" *Dbs)
-> T

$ ls -l dbFile*
-rw-r--r-- 1 abu abu  256 Jul  3 08:30 dbFile@
-rw-r--r-- 1 abu abu  256 Jul  3 08:30 dbFileA
-rw-r--r-- 1 abu abu  256 Jul  3 08:30 dbFileB
-rw-r--r-- 1 abu abu 1024 Jul  3 08:30 dbFileC

# DB directly on a device
: (pool "/dev/hda2")
-> T




(pool2 'sym . prg) -> any


Temporary switches to another database specified by sym. This
database must be a multi-file DB with exactly the same *Dbs structure as the currently open one. The
current database is not closed - I/O is just redirected to the new one. All
files are opened before prg runs, and are closed thereafter. The
result of prg is returned. No replication journal or transaction
log is written. Also, possibly cached objects of the current DB remain in the
heap, so an explicit call to rollback may be necessary. See also
blk.


(pool2 "db2/"  # Update a read-only DB
   (journal "file.jnl") )

(rollback)
(pool2 "db2/"  # Access object(s)
   (show *DB) )
(rollback)




(pop 'var) -> any


Pops the first element (CAR) from the stack in var. See also
push, ++, shift, queue, cut, del and fifo.


: (setq S '((a b c) (1 2 3)))
-> ((a b c) (1 2 3))
: (pop S)
-> a
: (pop (cdr S))
-> 1
: (pop 'S)
-> (b c)
: S
-> ((2 3))




(port ['T] 'cnt|(cnt . cnt) ['var]) -> cnt


Opens a TCP-Port cnt (or a UDP-Port if the first argument is
T), and returns a socket descriptor suitable as an argument for
listen or accept (or udp, respectively). If cnt is zero,
some free port number is allocated. If a pair of cnts is given
instead, it should be a range of numbers which are tried in turn. When
var is given, it is bound to the port number.


: (port 0 'A)                       # Allocate free port
-> 4
: A
-> 1034                             # Got 1034
: (port (4000 . 4008) 'A)           # Try one of these ports
-> 5
: A
-> 4002




(pp 'sym) -> sym


(pp 'sym 'cls) -> sym


(pp '(sym . cls)) -> sym


Pretty-prints the function or method definition of sym. The
output format would regenerate that same definition when read and executed. See
also pretty, debug and vi.


: (pp 'tab)
(de tab (Lst . @)
   (for N Lst
      (let V (next)
         (and (gt0 N) (space (- N (length V))))
         (prin V)
         (and
            (lt0 N)
            (space (- 0 N (length V))) ) ) )
   (prinl) )
-> tab

: (pp 'has> '+Entity)
(dm has> (Var Val)
   (or
      (nor Val (get This Var))
      (has> (meta This Var) Val (get This Var)) ) )
-> has>

: (more (can 'has>) pp)
(dm (has> . +relation) (Val X)
   (and (= Val X) X) )

(dm (has> . +Fold) (Val X)
   (extra
      Val
      (if (= Val (fold Val)) (fold X) X) ) )

(dm (has> . +Entity) (Var Val)
   (or
      (nor Val (get This Var))
      (has> (meta This Var) Val (get This Var)) ) )

(dm (has> . +List) (Val X)
   (and
      Val
      (or
         (extra Val X)
         (find '((X) (extra Val X)) X) ) ) )

(dm (has> . +Bag) (Val X)
   (and
      Val
      (or (super Val X) (car (member Val X))) ) )




(pr 'any ..) -> any


Binary print: Prints all any arguments to the current output
channel in encoded binary format. See also rd, bytes, tell, hear and wr.


: (out "x" (pr 7 "abc" (1 2 3) 'a))  # Print to "x"
-> a
: (hd "x")
00000000  04 0E 0E 61 62 63 01 04 02 04 04 04 06 03 05 61  ...abc.........a
-> NIL




(prBase64 'cnt ['str]) -> NIL


Multiline base64 printing. Echoes bytes from the current input channel to
the current output channel in Base64 format. A newline is inserted after every
cnt byte-triples (character-quadruples). If str is
given (typically a carriage return), it is output before the newline. See also
echo mail.


: (in "image.png" (prBase64 18))  # Print 72 columns




(prEval 'prg ['cnt]) -> any


Executes prg, similar to run, by evaluating all expressions in
prg (within the binding environment given by cnt-1).
As a side effect, all atomic expressions will be printed with prinl. See also eval.


: (let Prg 567
   (prEval
      '("abc" (prinl (+ 1 2 3)) Prg 987) ) )
abc
6
567
987
-> 987




(pre? 'any1 'any2) -> any2 | NIL


Returns any2 when the string representation of
any1 is a prefix of the string representation of any2.
See also sub? and head.


: (pre? "abc" "abcdefg")
-> "abcdef"
: (pre? "def" "abcdefg")
-> NIL
: (pre? (+ 3 4) "7fach")
-> "7fach"
: (pre? NIL "abcdefg")
-> "abcdefg"

: (pre? "abc" '(a b c d e f g))
-> "abcdefg"
: (pre? '(a b c) "abcdefg")
-> "abcdefg"




(pretty 'any 'cnt)


Pretty-prints any. If any is an atom, or a list
with a size not greater than 12, it is
printed as is. Otherwise, only the
opening parenthesis and the CAR of the list is printed, all other elements are
pretty-printed recursively indented by three spaces, followed by a space and the
corresponding closing parenthesis. The initial indentation level
cnt defaults to zero. See also pp.


: (pretty '(a (b c d) (e (f (g) (h) (i)) (j (k) (l) (m))) (n o p) q))
(a
   (b c d)
   (e
      (f (g) (h) (i))
      (j (k) (l) (m)) )
   (n o p)
   q )-> ")"




(prin 'any ..) -> any


Prints the string representation of all any arguments to the
current output channel. No space or newline is printed between individual items,
or after the last item. For lists, all elements are prin'ted
recursively. See also prinl.


: (prin 'abc 123 '(a 1 b 2))
abc123a1b2-> (a 1 b 2)




(prinl 'any ..) -> any


Prints the string representation of all any arguments to the
current output channel, followed by a newline. No space or newline is printed
between individual items. For lists, all elements are prin'ted
recursively. See also prin.


: (prinl 'abc 123 '(a 1 b 2))
abc123a1b2
-> (a 1 b 2)




(print 'any ..) -> any


Prints all any arguments to the current output channel. If
there is more than one argument, a space is printed between successive
arguments. No space or newline is printed after the last item. See also println, printsp, sym and str


: (print 123)
123-> 123
: (print 1 2 3)
1 2 3-> 3
: (print '(a b c) 'def)
(a b c) def-> def




(println 'any ..) -> any


Prints all any arguments to the current output channel,
followed by a newline. If there is more than one argument, a space is printed
between successive arguments. See also print, printsp.


: (println '(a b c) 'def)
(a b c) def
-> def




(printsp 'any ..) -> any


Prints all any arguments to the current output channel,
followed by a space. If there is more than one argument, a space is printed
between successive arguments. See also print, println.


: (printsp '(a b c) 'def)
(a b c) def -> def




(prior 'lst1 'lst2) -> lst | NIL


Returns the cell in lst2 which immediately precedes the cell
lst1, or NIL if lst1 is not found in
lst2 or is the very first cell. == is used for comparison (pointer equality). See
also offset and memq.


: (setq L (1 2 3 4 5 6))
-> (1 2 3 4 5 6)
: (setq X (cdddr L))
-> (4 5 6)
: (prior X L)
-> (3 4 5 6)




(private) sym|lst


Intern symbols locally into an internal special namespace named 'priv'. This
namespace is always searched first, but never gets new symbols
automatically interned. (private) expects a single symbol
or a list of symbols immediately following in the current input stream.
See also pico, symbols, local, export, import and intern.


: (symbols 'myLib 'pico)
-> (pico)
myLib: (symbols)
-> (myLib pico)
myLib: (private) (foo bar)  # Intern 'foo' and 'bar' in 'priv'
myLib: (symbols)
-> (myLib pico)
myLib: (all 'priv)
-> (priv~foo priv~bar)




(proc 'sym ..) -> T


(Debug mode on Linux only) Shows a list of processes with command names
given by the sym arguments, using the system ps
utility. See also kids, kill and hd.


: (proc 'pil)
  PID  PPID  STARTED  SIZE %CPU WCHAN  CMD
16993  3267 12:38:21  1516  0.5 -      /usr/bin/picolisp /usr/lib/picolisp/lib.l /usr/bin/pil +
15731  1834 12:36:35  2544  0.1 -      /usr/bin/picolisp /usr/lib/picolisp/lib.l /usr/bin/pil app/main.l -main -go +
15823 15731 12:36:44  2548  0.0 -        /usr/bin/picolisp /usr/lib/picolisp/lib.l /usr/bin/pil app/main.l -main -go +
-> T




(prog . prg) -> any


Executes prg, and returns the result of the last expression.
See also nil, t, prog1 and prog2.


: (prog (print 1) (print 2) (print 3))
123-> 3




(prog1 'any1 . prg) -> any1


Executes all arguments, and returns the result of the first expression
any1. See also nil,
t, prog and prog2.


: (prog1 (print 1) (print 2) (print 3))
123-> 1




(prog2 'any1 'any2 . prg) -> any2


Executes all arguments, and returns the result of the second expression
any2. See also nil,
t, prog and prog1.


: (prog2 (print 1) (print 2) (print 3))
123-> 2




(prompt 'any . prg) -> any


Sets the prompt for non-REPL readline(3) calls to
any during the execution of prg. See also tty.


: (prompt "== " (line))
== abc
-> ("a" "b" "c")




(prop 'sym1|lst ['sym2|cnt ..] 'sym) -> var


Fetches a property for a property key sym from a symbol. That
symbol is sym1 (if no other arguments are given), or a symbol found
by applying the get algorithm to
sym1|lst and the following arguments. The property (the cons pair,
not just its value) is returned, suitable for direct (destructive) manipulations
with functions expecting a var argument. See also ::.


: (put 'X 'cnt 0)
-> 0
: (prop 'X 'cnt)
-> (0 . cnt)
: (inc (prop 'X 'cnt))        # Directly manipulate the property value
-> 1
: (get 'X 'cnt)
-> 1




(protect . prg) -> any


Executes prg, and returns the result of the last expression. If
a signal is received during that time, its handling will be delayed until the
execution of prg is completed. See also alarm, *Hup, *Sig[12] and kill.


: (protect (journal "db1.log" "db2.log"))
-> T




(prove 'lst ['lst]) -> lst


The Pilog interpreter. Tries to prove the query
list in the first argument, and returns an association list of symbol-value
pairs, or NIL if not successful. The query list is modified as a
side effect, allowing subsequent calls to prove for further
results. The optional second argument may contain a list of symbols; in that
case the successful matches of rules defined for these symbols will be traced.
See also goal, -> and unify.


: (prove (goal '((equal 3 3))))
-> T
: (prove (goal '((equal 3 @X))))
-> ((@X . 3))
: (prove (goal '((equal 3 4))))
-> NIL




(prune ['cnt])


Optimizes memory usage by pruning in-memory nodes of database trees.
Typically called repeatedly during bulk data imports. If cnt is
0, the pruning process is initialized, and if it is
NIL, further pruning will be disabled. Otherwise, all nodes which
have not been accessed (with fetch,
store, scan or iter) for cnt calls to
prune will be wiped. See
also lieu.


(in File1
   (prune 0)
   (while (someData)
      (new T '(+Cls1) ..)
      (at (0 . 10000) (commit) (prune 100)) ) )
(in File2
   (prune 0)
   (while (moreData)
      (new T '(+Cls2) ..)
      (at (0 . 10000) (commit) (prune 100)) ) )
(commit)
(prune)




(push 'var 'any ..) -> any


Implements a stack using a list in var. The any
arguments are cons'ed in front of the value list. See also push1, push1q, pop, shift, queue and fifo.


: (push 'S 3)              # Use the VAL of 'S' as a stack
-> 3
: S
-> (3)
: (push 'S 2)
-> 2
: (push 'S 1)
-> 1
: S
-> (1 2 3)
: (push S 999)             # Now use the CAR of the list in 'S'
-> 999
: (push S 888 777)
-> 777
: S
-> ((777 888 999 . 1) 2 3)




(push1 'var 'any ..) -> any


Maintains a unique list in var. Each any argument
is cons'ed in front of the value list only if it is not already a member of that list. See also push, push1q, pop and queue.


: (push1 'S 1 2 3)
-> 3
: S
-> (3 2 1)
: (push1 'S 2 4)
-> 4
: S
-> (4 3 2 1)




(push1q 'var 'any ..) -> any


Maintains a unique list in var. Each any argument
is cons'ed in front of the value list only if it is not already memq of that list (pointer equality). See also
push, push1, pop and queue.


: (push1q 'S 'a (1) 'b (2) 'c)
-> c
: S
-> (c (2) b (1) a)
: (push1q 'S 'b (1) 'd)       # (1) is not pointer equal to the previous one
-> d
: S
->  (d (1) c (2) b (1) a)     # (1) is twice in the list




(put 'sym1|lst ['sym2|cnt ..] 'any) -> any


Stores a new value any for a property key (or in the symbol
value for zero) in a symbol, or in a list. That symbol is sym1 (if
no other arguments are given), or a symbol found by applying the get algorithm to sym1|lst and the
following arguments. If the final destination is a list, the value is stored in
the CDR of an asoqed element (if the
key argument is a symbol), or the n'th element (if the key is a number). See
also =:.


: (put 'X 'a 1)
-> 1
: (get 'X 'a)
-> 1
: (prop 'X 'a)
-> (1 . a)

: (setq L '(A B C))
-> (A B C)
: (setq B 'D)
-> D
: (put L 2 0 'p 5)  # Store '5' under the 'p' property of the value of 'B'
-> 5
: (getl 'D)
-> ((5 . p))




(put! 'obj 'sym 'any) -> any


Transaction wrapper function for put. Note that for setting property values of
entities typically the put!> message is used. See also
new!, request!, set! and inc!.


(put! Obj 'cnt 0)  # Setting a property of a non-entity object




(putl 'sym1|lst1 ['sym2|cnt ..] 'lst) -> lst


Stores a complete new property list lst in a symbol. That
symbol is sym1 (if no other arguments are given), or a symbol found
by applying the get algorithm to
sym1|lst1 and the following arguments. All previously defined
properties for that symbol are lost. See also getl and maps.


: (putl 'X '((123 . a) flg ("Hello" . b)))
-> ((123 . a) flg ("Hello" . b))
: (get 'X 'a)
-> 123
: (get 'X 'b)
-> "Hello"
: (get 'X 'flg)
-> T




(pwd) -> sym


Returns the path to the current working directory. See also dir and cd.


: (pwd)
-> "/home/app"







================================================
FILE: doc/refQ.html
================================================
Q
Q



(qsym . sym) -> lst


Returns a cons pair of the value and property list of sym. See
also quote, val and getl.


: (setq A 1234)
-> 1234
: (put 'A 'a 1)
-> 1
: (put 'A 'b 2)
-> 2
: (put 'A 'f T)
-> T
: (qsym . A)
-> (1234 f (2 . b) (1 . a))




(quote . any) -> any


Returns any unevaluated. The reader recognizes the single quote
char ' as a macro for this function. See also lit.


: 'a
-> a
: '(foo a b c)
-> (foo a b c)
: (quote (quote (quote a)))
-> ('('(a)))




(query 'lst ['lst]) -> flg


Handles an interactive Pilog query. The two
lst arguments are passed to prove. query displays each
result, waits for a key, and terminates when ESC is pressed. See also ?, pilog and solve.


: (query (goal '((append @X @Y (a b c)))))
 @X=NIL @Y=(a b c)
 @X=(a) @Y=(b c)
 @X=(a b) @Y=(c)
 @X=(a b c) @Y=NIL
-> NIL




(queue 'var 'any) -> any


Implements a queue using a list in var. The any
argument is (destructively) concatenated to the end of the value list. See also
push, pop, rid and fifo.


: (queue 'A 1)
-> 1
: (queue 'A 2)
-> 2
: (queue 'A 3)
-> 3
: A
-> (1 2 3)
: (pop 'A)
-> 1
: A
-> (2 3)




(quit ['any ['any]])


Stops current execution. If no arguments are given, all pending finally expressions are executed and control
is returned to the top level read-eval-print loop. Otherwise, an error handler
is entered. The first argument can be some error message, and the second might
be the reason for the error. See also Error
Handling.


: (de foo (X) (quit "Sorry, my error" X))
-> foo
: (foo 123)                                  # 'X' is bound to '123'
123 -- Sorry, my error                       # Error entered
? X                                          # Inspect 'X'
-> 123
?                                            # Empty line: Exit
:







================================================
FILE: doc/refR.html
================================================
R
R



*Rule


A global variable holding the current Pilog
rule symbol. It is cleared at the beginning of a new REPL. See also be and clause.


: (be likes (John Mary))
-> likes
: *Rule
-> likes




*Run


This global variable can hold a list of prg expressions which
are used during key, sync, wait and listen. The first element of each expression
must either be a positive number (thus denoting a file descriptor to wait for)
or a negative number (denoting a timeout value in milliseconds (in that case
another number must follow to hold the remaining time)). A poll(2)
system call is performed with these values, and the corresponding
prg body is executed when input data are available or when a
timeout occurred (with @ set to the file
descriptor or timeout value). See also task.


: (de *Run (-2000 0 (println '2sec)))     # Install 2-sec-timer
-> *Run
: 2sec                                    # Prints "2sec" every 2 seconds
2sec
2sec
                                          # (Ctrl-D) Exit
$




+Ref


Prefix class for maintaining non-unique indexes to +relations, a subclass of +index. Accepts an optional argument for a
+Hook attribute. See also Database.


(rel tel (+Fold +Ref +String))  # Phone number with folded, non-unique index




+Ref2


Prefix class for maintaining a secondary ("backing") index to +relations. Can only be used as a prefix
class to +Key or +Ref. It maintains an index in the current
(sub)class, in addition to that in one of the superclasses (must be a
+Ref), to allow (sub)class-specific queries. See also Database.


(class +Ord +Entity)             # Order class
(rel nr (+Need +Ref +Number))    # Order number
...
(class +EuOrd +Ord)              # EU-specific order subclass
(rel nr (+Ref2 +Key +Number))    # Order number with backing index




+relation


Abstract base class of all database relations. Relation objects are usually
defined with rel. The class hierarchy
includes the classes +Any, +Bag, +Bool, +Number, +Date, +Time, +Symbol, +String, +Link, +Joint and +Blob, and the prefix classes +Hook, +Hook2, +index, +Key, +Ref, +Ref2, +Idx, +IdxFold, +Sn, +Fold, +Aux, +UB, +Dep, +List, +Need, +Mis, +Alt and +Swap. See also Database and +Entity.


Messages to relation objects include


mis> (Val Obj)       # Return error if mismatching type or value
has> (Val X)         # Check if the value is present
put> (Obj Old New)   # Put new value
rel> (Obj Old New)   # Maintain relational structures
lose> (Obj Val)      # Delete relational structures
keep> (Obj Val)      # Restore deleted relational structures
zap> (Obj Val)       # Clean up relational structures




(rand ['cnt1 'cnt2] | ['T]) -> cnt | flg


Returns a pseudo random number in the range of the positive short numbers
cnt1 and cnt2 (or -2147483648 .. +2147483647 if no
arguments are given). If the argument is T, a boolean value
flg is returned. Note that if a range is given, the results are
"more random" because the higher bits of the internal generator are used. See
also seed.


: (rand 3 9)
-> 3
: (rand 3 9)
-> 7




(range 'num1 'num2 ['num3]) -> lst


Produces a list of numbers in the range num1 through
num2. When num3 is non-NIL, it is used
to increment num1 (if it is smaller than num2) or to
decrement num1 (if it is greater than num2). See also
need.


: (range 1 6)
-> (1 2 3 4 5 6)
: (range 6 1)
-> (6 5 4 3 2 1)
: (range -3 3)
-> (-3 -2 -1 0 1 2 3)
: (range 3 -3 2)
-> (3 1 -1 -3)




range/3


(Deprecated since version 25.5.30) Pilog predicate that succeeds if the first
argument is in the range of the result of applying the get algorithm to the following
arguments. Typically used as filter predicate in select/3 database queries. See also
Comparing, isa/2, same/3, bool/3, head/3, fold/3, part/3 and tolr/3.


: (?
   @Nr (1 . 5)  # Numbers between 1 and 5
   @Nm "part"
   (select (@Item)
      ((nr +Item @Nr) (nm +Item @Nm))
      (range @Nr @Item nr)
      (part @Nm @Item nm) ) )
 @Nr=(1 . 5) @Nm="part" @Item={B1}
 @Nr=(1 . 5) @Nm="part" @Item={B2}
-> NIL




(rank 'any 'lst ['flg]) -> lst


Searches a ranking list. lst should be sorted. Returns the
element from lst with a maximal CAR less or equal to
any (if flg is NIL), or with a minimal
CAR greater or equal to any (if flg is
non-NIL), or NIL if no match is found. See also
assoc and Comparing.


: (rank 0 '((1 . a) (100 . b) (1000 . c)))
-> NIL
: (rank 50 '((1 . a) (100 . b) (1000 . c)))
-> (1 . a)
: (rank 100 '((1 . a) (100 . b) (1000 . c)))
-> (100 . b)
: (rank 300 '((1 . a) (100 . b) (1000 . c)))
-> (100 . b)
: (rank 9999 '((1 . a) (100 . b) (1000 . c)))
-> (1000 . c)
: (rank 50 '((1000 . a) (100 . b) (1 . c)) T)
-> (100 . b)




(rassoc 'any 'lst) -> lst


Reverse assoc. Returns the first
element from lst with its CDR equal to any, or
NIL if no match is found. See also rasoq and asoq.


: (rassoc 7 '((999 1 2 3) ("b" . 7) ("ok" "Hello")))
-> ("b" . 7)
: (rassoc (1 2 3) '((999 1 2 3) ("b" . 7) ("ok" "Hello")))
-> (999 1 2 3)
: (rassoc 'u '((999 1 2 3) ("b" . 7) ("ok" "Hello")))
-> NIL




(rasoq 'any 'lst) -> lst


Reverse asoq. Returns the first
element from lst with any as its CDR, or
NIL if no match is found. == is used for comparison (pointer equality). See
also assoc and rassoc.


: (rasoq 'b '((1 . a) (2 . b) (3 . c))) )
-> (2 . b)
: (rasoq "b" '((1 . a) (2 . b) (3 . c))) )
-> NIL




(raw ['flg]) -> flg


Console mode control function. When called without arguments, it returns the
current console mode (NIL for "cooked mode"). Otherwise, the
console is set to the new state. See also key.


$ pil +
: (raw)
-> NIL
: (raw T)
-> T
...  # Raw mode, no echo!




(rc 'sym 'any1 ['any2 ['any3 'any4..]]) -> any


Fetches a value from a resource file sym, or stores one or more
key-value pairs (any1 . any2) in that file, using the key
any1 (and optionally any3 etc. for multiple stores).
All values are stored in a list in the file, using assoc. During the whole operation, the file is
exclusively locked with ctl.


: (info "a.rc")               # File exists?
-> NIL                        # No
: (rc "a.rc" 'a 1)            # Store 1 for 'a'
-> 1
: (rc "a.rc" 'b (2 3 4))      # Store (2 3 4) for 'b'
-> (2 3 4)
: (rc "a.rc" 'c 'b)           # Store 'b' for 'c'
-> b
: (info "a.rc")               # Check file
-> (28 733124 . 61673)
: (in "a.rc" (echo))          # Display it
((c . b) (b 2 3 4) (a . 1))
-> T
: (rc "a.rc" 'c)              # Fetch value for 'c'
-> b
: (rc "a.rc" @)               # Fetch value for 'b'
-> (2 3 4)




(rd ['sym]) -> any


(rd 'cnt) -> num | NIL


Binary read: Reads one item from the current input channel in encoded binary
format. When called with a cnt argument (second form), that number
of raw bytes (in big endian format if cnt is positive, otherwise
little endian) is read as a single number. Upon end of file, if the
sym argument is given, it is returned, otherwise NIL.
See also pr, tell, hear and wr.


: (out "x" (pr 'abc "EOF" 123 "def"))
-> "def"
: (in "x" (rd))
-> abc
: (in "x"
   (make
      (use X
         (until (== "EOF" (setq X (rd "EOF")))  # '==' detects end of file
            (link X) ) ) ) )
-> (abc "EOF" 123 "def")  # as opposed to reading a symbol "EOF"

: (in "/dev/urandom" (rd 20))
-> 396737673456823753584720194864200246115286686486




(read ['sym1 ['sym2]]) -> any


Reads one item from the current input channel. NIL is returned
upon end of file. When called without arguments, an arbitrary Lisp expression is
read. Otherwise, a token (a number, an internal symbol, a transient symbol (for
punctuation), or a list of symbols (for a string)) is read. In that case,
sym1 specifies which set of characters to accept for continuous
symbol names (in addition to the standard alphanumerical characters), and
sym2 an optional comment character. See also any, str, line, skip and eof.


: (list (read) (read) (read))    # Read three things from console
123                              # a number
abcd                             # a symbol
(def                             # and a list
ghi
jkl
)
-> (123 abcd (def ghi jkl))
: (make (while (read "_" "#") (link @)))
abc = def_ghi("xyz"+-123) # Comment
NIL
-> (abc "=" def_ghi "(" ("x" "y" "z") "+" "-" 123 ")")




(recur lst . prg) -> any


(recurse ['any ..]) -> any


Implements anonymous recursion, by defining the function
recurse on the fly. During the execution of prg, the
symbol recurse is bound to the function definition (lst .
prg). See also let, lambda and tco.


: (de fibonacci (N)
   (when (lt0 N)
      (quit "Bad fibonacci" N) )
   (recur (N)
      (if (>= 2 N)
         1
         (+
            (recurse (dec N))
            (recurse (- N 2)) ) ) ) )
-> fibonacci
: (fibonacci 22)
-> 17711
: (fibonacci -7)
-7 -- Bad fibonacci




(redef sym . fun) -> sym


Redefines sym in terms of itself. The current definition is
saved in a new symbol, which is substituted for each occurrence of
sym in fun, and which is also returned. See also
de, undef, daemon and patch.


: (de hello () (prinl "Hello world!"))
-> hello
: (pp 'hello)
(de hello NIL
   (prinl "Hello world!") )
-> hello

: (redef hello (A B)
   (println 'Before A)
   (prog1 (hello) (println 'After B)) )
-> "hello"
: (pp 'hello)
(de hello (A B)
   (println 'Before A)
   (prog1 ("hello") (println 'After B)) )
-> hello
: (hello 1 2)
Before 1
Hello world!
After 2
-> "Hello world!"

: (redef * @
   (msg (rest))
   (pass *) )
-> "*"
: (* 1 2 3)
(1 2 3)
-> 6

: (redef + @
   (pass (ifn (num? (next)) pack +) (arg)) )
-> "+"
: (+ 1 2 3)
-> 6
: (+ "a" 'b '(c d e))
-> "abcde"




(reflect 'cnt 'sym)


Global variable holding a (possibly empty) function, which can be called
from native code to supply information of native data structures to Lisp. See
also native.





(rel sym lst [any ..]) -> any


Defines a relation for sym in the current class *Class, using lst as the list of
classes for that relation, and possibly additional arguments any
for its initialization. See also Database, class, extend, dm and var.


(class +Person +Entity)
(rel nm  (+List +Ref +String))            # Names
(rel tel (+Ref +String))                  # Telephone
(rel adr (+Joint) prs (+Address))         # Address

(class +Address +Entity)
(rel cit (+Need +Hook +Link) (+City))     # City
(rel str (+List +Ref +String) cit)        # Street
(rel prs (+List +Joint) adr (+Person))    # Inhabitants

(class +City +Entity)
(rel nm  (+List +Ref +String))            # Zip / Names




(release 'sym) -> NIL


Releases the mutex represented by the file 'sym'. This is the reverse
operation of acquire.


: (release "sema1")
-> NIL




(remark 'any)


Global variable holding a (possibly empty) function, which will be called
when a value is printed in the REPL. It can be used to provide further
information about that value.


: (date)
-> 739542  # 2024-12-16
: (scl 3)
-> 3  # 0.003
: 12.3
-> 12300  # 12.300
: (date)
-> 739542  # 2024-12-16 739.542



remote/2


(Deprecated since version 25.5.30) Pilog predicate for remote database queries.
It takes a list and an arbitrary number of clauses. The list should
contain a Pilog variable for the result in the CAR, and a list of
resources in the CDR. The clauses will be evaluated on remote machines
according to these resources. Each resource must be a cons pair of two
functions, an "out" function in the CAR, and an "in" function in the
CDR. See also *Ext, revolve/2, select/3 and db/3.


(setq *Ext           # Set up external offsets
   (mapcar
      '((@Host @Ext)
         (cons @Ext
            (curry (@Host @Ext (Sock)) (Obj)
               (when (or Sock (setq Sock (connect @Host 4040)))
                  (ext @Ext
                     (out Sock (pr (cons 'qsym Obj)))
                     (prog1
                        (in Sock (rd))
                        (unless @
                           (close Sock)
                           (off Sock) ) ) ) ) ) ) )
      '("localhost")
      '(20) ) )

(de rsrc ()  # Simple resource handler, ignoring errors or EOFs
   (extract
      '((@Ext Host)
         (let? @Sock (connect Host 4040)
            (cons
               (curry (@Ext @Sock) (X)  # out
                  (ext @Ext (out @Sock (pr X))) )
               (curry (@Ext @Sock) ()  # in
                  (ext @Ext (in @Sock (rd))) ) ) ) )
      '(20)
      '("localhost") ) )

: (?
   @Nr (1 . 3)
   @Sup 2
   @Rsrc (rsrc)
   (remote (@Item . @Rsrc)
      (db nr +Item @Nr @Item)
      (val @Sup @Item sup nr) )
   (show @Item) )
{AF2} (+Item)
   pr 1250
   inv 100
   sup {AG2}
   nm "Spare Part"
   nr 2
 @Nr=(1 . 3) @Sup=2 @Rsrc=((((X) (ext 20 (out 3 (pr X)))) NIL (ext 20 (in 3 (rd))))) @Item={AF2}
-> NIL




(remove 'cnt 'lst) -> lst


Removes the element at position cnt from lst. This
is a non-destructive operation. See also insert, place, append, delete and replace.


: (remove 3 '(a b c d e))
-> (a b d e)
: (remove 1 '(a b c d e))
-> (b c d e)
: (remove 9 '(a b c d e))
-> (a b c d e)




(repeat) -> lst


Makes the current Pilog definition "tail
recursive", by closing the previously defined rules in the definition's T
property to a circular list. See also repeat/0 and be.


(be a (1))     # Define three facts
(be a (2))
(be a (3))
(repeat)       # Unlimited supply

: (? (a @N))
 @N=1
 @N=2
 @N=3
 @N=1
 @N=2
 @N=3.         # Stop
-> NIL




repeat/0


Pilog predicate that always succeeds, also on
backtracking. See also repeat and
true/0.


: (be integer (@I)   # Generate unlimited supply of integers
   (^ @C (box 0))    # Init to zero
   (repeat)          # Repeat from here
   (^ @I (inc @C)) )
-> integer

: (? (integer @X))
 @X=1
 @X=2
 @X=3
 @X=4.               # Stop
-> NIL




(replace 'lst 'any1 'any2 ..) -> lst


Replaces in lst all occurrences of any1 with
any2. For optional additional argument pairs, this process is
repeated. This is a non-destructive operation. See also append, delete, insert, remove and place.


: (replace '(a b b a) 'a 'A)
-> (A b b A)
: (replace '(a b b a) 'b 'B)
-> (a B B a)
: (replace '(a b b a) 'a 'B 'b 'A)
-> (B A A B)




(request 'typ 'sym ['hook] 'val ..) -> obj


Returns a database object. If a matching object cannot be found (using
db), a new object of the given type is
created (using new). See also obj.


: (request '(+Item) 'nr 2)
-> {B2}




(request! 'typ 'sym ['hook] 'val ..) -> obj


Transaction wrapper function for request.
See also new!, set!, put! and inc!.





(rest) -> lst


Can only be used inside functions with a variable number of arguments (with
@). Returns the list of all remaining arguments from the internal
list. See also args, next, arg and pass.


: (de foo @ (println (rest)))
-> foo
: (foo 1 2 3)
(1 2 3)
-> (1 2 3)




(retract) -> lst


Removes a Pilog fact or rule. See also be, clause, asserta and assertz.


: (be a (1))
-> a
: (be a (2))
-> a
: (be a (3))
-> a

: (retract '(a (2)))
-> (((1)) ((3)))

:  (? (a @N))
 @N=1
 @N=3
-> NIL




retract/1


Pilog predicate that removes a fact or rule.
See also retract, asserta/1 and assertz/1.


: (be a (1))
-> a
: (be a (2))
-> a
: (be a (3))
-> a

: (? (retract (a 2)))
-> T
: (rules 'a)
1 (be a (1))
2 (be a (3))
-> a




(rev 'cnt1 'cnt2) -> cnt


Reverses the lowest cnt1 bits of cnt2. See also
>> and hash.


: (bin (rev 4 (bin "0101")))
-> "1010"
: (rev 32 1)
-> 2147483648
: (hex @)
-> "80000000"
: (rev 32 (hex "E0000000"))
-> 7




(reverse 'lst) -> lst


Returns a reversed copy of lst. See also flip.


: (reverse (1 2 3 4))
-> (4 3 2 1)




(rewind) -> flg


Sets the file position indicator for the current output stream to the
beginning of the file, and truncates the file length to zero. Returns
T when successful. See also flush.


: (out "a" (prinl "Hello world"))
-> "Hello world"
: (in "a" (echo))
Hello world
-> T
: (info "a")
-> (12 733216 . 53888)
: (out "a" (rewind))
-> T
: (info "a")
-> (0 733216 . 53922)




revolve/2


(Deprecated since version 25.5.30) Pilog predicate for quasi-parallel evaluation
of clauses. It takes a list and an arbitrary number of clauses. The list
should contain a Pilog variable for the result in the CAR, another Pilog
variable for passing the values in the CADR, and a list of values in the
CDDR. The clauses will be evaluated in a round-robin fashion. See also
remote/2.


: (solve
   (quote
      @Rsrc '((1 2 3 4) (5 6 7 8) (a b c))
      (revolve (@Res @Lst . @Rsrc)
         (lst @Res @Lst) ) )
   @Res )
-> (1 5 a 2 6 b 3 7 c 4 8)




(rid 'var 'any) -> any


Destructively removes all occurrences of any from the (possibly
circular) value of var, and returns the new value. See also
fifo, queue, cut and del.


$: (off E)
-> NIL
: (fifo 'E 1 2 3 2 4 2)
-> 2
: E
-> (2 1 2 3 2 4 .)
$: (rid 'E 2)
-> (4 1 3 .)
$: (rid 'E 4)
-> (3 1 .)




(rollback) -> flg


Cancels a transaction, by discarding all modifications of external symbols.
See also commit.


: (pool "db")
-> T
# .. Modify external objects ..
: (rollback)            # Rollback
-> T




(root 'tree) -> (num . sym)


Returns the root of a database index tree, with the number of entries in
num, and the base node in sym. See also tree.


: (root (tree 'nr '+Item))
-> (6 . {H1})




(rot 'lst ['cnt]) -> lst


Rotate: The contents of the cells of lst are (destructively)
shifted right, and the value from the last cell is stored in the first cell.
Without the optional cnt argument, the whole list is rotated,
otherwise only the first cnt elements. See also flip .


: (rot (1 2 3 4))             # Rotate all four elements
-> (4 1 2 3)
: (rot (1 2 3 4 5 6) 3)       # Rotate only the first three elements
-> (3 1 2 4 5 6)




(round 'num1 ['num2]) -> sym


Formats a number num1 with num2 decimal places,
according to the current scale *Scl.
num2 defaults to 3. See also Numbers
and format.


: (scl 4)               # Set scale to 4
-> 4  # 0.0004
: (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
-> "12.3456"




(rt cnt . prg) -> any


Real/Runtime measurement: Executes prg, then (destructively)
adds the number of elapsed microseconds to the cnt parameter. Thus,
cnt will finally contain the total number of microseconds spent in
prg. See also usec.


: (de foo ()                        # Define function with empty loop
   (rt 0 (do 999999999)) )
-> foo
: (foo)                             # Execute it
-> NIL
: (pp 'foo)
(de foo NIL
   (rt 2022324 (do 999999999)) )    # 'rt' incremented 'cnt' by 2022324
-> foo




(rules 'sym ..) -> sym


Prints all rules defined for the sym arguments. See also Pilog and be.


: (rules 'member 'append)
1 (be member (@X (@X . @)))
2 (be member (@X (@ . @Y)) (member @X @Y))
1 (be append (NIL @X @X))
2 (be append ((@A . @X) @Y (@A . @Z)) (append @X @Y @Z))
-> append




(run 'any ['cnt]) -> any


If any is an atom, run behaves like eval. Otherwise any is a list,
which is evaluated in sequence. The last result is returned. If an offset
cnt is given, the value of @ in the cnt'th call environment
is used during that evaluation. cnt should be greater than zero.
See also up.


: (run '((println (+ 1 2 3)) (println 'OK)))
6
OK
-> OK

: (de f (N . Prg)
   (when (gt0 N)
      (prinl "1: @ = " @)  # '@' is 4, as 'N' is 4 from the call below
      (run Prg 1) ) )  # but printed is 3, as it was set by 'and'
-> f

: (and 3 (f 4 (prinl "2: @ = " @)))  # '@' was 3 when 'f' was called
1: @ = 4
2: @ = 3
-> 3







================================================
FILE: doc/refS.html
================================================
S
S



*Scl


A global variable holding the current fixpoint input scale. See also Numbers and scl.


: (str "123.45")  # Default value of '*Scl' is 0
-> (123)
: (setq *Scl 3)
-> 3
: (str "123.45")
-> (123450)

: 123.4567
-> 123457
: 12.3456
-> 12346




*Sig1


*Sig2


Global variables holding (possibly empty) prg bodies, which
will be executed when a SIGUSR1 signal (or a SIGUSR2 signal, respectively) is
sent to the current process. See also alarm, *Hup, sigio, *TStp[12], *Winch and *Term.


: (de *Sig1 (msg 'SIGUSR1))
-> *Sig1




*Solo


A global variable indicating exclusive database access. Its value is
0 initially, set to T (or NIL) during
cooperative database locks when lock
is successfully called with a NIL (or non-NIL)
argument. See also *Zap.


: *Solo
-> 0
: (lock *DB)
-> NIL
: *Solo
-> NIL
: (rollback)
-> T
: *Solo
-> 0
: (lock)
-> NIL
: *Solo
-> T
: (rollback)
-> T
: *Solo
-> T




+Sn


Prefix class for maintaining indexes according to a modified soundex
algorithm, for tolerant name searches, to +String relations. Typically used in
combination with the +Idx prefix
class. See also Database.


(rel nm (+Sn +Idx +String))  # Name




+String


Class for string (transient symbol) relations, a subclass of +Symbol. Accepts an optional argument for
the string length (currently not used). See also Database.


(rel nm (+Sn +Idx +String))  # Name, indexed by soundex and substrings




+Swap


Prefix class for +relations
where the data are to be stored in the value of a separate external symbol
instead of the relation's object. Typically used for data which are relatively
large and/or rarely accessed. Doesn't work with bidirectional relations
(+Joint or +index). See also Database.


(rel pw (+Swap +String))               # Password
(rel nr (+Swap +List +Number))         # List of bignums




+Symbol


Class for symbolic relations, a subclass of +relation. Objects of that class typically
maintain internal symbols, as opposed to the more often-used +String for transient symbols. See also Database.


(rel perm (+List +Symbol))  # Permission list




same/3


(Deprecated since version 25.5.30) Pilog predicate that succeeds if the first
argument matches the result of applying the get algorithm to the following
arguments. Typically used as filter predicate in select/3 database queries. See also
isa/2, bool/3, range/3, head/3, fold/3, part/3 and tolr/3.


: (?
   @Nr 2
   @Nm "Spare"
   (select (@Item)
      ((nr +Item @Nr) (nm +Item @Nm))
      (same @Nr @Item nr)
      (head @Nm @Item nm) ) )
 @Nr=2 @Nm="Spare" @Item={B2}




(scan 'tree ['fun] ['any1] ['any2] ['flg])


Scans through a database tree by applying fun to all key-value
pairs. fun should be a function accepting two arguments for key and
value. It defaults to println.
any1 and any2 may specify a range of keys. If
any1 is greater than any2, the traversal will be in
opposite direction. Note that the keys need not to be atomic, depending on the
application's index structure. If flg is non-NIL,
partial keys are skipped. See also tree, iter, init and step.


: (scan (tree 'nm '+Item))
("ASLRSNSTRSTN" {B3} . T) {B3}
("Additive" {B4}) {B4}
("Appliance" {B6}) {B6}
("Auxiliary Construction" . {B3}) {B3}
("Construction" {B3}) {B3}
("ENNSNNTTTF" {B4} . T) {B4}
("Enhancement Additive" . {B4}) {B4}
("Fittings" {B5}) {B5}
("GTSTFLNS" {B6} . T) {B6}
("Gadget Appliance" . {B6}) {B6}
...

: (scan (tree 'nm '+Item) println NIL T T)  # 'flg' is non-NIL
("Auxiliary Construction" . {B3}) {B3}
("Enhancement Additive" . {B4}) {B4}
("Gadget Appliance" . {B6}) {B6}
("Main Part" . {B1}) {B1}
("Metal Fittings" . {B5}) {B5}
("Spare Part" . {B2}) {B2}
-> NIL




(scl 'num [. prg]) -> num


If prg is given, it binds *Scl dynamically to num during the
execution of prg. Otherwise, it sets *Scl globally to num. See also Numbers.


: (scl 0)
-> 0
: (str "123.45")
-> (123)
: (scl 1)
-> 1  # 0.1
: (read)
123.45
-> 1235  # 123.5
: (scl 3)
-> 3  # 0.003
: (str "123.45")
-> (123450)
: (scl 1 (str "123.45"))
-> (1235)
: *Scl
-> 3  # 0.003




(script 'any ..) -> any


The first any argument is loaded, with the remaining arguments passed as variable arguments. They can be
accessed with next, arg, args and rest. With that, the syntax in the script is
the same as that in the body of a function with variable arguments (see lambda expressions, "when the CAR is the symbol @").


$ cat x
(* (next) (next))

$ pil +
: (script "x" 3 4)
-> 12




(search 'any 'lst ['any 'lst ..] ['fun]) -> lst


(search 'lst) -> obj | NIL


Searches the database for an arbitrary number
of any criteria. The first form returns a list holding a query
structure according to the corresponding lst lists of relation
specifications. A search criterion can be an atom for an exact search, or a cons
pair for a range search. A relation specification can be a list (var cls
[hook]) for an index search, a cons pair (sym . sym) for the
two endpoints of a +Joint, or - only
instead of the first specification in lst - two functions: A
generator function and a filter function. The final fun argument
may optionally filter and possibly modify each result. The second form takes a
query structure as returned from the first form, and returns the next result (an
object) or NIL (if there are no more matching results).
search is described in detail in The 'search'
Function. See also init, step and collect.


: (for
   (Q
      (search
         (2 . 5) '((nr +Item))  # Select all items with numbers between 2 and 5
         "Active" '((nm +CuSu) (sup +Item)) )  # and suppliers matching "Active"
      (search Q) )
   (show @) )
{B3} (+Item)
   sup {C1}
   nr 3
   pr 15700
   inv 100
   nm "Auxiliary Construction"
{B5} (+Item)
   sup {C1}
   nr 5
   pr 7980
   inv 100
   nm "Metal Fittings"
-> {B5}




(sect 'lst1 'lst2) -> lst


Returns the intersection of list arguments, all elements which are both in
lst1 and in lst2. See also diff.


: (sect (1 2 3 4) (3 4 5 6))
-> (3 4)
: (sect (1 2 3) (4 5 6))
-> NIL




(seed 'any) -> cnt


Initializes the random generator's seed, and returns a pseudo random number
in the range -2147483648 .. +2147483647. See also rand and hash.


: (seed "init string")
-> -417605464
: (rand)
-> -1061886707
: (rand)
-> 822065436

: (seed (time))
-> 128285383




(seek 'fun 'lst ..) -> lst


Applies fun to lst and all successive CDRs, until
non-NIL is returned. Returns the tail of lst starting
with that element (and stores the non-NIL value in the global
variable @@), or NIL if
fun did not return non-NIL for any element of
lst. When additional lst arguments are given, they are
passed to fun in the same way. See also find, pick.


: (seek '((X) (> (car X) 9)) (1 5 8 12 19 22))
-> (12 19 22)




(select [var ..] cls [hook] [var val ..]) -> obj | NIL


(Debug mode only) Interactive database function, loosely modelled after the
SQL 'SELECT' command. A front-end to search. When called with only a
cls argument, select steps through all objects of that
class, and shows their complete
contents (this is analog to 'SELECT * from CLS'). If cls is
followed by attribute/value specifications, the search is limited to these
values (this is analog to 'SELECT * from CLS where VAR = VAL'). If before
cls one or several attribute names are supplied, only these
attribute (instead of the full show) are printed. These attribute
specifications may also be lists, then those will be evaluated to retrieve
related data. After each step, select waits for a key, and
terminates when ESC is pressed. The global variable This is set to the last result. See also Database and Pilog.


: (select +Item)                       # Show all items
{B1} (+Item)
   nr 1
   nm "Main Part"
   pr 29900
   inv 100
   sup {C1}
{B2} (+Item)
   nr 2
   nm "Spare Part"
   pr 1250
   inv 100
   sup {C2}
-> {B2}                                # ESC was pressed

: (select +Item nr 3)                  # Show only item 3
{B3} (+Item)
   nr 3
   sup {C1}
   pr 15700
   nm "Auxiliary Construction"
   inv 100
-> NIL

# Show selected attributes for items 3 through 3
: (select nr nm pr (: sup nm) +Item nr (3 . 5))
3 "Auxiliary Construction" 157.00 "Active Parts Inc." {B3}
4 "Enhancement Additive" 9.99 "Seven Oaks Ltd." {B4}
5 "Metal Fittings" 79.80 "Active Parts Inc." {B5}
-> NIL




select/3


(Deprecated since version 25.5.30) Pilog database predicate that allows combined
searches over +index and
other relations. It takes a list of Pilog variables, a list of generator
clauses, and an arbitrary number of filter clauses. The functionality is
described in detail in The 'select' Predicate.
See also db/3, isa/2, same/3, bool/3, range/3, head/3, fold/3, part/3, tolr/3 and remote/2.


: (?
   @Nr (2 . 5)          # Select all items with numbers between 2 and 5
   @Sup "Active"        # and suppliers matching "Active"
   (select (@Item)                                  # Bind results to '@Item'
      ((nr +Item @Nr) (nm +CuSu @Sup (sup +Item)))  # Generator clauses
      (range @Nr @Item nr)                          # Filter clauses
      (part @Sup @Item sup nm) ) )
 @Nr=(2 . 5) @Sup="Active" @Item={B3}
 @Nr=(2 . 5) @Sup="Active" @Item={B5}
-> NIL




(send 'msg 'obj ['any ..]) -> any


Sends the message msg to the object obj,
optionally with arguments any. If the message cannot be located in
obj, its classes and superclasses, an error "Bad
message" is issued. See also OO Concepts,
try, method, meth, super and extra.


: (send 'stop> Dlg)  # Equivalent to (stop> Dlg)
-> NIL




(seq 'cnt|sym1) -> sym | NIL


Sequential single step: Returns the first external symbol in the
cnt'th database file, or the next external symbol following
sym1 in the database, or NIL when the end of the
database is reached. See also free.


: (pool "db")
-> T
: (seq *DB)
-> {2}
: (seq @)
-> {3}




(set 'var 'any ..) -> any


Stores new values any in the var arguments. See
also setq, val, swap, con and def.


: (set 'L '(a b c)  (cdr L) 999)
-> 999
: L
-> (a 999 c)




(set! 'obj 'any) -> any


Transaction wrapper function for set. Note that for setting the value of entities
typically the set!> message
is used. See also new!, request!, put! and inc!.


(set! Obj (* Count Size))  # Setting a non-entity object to a numeric value




(setq var 'any ..) -> any


Stores new values any in the var arguments. See
also set, val and def.


: (setq  A 123  B (list A A))  # Set 'A' to 123, then 'B' to (123 123)
-> (123 123)




(shadows ['flg]) -> lst


(Debug mode only) Returns a list of all symbols shadowing other symbols in
the current namespace search order.
When flg non-NIL, these and the overshadowed
symbols are printed as a side effect. See also symbols and namespaces.


: (symbols '(vip pico))
-> (pico)
vip: (shadows T)
   vi pico~vi
   cmd pico~cmd
   shift pico~shift
-> (vi cmd shift)
vip: (symbols '(pico))
-> (vip pico)

$ pty  # After starting "chess" in PilBox
chess: (shadows T)
   field pico~field
   wake android~wake
   queue pico~queue
   alarm pico~alarm
-> (field wake queue alarm)
chess: (nsp 'field)
-> chess
chess: (nsp 'wake)
-> simul
chess: (nsp 'alarm)
-> android




(shift 'var) -> any


Sets the list in var to its CDR. (shift 'var) is
equivalent to (set 'var (cdr (val 'var))). See also push and pop.


: (setq A (1 2 3))
-> (1 2 3)
: (shift 'A)
-> (2 3)
: A
-> (2 3)




(show 'any ['sym|cnt ..]) -> any


Shows the name, value and property list of a symbol found by applying the
get algorithm to any and
the following arguments. See also view.


: (setq A 123456)
-> 123456
: (put 'A 'x 1)
-> 1
: (put 'A 'lst (9 8 7))
-> (9 8 7)
: (put 'A 'flg T)
-> T

: (show 'A)
A 123456
   flg
   lst (9 8 7)
   x 1
-> A

: (show 'A 'lst 2)
-> 8




show/1


Pilog predicate that always succeeds, and shows
the name, value and property list of the argument symbol. See also show.


: (? (db nr +Item 2 @Item) (show @Item))
{B2} (+Item)
   nm "Spare Part"
   nr 2
   pr 1250
   inv 100
   sup {C2}
 @Item={B2}
-> NIL




(sigio 'cnt . prg) -> cnt


Sets a signal handler prg for SIGIO on the file descriptor
cnt. Returns the file descriptor. See also alarm, *Hup, *Winch, *Sig[12], *TStp[12] and *Term.


# First session
: (sigio (setq *SigSock (port T 4444))  # Register signal handler at UDP port
   (while (udp *SigSock)                # Queue all received data
      (fifo '*SigQueue @) ) )
-> 3

# Second session
: (for I 7 (udp "localhost" 4444 I))  # Send numbers to first session

# First session
: (fifo '*SigQueue)
-> 1
: (fifo '*SigQueue)
-> 2




(size 'any) -> cnt


Returns the "size" of any. For numbers this is the number of
bytes needed for the value, for external symbols it is the number of bytes it
would occupy in the database, for other symbols it is the number of bytes
occupied by the UTF-8 representation of the name, and for lists it is the total
number of cells in this list and all its sublists. See also length and bytes.


: (size "abc")
-> 3
: (size "äbc")
-> 4
: (size 127)  # One byte
-> 1
: (size 128)  # Two bytes (eight bits plus sign bit!)
-> 2
: (size (1 (2) 3))
-> 4
: (size (1 2 3 .))
-> 3






Skips all whitespace (and comments if any is given) in the
input stream. Returns the next available character, or NIL upon end
of file. See also peek and eof.


$ cat a
# Comment
abcd
$ pil +
: (in "a" (skip "#"))
-> "a"




(solve 'lst [. prg]) -> lst


Evaluates a Pilog query and, returns the list
of result sets. If prg is given, it is executed for each result
set, with all Pilog variables bound to their matching values, and returns a list
of the results. See also pilog,
?, goal and prove.


: (solve '((append @X @Y (a b c))))
-> (((@X) (@Y a b c)) ((@X a) (@Y b c)) ((@X a b) (@Y c)) ((@X a b c) (@Y)))

: (solve '((append @X @Y (a b c))) @X)
-> (NIL (a) (a b) (a b c))




(sort 'lst ['fun]) -> lst


Returns a sorted list by destructively exchanging the elements of
lst. If fun is given, it is used as a "less than"
predicate for comparisons. Typically, sort is used in combination
with by, giving shorter and often more efficient
solutions than with the predicate function. See also Comparing, group, maxi, mini and uniq.


: (sort '(a 3 1 (1 2 3) d b 4 T NIL (a b c) (x y z) c 2))
-> (NIL 1 2 3 4 a b c d (1 2 3) (a b c) (x y z) T)
: (sort '(a 3 1 (1 2 3) d b 4 T NIL (a b c) (x y z) c 2) >)
-> (T (x y z) (a b c) (1 2 3) d c b a 4 3 2 1 NIL)
: (by cadr sort '((1 4 3) (5 1 3) (1 2 4) (3 8 5) (6 4 5)))
-> ((5 1 3) (1 2 4) (1 4 3) (6 4 5) (3 8 5))




(space ['cnt]) -> cnt


Prints cnt spaces, or a single space when cnt is
not given. See also beep, prin and char.


: (space)
 -> 1
: (space 1)
 -> 1
: (space 2)
  -> 2




(sp? 'any) -> flg


Returns T when the argument any is
NIL, or if it is a string (symbol) that consists only of whitespace
characters.


: (sp? "  ")
-> T
: (sp? "ABC")
-> NIL
: (sp? 123)
-> NIL




(split 'lst 'any ..) -> lst


Splits lst at all places containing an element any
and returns the resulting list of sublists. See also stem.


: (split (1 a 2 b 3 c 4 d 5 e 6) 'e 3 'a)
-> ((1) (2 b) (c 4 d 5) (6))
: (mapcar pack (split (chop "The quick brown fox") " "))
-> ("The" "quick" "brown" "fox")




(sq 'num1 ['num2]) -> num


Returns the square of num1. If num2 is given, the
result will be divided by it and rounded. (sq 'num1 'num2) is
equivalent to (*/ 'num1 'num1 'num2). See also */.


: (sq 6)
-> 36
: (sq -6 10)
-> 4

: (scl 6)
-> 6  # 0.000006
: (sqrt 2.0 1.0)
-> 1414214  # 1.414214
: (sq @ 1.0)
-> 2000001  # 2.000001





(sqrt 'num ['flg|num]) -> num


Returns the square root of the num argument. If
flg is given and non-NIL, the result will be rounded.
If in addition to that flg is a number, the first argument will be
multiplied with it before doing the square root calculation. See also */.


: (sqrt 64)
-> 8
: (sqrt 1000)
-> 31
: (sqrt 1000 T)
-> 32
: (sqrt 10000000000000000000000000000000000000000)
-> 100000000000000000000

: (scl 6)
-> 6  # 0.000006
: (sqrt 2.0 1.0)
-> 1414214  # 1.414214




(ssl 'host 'path . prg) -> any


Executes prg in an input stream (using in) from "@bin/ssl" requesting path
from host.


: (ssl "picolisp.com" "wiki/?home" (line T))
-> "<!DOCTYPE html>"




(stack ['cnt ['cnt]]) -> cnt | (.. (any . cnt) . cnt)


Maintains the stack segment sizes for coroutines. By default, coroutine sizes are 64 kB
each, and the main stack segment size is 256 kB. If called with at least one
argument and no coroutine running, the stack segment size is set to the first
cnt argument, and optionally the main segment size is set to the
second cnt argument. Otherwise, the current size in kilobytes is
returned and - if there are running coroutines - pairs of their tags and unused
stack spaces are consed in front of
the size. See also heap.


$ ulimit -s unlimited  &&  pil +  # Guarantee stack space
: (stack)        # Current size
-> 64            # 64 kB
: (stack 20 80)  # Reduce to 20 kB
-> 20
: (co 'inc (let N 0 (loop (yield (inc 'N)))))  # Create two coroutines
-> 1
: (co 'dec (let N 0 (loop (yield (dec 'N)))))
-> -1
: (stack)
-> ((dec . 19) (inc . 19) (T . 75) . 20)




(stamp ['dat 'tim] | ['T]) -> sym


Returns a date-time string in the form "YYYY-MM-DD HH:MM:SS". If
dat and tim is missing, the current date and time is
used. If T is passed, the current Coordinated Universal Time (UTC)
is used instead. See also date and
time.


: (stamp)
-> "2000-09-12 07:48:04"
: (stamp (date) 0)
-> "2000-09-12 00:00:00"
: (stamp (date 2000 1 1) (time 12 0 0))
-> "2000-01-01 12:00:00"




(state 'var (sym|lst exe [. prg]) ..) -> any


Implements a finite state machine. The variable var holds the
current state as a symbolic value. When a clause is found that contains the
current state in its CAR sym|lst value, and where the
exe in its CADR evaluates to non-NIL, the current
state will be set to that value, the body prg in the CDDR will be
executed, and the result returned. T is a catch-all for any state.
If no state-condition matches, NIL is returned. See also case, cond and job.


: (de tst ()
   (job '((Cnt . 4))
      (state '(start)
         (start 'run
            (printsp 'start) )
         (run (and (gt0 (dec 'Cnt)) 'run)
            (printsp 'run) )
         (run 'stop
            (printsp 'run) )
         (stop 'start
            (setq Cnt 4)
            (println 'stop) ) ) ) )
-> tst
: (do 12 (tst))
start run run run run stop
start run run run run stop
-> stop
: (pp 'tst)
(de tst NIL
   (job '((Cnt . 4))
      (state '(start)
      ...
-> tst
: (do 3 (tst))
start run run -> run
: (pp 'tst)
(de tst NIL
   (job '((Cnt . 2))
      (state '(run)
      ...
-> tst




(stem 'lst 'any ..) -> lst


Returns the tail of lst that does not contain any of the
any arguments. (stem 'lst 'any ..) is equivalent to
(last (split 'lst 'any ..)). See also tail and split.


: (stem (chop "abc/def\\ghi") "/" "\\")
-> ("g" "h" "i")




(step 'lst ['flg]) -> any


Single-steps iteratively through a database tree. lst is a
structure as received from init. If
flg is non-NIL, partial keys are skipped. The key for
each returned value is stored in the global variable @@. See also tree, scan, iter, leaf and fetch.


: (setq Q (init (tree 'nr '+Item) 3 5))
-> (((3 . 5) ((3 NIL . {B3}) (4 NIL . {B4}) (5 NIL . {B5}) (6 NIL . {B6}))))
: (get (step Q) 'nr)
-> 3
: (get (step Q) 'nr)
-> 4
: (get (step Q) 'nr)
-> 5
: (get (step Q) 'nr)
-> NIL




(store 'tree 'any1 'any2 ['(num1 . num2)])


Stores a value any2 for the key any1 in a database
tree. num1 is a database file number, as used in new (defaulting to 1), and num2 a
database block size (defaulting to 256). When any2 is
NIL, the corresponding entry is deleted from the tree. See also
tree and fetch.


: (store (tree 'nr '+Item) 2 '{B2})




(str 'sym ['sym1]) -> lst


(str 'lst) -> sym


In the first form, the string sym is parsed into a list. This
mechanism is also used by load. If
sym1 is given, it should specify a set of characters, and
str will then return a list of tokens analog to read. The second form does the reverse
operation by building a string from a list. See also any, name and sym.


: (str "a (1 2) b")
-> (a (1 2) b)
: (str '(a "Hello" DEF))
-> "a \"Hello\" DEF"
: (str "a*3+b*4" "_")
-> (a "*" 3 "+" b "*" 4)




(str? 'any) -> sym | NIL


Returns the argument any when it is a transient symbol
(string), otherwise NIL. See also sym?, box? and ext?.


: (str? 123)
-> NIL
: (str? '{ABC})
-> NIL
: (str? 'abc)
-> NIL
: (str? "abc")
-> "abc"




(strDat 'sym) -> dat


Converts a string sym in the date format of the current
locale to a date. See also expDat, $dat and datStr.


: (strDat "2007-06-01")
-> 733134
: (strDat "01.06.2007")
-> NIL
: (locale "DE" "de")
-> NIL
: (strDat "01.06.2007")
-> 733134
: (strDat "1.6.2007")
-> 733134




(strip 'any) -> any


Strips all leading quote calls from any. See also
lit.


: (strip 123)
-> 123
: (strip '''(a))
-> (a)
: (strip (quote quote a b c))
-> (a b c)




(struct 'num 'any 'any ..) -> any


Creates or extracts data structures, suitable to be passed to or returned
from native functions. The first
num argument should be a native value, either a scalar, or a
pointer obtained by calling functions like malloc(). The second
argument any is a result
specification, while all following initialization items are stored in the structure
pointed to by the first argument. See also Native C
Calls.


: (scl 2)
-> 2  # 0.02

## /* We assume the following C structure */
## typedef struct value {
##    int x, y;
##    double a, b, c;
##    long z;
##    char nm[4];
## } value;

# Allocate structure
: (setq P (%@ "malloc" 'N 56))
-> 498324676928

# Store two integers, three doubles, one long, and four characters
: (struct P NIL -7 -4 (1.0 0.11 0.22 0.33) (7 . 8) 65 66 67 0)
-> NIL

# Extract the structure
: (struct P '((I . 2) (1.0 . 3) N (C . 4)))
-> ((7 4) (11 22 33) 7 ("A" "B" "C"))

# Do both in a single call (allowing conversions of data types)
: (struct P
   '((I . 2) (1.0 . 3) N (C . 4))
   -7 -4 (1.0 0.11 0.22 0.33) (7 . 8) 65 66 67 0 )
-> ((7 4) (11 22 33) 7 ("A" "B" "C"))

# De-allocate structure
: (%@ "free" NIL P)
-> NIL




(sub? 'any1 'any2 ['cnt]) -> any2 | NIL


Returns any2 when the string representation of
any1 is a substring of the string representation of
any2, and stores the substring's byte position in the
global variable @@. When
cnt is given, the search starts at that byte position
(default is 1). See also pre?,
offset and index.


: (sub? "def" "abcdefg")
-> "abcdefg"
: (sub? "abb" "abcdefg")
-> NIL
: (sub? NIL "abcdefg")
-> "abcdefg"

: (sub? "def" '(a b c d e f g))
-> "abcdefg"
: (sub? '(d e f) "abcdefg")
-> "abcdefg"

: (sub? "" "abc") @@
-> 0
: (sub? "a" "abc") @@
-> 1
: (sub? "b" "abc") @@
-> 2

: (sub? "bc" "abcXabc") @@
-> 2
: (sub? "bc" "abcXabc" 2) @@
-> 2
: (sub? "bc" "abcXabc" 3) @@
-> 6




(subr 'sym) -> num


Converts a Lisp-function that was previously converted with expr back to a SUBR function.


: car
-> 67313448
: (expr 'car)
-> (@ (pass $385260187))
: (subr 'car)
-> 67313448
: car
-> 67313448




(sum 'fun 'lst ..) -> num


Applies fun to each element of lst. When
additional lst arguments are given, their elements are also passed
to fun. Returns the sum of all numeric values returned from
fun.


: (setq A 1  B 2  C 3)
-> 3
: (sum val '(A B C))
-> 6
: (sum * (3 4 5) (5 6 7))        # Vector dot product
-> 74
: (sum                           # Total size of symbol list values
   '((X)
      (and (pair (val X)) (size @)) )
   (what) )
-> 32021




(super ['any ..]) -> any


Can only be used inside methods. Sends the current message to the current
object This, this time starting the search for a method at the
superclass(es) of the class where the current method was found. See also OO Concepts, extra, method, meth, send and try.


(dm stop> ()         # 'stop>' method of current class
   (super)           # Call the 'stop>' method of the superclass
   ... )             # other things




(swap 'var 'any) -> any


Set the value of var to any, and return the
previous value. See also xchg and
set.


: (setq A 7  L (1 2 3))
-> (1 2 3)
: (swap (cdr L) (swap 'A 'xyz))
-> 2
: A
-> xyz
: L
-> (1 7 3)




(sym 'any) -> sym


Generate the printed representation of any into the name of a
new symbol sym. This is the reverse operation of any. See also name and str.


: (sym '(abc "Hello" 123))
-> "(abc \"Hello\" 123)"




(sym? 'any) -> flg


Returns T when the argument any is a symbol. See
also num?, atom, pair, str?, box? and ext?.


: (sym? 'a)
-> T
: (sym? NIL)
-> T
: (sym? 123)
-> NIL
: (sym? '(a b))
-> NIL




(symbols) -> lst


(symbols 'lst) -> lst


(symbols 'lst . prg) -> any


(symbols ['T] 'sym1 'sym2 ..) -> lst


Creates and manages namespaces of
internal symbols: In the first form, the current list of namespaces is
returned. In the second form, the current namespace list is set to
lst, and the previous namespace list is returned. In the
third form, the current namespace list is set to lst during
the execution of prg, and the result is returned. In the
fourth form, sym1 is initialized to a new namespace if its
value is NIL and not modified otherwise, sym1,
sym2 and all following arguments are set as the current
namespace list, and if the value of the global variable *Dbg is non-NIL, the current line
number and file name (if any) are stored in the *Dbg
property of sym1. If the first argument is T,
the resulting namespace list is also exported from the current REPL. See
also pico, nsp, -symbols, private, local, namespaces, shadows, export, import, intern and load.


: (symbols 'myLib 'pico)
-> (pico)
myLib: (de foo (X)
   (bar (inc X)) )
-> foo
myLib: (symbols 'pico)
-> (myLib pico)
: (pp 'foo)
(de foo . NIL)
-> foo
: (pp 'myLib~foo)
(de "foo" (X)
   ("bar" (inc X)) )
-> "foo"
: (symbols '(myLib pico))
-> (pico)
myLib: (pp 'foo)
(de foo (X)
   (bar (inc X)) )
-> foo
myLib:




(-symbols) -> lst


Command line frontend to symbols. Inserts the next command line
argument as the first namespace into the current search order. --symbols
myLib on the command line (see Invocation)
is equivalent to -"symbols '(myLib ...)". See also opt.


$ ./pil lib/gis.l lib/simul.l  --symbols gis  --symbols simul  +
simul: (symbols)
-> (simul gis pico)
simul:




(sync) -> flg


Waits for pending data from all family processes. While other processes are
still sending data (via the tell
mechanism), a poll(2) system call is executed for all file
descriptors and timers in the VAL of the global variable *Run. When used in a non-database context,
(tell) should be called in the end to inform the parent process
that it may grant synchronization to other processes waiting for
sync. In a database context, where sync is usually
called by dbSync, this is not
necessary because it is done internally by commit or rollback.

See also key and wait.


: (or (lock) (sync))       # Ensure database consistency
-> T                       # (numeric process-id if lock failed)




(sys 'any ['any]) -> sym


Returns or sets a system environment variable.


: (sys "TERM")  # Get current value
-> "xterm"
: (sys "TERM" "vt100")  # Set new value
-> "vt100"
: (sys "TERM")
-> "vt100"




(sysdefs 'sym1 '[sym2])


Loads system-dependent definitions for all symbols in the section named
sym1 from the file "@lib/sysdefs" (or an alternative file given by
sym2). All symbols in that section are defined to their given values. See also native.


: (sysdefs "networking")  # Load networking system definitions







================================================
FILE: doc/refT.html
================================================
T
T



*Term


Global variable holding a (possibly empty) prg body, which will
be executed when a SIGTERM signal is sent to the current process. If it returns
non-NIL, the signal is ignored.
See also
alarm, sigio, *Hup, *Winch, *Sig[12] and *TStp[12].


: (de *Term (msg 'SIGTERM) T)
-> *Term




*TStp1


*TStp2


Global variables holding (possibly empty) prg bodies, which
will be executed when a SIGTSTP signal (*TStp1) or a SIGCONT signal
(*TStp2) is sent to the current process. See also alarm, sigio, *Hup, *Winch, *Sig[12] and *Term.


: (de *TStp1 (msg 'SIGTSTP))
-> *TStp1




*Tmp


A global variable holding the temporary directory name created with tmp. See also *Bye.


: *Bye
-> ((saveHistory) (and *Tmp (call 'rm "-r" *Tmp)))
: (tmp "foo" 123)
-> "/home/app/.pil/tmp/27140/foo123"
: *Tmp
-> "/home/app/.pil/tmp/27140/"




+Time


Class for clock time values (as calculated by time), a subclass of +Number. See also Database.


(rel tim (+Time))  # Time of the day




T


A global constant, evaluating to itself. T is commonly returned
as the boolean value "true" (though any non-NIL values could be
used). It represents the absolute maximum, as it is larger than any other
object. As a property key, it is used to store Pilog clauses, and inside Pilog clauses it is the
cut operator. See also NIL and
and Comparing.


: T
-> T
: (= 123 123)
-> T
: (get 'not T)
-> ((@P (1 @P) T (fail)) (@P))




This


Holds the current object during method execution (see OO Concepts), or inside the body of a with statement. As it is a normal symbol,
however, it can be used in normal bindings anywhere. See also isa, :,
=:, :: and var:. See also
with and
this.


: (with 'X (println 'This 'is This))
This is X
-> X
: (put 'X 'a 1)
-> 1
: (put 'X 'b 2)
-> 2
: (put 'Y 'a 111)
-> 111
: (put 'Y 'b 222)
-> 222
: (mapcar '((This) (cons (: a) (: b))) '(X Y))
-> ((1 . 2) (111 . 222))




(t . prg) -> T


Executes prg, and returns T. See also nil, prog, prog1 and prog2.


: (t (println 'OK))
OK
-> T




(tab 'lst 'any ..) -> NIL


Print all any arguments in a tabular format. lst
should be a list of numbers, specifying the field width for each argument. All
items in a column will be left-aligned for negative numbers, otherwise
right-aligned. See also align,
center and wrap.


: (let Fmt (-3 14 14)
   (tab Fmt "Key" "Rand 1" "Rand 2")
   (tab Fmt "---" "------" "------")
   (for C '(A B C D E F)
      (tab Fmt C (rand) (rand)) ) )
Key        Rand 1        Rand 2
---        ------        ------
A               0    1481765933
B     -1062105905    -877267386
C      -956092119     812669700
D       553475508   -1702133896
E      1344887256   -1417066392
F      1812158119   -1999783937
-> NIL




(tail 'cnt|lst 'lst) -> lst


Returns the last cnt elements of lst. If
cnt is negative, it is added to the length of lst. If
the first argument is a lst, tail is a predicate
function returning that argument list if it is equal to the tail of
the second argument, and NIL otherwise. (tail -2 Lst)
is equivalent to (nth Lst 3). See also offset, head, last and stem.


: (tail 3 '(a b c d e f))
-> (d e f)
: (tail -2 '(a b c d e f))
-> (c d e f)
: (tail 0 '(a b c d e f))
-> NIL
: (tail 10 '(a b c d e f))
-> (a b c d e f)
: (tail '(d e f) '(a b c d e f))
-> (d e f)




(task 'num ['num] [sym 'any ..] [. prg]) -> lst


A front-end to the *Run global. If
called with only a single num argument, the corresponding entry is
removed from the value of *Run. Otherwise, a new entry is created.
If an entry with that key already exists, an error is issued. For negative
numbers, a second number must be supplied. If sym/any
arguments are given, a job environment
is built for the *Run entry. See also tasks and timeout.


: (task -10000 5000 N 0 (tty (println (inc 'N))))  # Install task for every 10 seconds
-> (-10000 5000 (job '((N . 0)) (tty (println (inc 'N)))))
: 1                                                # ... after 5 seconds
2                                                  # ... after 10 seconds
3                                                  # ... after 10 seconds
(task -10000)                                      # remove again
-> NIL

: (task (port T 4444) (eval (udp @)))              # Receive RPC via UDP
-> (3 (eval (udp @)))

# Another session (on the same machine)
: (udp "localhost" 4444 '(println *Pid))  # Send RPC message
-> (println *Pid)




(tasks . prg)


Runs a task with variable event
specification in a single *Run entry.
The task body prg should return either a positive number (a file
descriptor) or a negative number (a timeout value) to be used in the next
iteration. The first value must be a timeout. A value of NIL
removes the task. Uses -2 as implicit key. See also timeout.


(tasks  # Three iterations with varying timeout
   (let X (pop '(((-1000 . a) (-4000 . b) (-1000 . c))))
      (tty (println (cdr X)))
      (car X) ) )

(tasks
   (co 'echoes  # Coroutine
      (use S
         (loop  # Loop infinitely
            (yield -4000)  # First wait 4 seconds
            (tty (println 'OK))
            (yield  # Then wait for remote data
               (setq S
                  (pipe (exec "sh" "-c" "sleep 2; echo 7")) ) )
            (tty (println (in S (read))))
            (close S) ) ) ) )




(tco lst . prg) -> any


(tc ['any ..])


Tail call optimization. tco implements a loop which is
restarted whenever tc is called during the execution of
prg. This is faster and uses much less stack space than a recursive
function call. lst is a list of parameter symbols. tc
must be the very last function called in a function body. See also recur and catch.


: (de f (N)
   (if (=0 N)
      'OK
      (printsp N)
      (f (dec N)) ) )  # Recursive call
-> f
: (f 8)
8 7 6 5 4 3 2 1 -> OK

# Equivalent to
: (de f (N)
   (tco (N)
      (if (=0 N)
         'OK
         (printsp N)
         (tc (dec N)) ) ) )  # Tail call
-> f
: (f 8)
8 7 6 5 4 3 2 1 -> OK

# Mutually recursive functions
: (de f (N)
   (tco (N)
      (if (le0 N)
         'OK
         (printsp N)
         (g (dec N)) ) ) )
-> f
: (de g (N)
   (if (le0 N)
      'OK
      (tc (dec N)) ) )  # Tail call
-> g
: (f 8)
8 6 4 2 -> OK




(telStr 'sym) -> sym


Formats a telephone number according to the current locale. If the string head matches the local
country code, it is replaced with the national trunk prefix, otherwise
+ is prepended. See also expTel, datStr, money and format.


: (telStr "49 1234 5678-0")
-> "+49 1234 5678-0"
: (locale "DE" "de")
-> NIL
: (telStr "49 1234 5678-0")
-> "01234 5678-0"




(tell ['cnt] 'sym ['any ..]) -> any


Family IPC: Send an executable list (sym any ..) to all family
members (i.e. all children of the current process, and all other children of the
parent process, see fork) for
automatic execution. When the cnt argument is given and non-zero,
it should be the PID of such a process, and the list will be sent only to that
process. If cnt is zero, the list will be sent to the parent
process instead. When called without arguments, no message is actually sent, and
the parent process may grant sync to
the next waiting process. tell is also used internally by commit to notify about database changes. When
called explicitly, the size of the message is limited to the POSIX constant
PIPE_BUF. See also kids, detach and hear.


: (call 'ps "x")                          # Show processes
  PID TTY      STAT   TIME COMMAND
  ..
 1321 pts/0    S      0:00 /usr/bin/picolisp ..  # Parent process
 1324 pts/0    S      0:01 /usr/bin/picolisp ..  # First child
 1325 pts/0    S      0:01 /usr/bin/picolisp ..  # Second child
 1326 pts/0    R      0:00 ps x
-> T
: *Pid                                    # We are the second child
-> 1325
: (tell 'println '*Pid)                   # Ask all others to print their Pid's
1324
-> *Pid




(test 'any . prg)


Executes prg, and issues an error if the result does not match the any argument. See also
assert.


: (test 12 (* 3 4))
-> NIL
: (test 12 (+ 3 4))
((+ 3 4))
12 -- 'test' failed
?




(text 'any1 'any ..) -> sym


Builds a new transient symbol (string) from the string representation of
any1, by replacing all occurrences of an at-mark "@",
followed by one of the letters "1" through "9", and
"A" through "Z", with the corresponding
any argument. In this context "@A" refers to the 10th
argument. A literal at-mark in the text can be represented by two successive
at-marks. See also pack and glue.


: (text "abc @1 def @2" 'XYZ 123)
-> "abc XYZ def 123"
: (text "a@@bc.@1" "de")
-> "a@bc.de"




(this 'any) -> any


Sets the current object This to the new value any.
(this 'any) is equivalent to (setq This 'any).
See also with.


: (this 'X)
-> X
: This
-> X




(throw 'sym 'any)


Non-local jump into a previous catch environment with the jump label
sym (or T as a catch-all). Any pending finally expressions are executed, local
symbol bindings are restored, open files are closed and internal data structures
are reset appropriately, as the environment was at the time when the
corresponding catch was called. Then any is returned
from that catch. See also quit.


: (de foo (N)
   (println N)
   (throw 'OK) )
-> foo
: (let N 1  (catch 'OK (foo 7))  (println N))
7
1
-> 1




(till 'any ['flg]) -> lst|sym


Reads from the current input channel till a character contained in
any is found (or until end of file if any is
NIL). If flg is NIL, a list of
single-character transient symbols is returned. Otherwise, a single string is
returned. See also from and line.


: (till ":")
abc:def
-> ("a" "b" "c")
: (till ":" T)
abc:def
-> "abc"




(tim$ 'tim ['flg]) -> sym


Formats a time tim.
If flg is NIL, the format is HH:MM, otherwise it is
HH:MM:SS. See also $tim and dat$.


: (tim$ (time))
-> "10:57"
: (tim$ (time) T)
-> "10:57:56"




(time ['T]) -> tim


(time 'tim) -> (h m s)


(time 'h 'm ['s]) -> tim | NIL


(time '(h m [s])) -> tim | NIL


Calculates the time of day, represented as the number of seconds since
midnight. When called without arguments, the current local time is returned.
When called with a T argument, the time of the last call to
date is returned. When called with a
single number tim, it is taken as a time value and a list with the
corresponding hour, minute and second is returned. When called with two or three
numbers (or a list of two or three numbers) for the hour, minute (and optionally
the second), the corresponding time value is returned (or NIL if
they do not represent a legal time). See also date, stamp, usec, tim$ and $tim.


: (time)                         # Now
-> 32334
: (time 32334)                   # Now
-> (8 58 54)
: (time 12 70)                   # Illegal time
-> NIL




(timeout ['num])


Sets or refreshes a timeout value in the *Run global, so that the current process
executes bye after the given period. If
called without arguments, the timeout is removed. Uses -1 as
implicit key. See also task.


: (timeout 3600000)           # Timeout after one hour
-> (-1 3600000 (bye))
: *Run                        # Look after a few seconds
-> ((-1 3574516 (bye)))




(tmp ['any ..]) -> sym


Returns the path name to the packed any arguments in a
process-local temporary directory. The directory name consists of the path to
".pil/tmp/" in the user's home directory, followed by the current process ID
*Pid. This directory is automatically
created if necessary, and removed upon termination of the process (bye). See also *Tmp and *Bye .


: *Pid
-> 27140
: (tmp "foo" 123)
-> "/home/app/.pil/tmp/27140/foo123"
: (out (tmp "foo" 123) (println 'OK))
-> OK
: (dir (tmp))
-> ("foo123")
: (in (tmp "foo" 123) (read))
-> OK




tolr/3


(Deprecated since version 25.5.30) Pilog predicate that succeeds if the first
argument, after folding it to
a canonical form, is either a substring or a +Sn soundex match of the result
of applying the get algorithm
to the following arguments. Typically used as filter predicate in
select/3 database queries.
See also isa/2, same/3, bool/3, range/3, head/3, fold/3 and part/3.


: (?
   @Nr (1 . 5)
   @Nm "Sven"
   (select (@CuSu)
      ((nr +CuSu @Nr) (nm +CuSu @Nm))
      (range @Nr @CuSu nr)
      (tolr @Nm @CuSu nm) )
   (val @Name @CuSu nm) )
 @Nr=(1 . 5) @Nm="Sven" @CuSu={C2} @Name="Seven Oaks Ltd."




(touch 'sym) -> sym


When sym is an external symbol, it is marked as "modified" so
that upon a later commit it will be
written to the database file. An explicit call of touch is only
necessary when the value or properties of sym are indirectly
modified.


: (get '{2} 'lst)
-> (1 2 3 4 5)
: (set (cdr (get (touch '{2}) 'lst)) 999)    # Only read-access, need 'touch'
-> 999
: (get '{2} 'lst)                            # Modified second list element
-> (1 999 3 4 5)




(trace 'sym)


(trace 'sym 'cls)


(trace '(sym . cls))


(Debug mode only) Inserts a $ trace
function call at the beginning of the function or method body of
sym, so that trace information will be printed before and after
execution. Can only be used with EXPRs and SUBRs. Built-in functions (SUBRs) are
automatically converted to Lisp expressions (see expr). See also *Dbg, traceAll and untrace, debug and lint.


: (trace '+)
-> +
: (+ 3 4)
 + : 3 4
 + = 7
-> 7




(-trace)


(Debug mode only) Command line frontend to trace. See also -debug.


$ ./pil --trace append +
: (append (1 2 3) (4 5 6))
 append : (1 2 3) (4 5 6)
 append = (1 2 3 4 5 6)
-> (1 2 3 4 5 6)




(traceAll ['lst]) -> sym


(Debug mode only) Traces all Lisp level functions by inserting a $ function call at the beginning. lst
may contain symbols which are to be excluded from that process. In addition, all
symbols in the global variable *NoTrace are excluded. See also
trace, untrace and *Dbg.


: (traceAll)      # Trace all Lisp level functions
-> balance




(trail ['flg]) -> lst


Returns a stack backtrace for the current point of program execution. The
list elements are either list expressions (denoting function or method calls),
or symbols followed by their corresponding values. If flg is
NIL, the symbols and their values are omitted, and only the
expressions are returned. See also bt,
up and env.


: (de f (A B)
   (g (inc A) (dec B)) )
-> f
: (de g (X Y)
   (trail T) )
-> g
: (f 3 4)
-> ((f 3 4) A 3 B 4 (g (inc A) (dec B)) X 4 Y 3)




(tree 'sym 'cls ['hook]) -> tree


Returns a data structure specifying a database index tree. sym
and cls determine the relation, with an optional hook
object. See also root, fetch, store, count, leaf, minKey, maxKey, init, step, scan, iter, prune, zapTree and chkTree.


: (tree 'nm '+Item)
-> (nm . +Item)




(trim 'lst) -> lst


Returns a copy of lst with all trailing whitespace characters
or NIL elements removed. See also clip.


: (trim (1 NIL 2 NIL NIL))
-> (1 NIL 2)
: (trim '(a b " " " "))
-> (a b)




true/0


Pilog predicate that always succeeds. See also
fail/0 and repeat/0.


:  (? (true))
-> T




(try 'msg 'obj ['any ..]) -> any


Tries to send the message msg to the object obj,
optionally with arguments any. If obj is not an
object, or if the message cannot be located in obj, in its classes
or superclasses, NIL is returned. See also OO Concepts, send, method, meth, super and extra.


: (try 'msg> 123)
-> NIL
: (try 'html> 'a)
-> NIL




(tty . prg) -> any


Redirects the current output channel to the terminal (stderr) during the
execution of prg. The current output channel and the state of
readline(3) will be saved and restored appropriately. See also
out.


: (task -2000 0 (tty (println (inc (0)))))
-> (-2000 0 (tty (println (inc (0)))))
1
2
3
: (* 3 4)  # Typed while numbers are printed




(type 'any) -> lst


Return the type (list of classes) of the object any. See also
OO Concepts, isa, class, new and object.


: (type '{1A;3})
(+Address)
: (type '+DnButton)
-> (+Tiny +Rid +JS +Able +Button)







================================================
FILE: doc/refU.html
================================================
U
U



*Uni


A global variable holding an idx
tree, with all unique data that were collected with the comma (,)
read-macro. Typically used for localization. Setting *Uni to
T disables this mechanism. See also Read-Macros and locale.


: (off *Uni)            # Clear
-> NIL
: ,"abc"                # Collect a transient symbol
-> "abc"
: ,(1 2 3)              # Collect a list
-> (1 2 3)
: *Uni
-> ("abc" NIL (1 2 3))




+UB


Prefix class for +Aux to maintain
an UB-Tree index instead of the direct values. This allows efficient range
access to multi-dimensional data. Only positive numeric keys are supported. See
also ubIter and Database.


(class +Pos +Entity)
(rel x (+UB +Aux +Ref +Number) (y z))
(rel y (+Number))
(rel z (+Number))

: (scan (tree 'x '+Pos))
(288362200753438306 . {13}) {13}
(348187139486943716 . {16}) {16}
(605261596962573238 . {11}) {11}
(638523558602802506 . {7}) {7}   # UBKEY of (453062 450921 613956)
(654697989157410399 . {12}) {12}
...

: (show '{7})
{7} (+Pos)
   x 453062
   y 450921
   z 613956
-> {7}

# Discrete queries work the same way as without the +UB prefix
: (db 'x '+Pos 453062 'y 450921 'z 613956)
-> {7}
: (aux 'x '+Pos 453062 450921 613956)
-> {7}
: (? (db x +Pos (453062 450921 613956) @Pos))
 @Pos={7}
-> NIL

# Range queries work efficiently with 'collect'. Note that though also Pilog
queries can handle UB-trees, they may do so sub-optimally for certain ranges.
: (collect 'x '+Pos (200000 200000 200000) (899999 899999 899999))
-> ({7} {14} {17} {15})




(u) -> T


(Debug mode only) Removes ! all
breakpoints in all subexpressions of the current breakpoint. Typically used when
single-stepping a function or method with debug. See also d and unbug.


! (u)                         # Unbug subexpression(s) at breakpoint
-> T




(ubIter 'tree 'dim 'fun 'lst1 'lst2)


Efficiently iterates through a database +UB tree, by applying fun to all
values. dim is the number of the key dimensions, lst1
and lst2 specify a range of keys. collect uses ubIter internally
for UB-tree queries. See also iter.


: (ubIter (tree 'x '+Pos) 3 show (200000 200000 200000) (899999 899999 899999))
{7} (+Pos)
   z 613956
   y 450921
   x 453062
{14} (+Pos)
   z 771372
   y 262217
   x 862358
{17} (+Pos)
   z 676836
   y 529576
   x 398229
{15} (+Pos)
   z 889332
   y 691799
   x 265381
-> NIL




(udp 'any1 'any2 'any3) -> any


(udp 'cnt) -> any


Simple unidirectional sending/receiving of UDP packets. In the first form,
any3 is sent to a UDP server listening at host any1,
port any2. In the second form, one item is received from a UDP
socket cnt, established with port. See also listen and connect.


# First session
: (port T 6666)
-> 3
: (udp 3)  # Receive a datagram

# Second session (on the same machine)
: (udp "localhost" 6666 '(a b c))
-> (a b c)

# First session
-> (a b c)




(ultimo 'y 'm) -> cnt


Returns the date of the last day
of the month m in the year y. See also day and week.


: (date (ultimo 2007 1))
-> (2007 1 31)
: (date (ultimo 2007 2))
-> (2007 2 28)
: (date (ultimo 2004 2))
-> (2004 2 29)
: (date (ultimo 2000 2))
-> (2000 2 29)
: (date (ultimo 1900 2))
-> (1900 2 28)




(unbug 'sym) -> T


(unbug 'sym 'cls) -> T


(unbug '(sym . cls)) -> T


(Debug mode only) Removes all !
breakpoints in the function or method body of sym, as inserted with debug or d, or directly with vi. See also u.


: (pp 'tst)
(de tst (N)
   (! println (+ 3 N)) )         # 'tst' has a breakpoint '!'
-> tst
: (unbug 'tst)                   # Unbug it
-> T
: (pp 'tst)                      # Restore
(de tst (N)
   (println (+ 3 N)) )




(undef 'sym) -> fun


(undef 'sym 'cls) -> fun


(undef '(sym . cls)) -> fun


Undefines the function or method sym. Returns the previous
definition. See also de, dm, def
and redef.


: (de hello () "Hello world!")
-> hello
: hello
-> (NIL "Hello world!")
: (undef 'hello)
-> (NIL "Hello world!")
: hello
-> NIL




(unify 'any) -> lst


(unify 'cnt) -> cnt


The first form unifies any with the current Pilog environment at the current level and with a
value of NIL, and returns the new environment or NIL
if not successful. The second form unifies all variables at the given level with
the current one. See also prove and
->.


: (? (^ @A (unify '(@B @C))))
 @A=(((NIL . @C) 0 . @C) ((NIL . @B) 0 . @B) T)




(uniq 'lst) -> lst


Returns a unique list, by eliminating all duplicate elements from
lst. See also Comparing, sort and group.


: (uniq (2 4 6 1 2 3 4 5 6 1 3 5))
-> (2 4 6 1 3 5)




uniq/2


Pilog predicate that succeeds if the second
argument is not yet stored in the first argument's index structure. idx is used internally storing for the values
and checking for uniqueness. See also member/2.


: (let U NIL
   (? (lst @X (a b c b c d)) (uniq U @X)) )
 @X=a
 @X=b
 @X=c
 @X=d
-> NIL
: (solve '((^ @B (box)) (lst @X (a b c b c d)) (uniq @B @X)) @X)
-> (a b c d)




(unless 'any . prg) -> any


Conditional execution: When the condition any evaluates to
non-NIL, NIL is returned. Otherwise prg
is executed and the result returned. See also when, ifn, nor, nand and nond.


: (unless (= 3 3) (println 'Strange 'result))
-> NIL
: (unless (= 3 4) (println 'Strange 'result))
Strange result
-> result




(until 'any . prg) -> any


Conditional loop: While the condition any evaluates to
NIL, prg is repeatedly executed. If prg
is never executed, NIL is returned. Otherwise the result of
prg is returned. See also while, for, loop and do.


: (until (=T (setq N (read)))
   (println 'square (* N N)) )
4
square 16
9
square 81
T
-> 81




(untrace 'sym) -> sym


(untrace 'sym 'cls) -> sym


(untrace '(sym . cls)) -> sym


(Debug mode only) Removes the $ trace
function call at the beginning of the function or method body of
sym, so that no more trace information will be printed before and
after execution. Built-in functions (SUBRs) are automatically converted to their
original form (see subr). See also
trace and traceAll.


: (trace '+)                           # Trace the '+' function
-> +
: +
-> (@ ($ + @ (pass $385455126)))       # Modified for tracing
: (untrace '+)                         # Untrace '+'
-> +
: +
-> 67319120                            # Back to original form




(up [cnt] sym ['val]) -> any


Looks up (or modifies) the cnt'th previously saved value of
sym in the corresponding enclosing environment. If cnt
is not given, 1 is used. It is allowed to omit the sym argument,
then the corresponding expression (function or method call) is returned. See
also eval, run, trail and env.


: (let N 1 ((quote (N) (println N (up N))) 2))
2 1
-> 1
: (let N 1 ((quote (N) (println N (up N) (up N 7))) 2) N)
2 1 7
-> 7

: (de foo (N)
   (println (up))
   (inc N) )
-> foo
: (foo 7)
(foo 7)
-> 8




(upd sym ..) -> lst


Synchronizes the internal state of all passed (external) symbols by passing
them to wipe. upd is the
standard function passed to commit
during database transactions.


(commit 'upd)  # Commit changes, informing all sister processes




(upp? 'any) -> sym | NIL


Returns any when the argument is a string (symbol) that starts
with an uppercase character. See also uppc and low?


: (upp? "A")
-> "A"
: (upp? "a")
-> NIL
: (upp? 123)
-> NIL
: (upp? ".")
-> NIL




(uppc 'any) -> any


Upper case conversion: If any is not a symbol, it is returned
as it is. Otherwise, a new transient symbol with all characters of
any, converted to upper case, is returned. See also lowc, fold and upp?.


: (uppc 123)
-> 123
: (uppc "abc")
-> "ABC"
: (uppc 'car)
-> "CAR"




(use sym . prg) -> any


(use (sym ..) . prg) -> any


Defines local variables. The value of the symbol sym - or the
values of the symbols sym in the list of the second form - are
saved, prg is executed, then the symbols are restored to their
original values. During execution of prg, the values of the symbols
can be temporarily modified. The return value is the result of prg.
See also bind, job and let.


: (setq  X 123  Y 456)
-> 456
: (use (X Y) (setq  X 3  Y 4) (* X Y))
-> 12
: X
-> 123
: Y
-> 456




(useKey 'sym 'cls ['hook]) -> num


Generates or reuses a key for a database tree, by randomly trying to locate
a free number. See also genKey.


: (maxKey (tree 'nr '+Item))
-> 8
: (useKey 'nr '+Item)
-> 12




(usec ['flg]) -> num


Returns a number of microseconds. If flg is
non-NIL, the microsecond fraction of the last call to time is returned, otherwise the number of
microseconds since interpreter startup. See also date.


: (usec)
-> 1154702479219050
: (list (date (date)) (time (time T)) (usec T))
-> ((2013 1 4) (10 12 39) 483321)







================================================
FILE: doc/refV.html
================================================
V
V



(val 'var) -> any


Returns the current value of var. See also setq, set and def.


: (setq L '(a b c))
-> (a b c)
: (val 'L)
-> (a b c)
: (val (cdr L))
-> b




val/3


(Deprecated since version 25.5.30) Pilog predicate that returns the value of an
object's attribute. Typically used in database queries. The first
argument is a Pilog variable to bind the value, the second is the
object, and the third and following arguments are used to apply the
get algorithm to that object.
See also db/3 and select/3.


: (?
   (db nr +Item (2 . 5) @Item)   # Fetch articles 2 through 5
   (val @Nm @Item nm)            # Get item description
   (val @Sup @Item sup nm) )     # and supplier's name
 @Item={B2} @Nm="Spare Part" @Sup="Seven Oaks Ltd."
 @Item={B3} @Nm="Auxiliary Construction" @Sup="Active Parts Inc."
 @Item={B4} @Nm="Enhancement Additive" @Sup="Seven Oaks Ltd."
 @Item={B5} @Nm="Metal Fittings" @Sup="Active Parts Inc."
-> NIL




(var sym . any) -> any


(var (sym . cls) . any) -> any


Defines a class variable sym with the initial value
any for the current class, implicitly given by the value of the
global variable *Class, or - in the
second form - for the explicitly given class cls. See also OO Concepts, rel and var:.


: (class +A)
-> +A
: (var a . 1)
-> 1
: (var b . 2)
-> 2
: (show '+A)
+A NIL
   b 2
   a 1
-> +A




(var: sym) -> any


Fetches the value of a class variable sym for the current
object This, by searching the property
lists of its class(es) and superclasses. See also OO
Concepts, var, with, meta, :,
=: and ::.


: (class +A)
-> +A
: (var a . 1)
-> 1
: (var b . 2)
-> 2
: (object 'O '(+A) 'a 9 'b 8)
-> O
: (with 'O (list (: a) (: b) (var: a) (var: b)))
-> (9 8 1 2)




(version ['flg]) -> lst


(version 'lst) -> lst


Prints the current version as a string of dot-separated numbers, and returns
the current version as a list of numbers. When flg is non-NIL,
printing is suppressed. The second form checks for the required version in
lst and throws an error if the current version is too old. See also
*CPU and *OS.


$ pil -version
25.5.8

: (version T)
-> (25 5 8)
: (version)
25.5.8
-> (25 5 8)

: (version (25 5 9))
!? (version (25 5 9))
(25 5 8) -- Inadequate PicoLisp version
?




(vi 'sym) -> sym | NIL


(vi 'sym 'cls) -> sym | NIL


(vi 'lst) -> lst | NIL


(v . lst) -> lst | NIL


(v) -> NIL


(Debug mode only) Opens the Vip editor on the function or method definition
of sym (source file or direct path name), or on a list of symbols
lst (in-memory). (v) resumes a Vip session suspended
with "qz". See also doc, *Dbg, debug and pp.


: (vi 'put> '+Entity)  # Edit the method's source code
: (v {1})  # In-memory-edit the database root object
-> put>




(view 'lst ['T]) -> any


Views lst as tree-structured ASCII graphics. When the
T argument is given, lst should be a binary tree
structure (as generated by idx), which
is then shown as a left-rotated tree. See also pretty and show.


: (balance 'I '(a b c d e f g h i j k l m n o))
-> NIL
: I
-> (h (d (b (a) c) f (e) g) l (j (i) k) n (m) o)

: (view I)
+-- h
|
+---+-- d
|   |
|   +---+-- b
|   |   |
|   |   +---+-- a
|   |   |
|   |   +-- c
|   |
|   +-- f
|   |
|   +---+-- e
|   |
|   +-- g
|
+-- l
|
+---+-- j
|   |
|   +---+-- i
|   |
|   +-- k
|
+-- n
|
+---+-- m
|
+-- o
-> NIL

: (view I T)
         o
      n
         m
   l
         k
      j
         i
h
         g
      f
         e
   d
         c
      b
         a
-> NIL







================================================
FILE: doc/refW.html
================================================
W
W



*Winch


Global variable holding a (possibly empty) prg body, which will
be executed when a SIGWINCH signal is sent to the current process. See also
alarm, sigio, *Hup, *Sig[12], *TStp[12] and *Term.


: (de *Winch (msg 'SIGWINCH))
-> *Winch




(wait 'cnt|NIL . prg) -> any


(wait 'cnt|NIL T 'fd) -> fd|NIL


Waits for a condition. While the result of the execution of prg
is NIL (first form), or no input is available for the file
descriptor in fd (second form), a poll(2) system call
is executed for all file descriptors and timers in the VAL of the
global variable *Run. When
cnt is non-NIL, the waiting time is limited to
cnt milliseconds. Returns the result of prg. See also
key and sync.


: (wait 2000)                                # Wait 2 seconds
-> NIL
: (prog
   (zero *Cnt)
   (setq *Run                                # Install background loop
      '((-2000 0 (println (inc '*Cnt)))) )   # Increment '*Cnt' every 2 sec
   (wait NIL (> *Cnt 6))                     # Wait until > 6
   (off *Run) )
1                                            # Waiting ..
2
3
4
5
6
7
-> NIL




(week 'dat) -> num


Returns the number of the week for a given date dat. See also day, ultimo, datStr and strDat.


: (datStr (date))
-> "2007-06-01"
: (week (date))
-> 22




(when 'any . prg) -> any


Conditional execution: When the condition any evaluates to
non-NIL, prg is executed and the result is returned.
Otherwise NIL is returned. See also unless, if, and
and cond.


: (when (> 4 3) (println 'OK) (println 'Good))
OK
Good
-> Good




(while 'any . prg) -> any


Conditional loop: While the condition any evaluates to
non-NIL, prg is repeatedly executed. If
prg is never executed, NIL is returned. Otherwise the
result of prg is returned. See also until, for, loop and do.


: (while (read)
   (println 'got: @) )
abc
got: abc
1234
got: 1234
NIL
-> 1234




(what 'sym) -> lst


(Debug mode only) Returns a list of all internal symbols that match the
pattern string sym. See also match, who, has and can.


: (what "cd@dr")
-> (cdaddr cdaadr cddr cddddr cdddr cddadr cdadr)




(who 'any) -> lst


(Debug mode only) Returns a list of all functions or method definitions that
contain the atom or pattern any. See also match, what, has and can.


: (who 'caddr)                         # Who is using 'caddr'?
-> ($dat lint1 expDat datStr $tim tim$ mail _gen dat$ datSym)

: (who "Type error")
-> ((mis> . +Link) *Uni (mis> . +Joint))

: (more (who "Type error") pp)         # Pretty print all results
(dm (mis> . +Link) (Val Obj)
   (and
      Val
      (nor (isa (: type) Val) (canQuery Val))
      "Type error" ) )
.                                      # Stop
-> T




(wipe 'sym|lst) -> sym|lst


Clears the VAL and the property list of sym, or of
all symbols in the list lst. When a symbol is an external symbol,
its state is also set to "not loaded". Does nothing when sym is an
external symbol that has been modified or deleted ("dirty").


: (setq A (1 2 3 4))
-> (1 2 3 4)
: (put 'A 'a 1)
-> 1
: (put 'A 'b 2)
-> 2
: (show 'A)
A (1 2 3 4)
   b 2
   a 1
-> A
: (wipe 'A)
-> A
: (show 'A)
A NIL
-> A




(with 'any . prg) -> any


Saves the current object This and sets it to the new value
any. Then prg is executed, and
This is restored to its previous value. The return value is
the result of prg. Used typically to access the local data
of var in the same manner as inside a method body.
prg is not executed (and NIL is returned) when
var is NIL. (with 'X . prg) is
equivalent to (let? This 'X . prg). See also this.


: (put 'X 'a 1)
-> 1
: (put 'X 'b 2)
-> 2
: (with 'X (list (: a) (: b)))
-> (1 2)




(wr 'cnt ..) -> cnt


Writes all cnt arguments as raw bytes to the current output
channel. See also rd and pr.


: (out "x" (wr 1 255 257))  # Write to "x"
-> 257
: (hd "x")
00000000  01 FF 01                                         ...
-> NIL




(wrap 'cnt 'lst) -> sym


(wrap 'cnt 'sym) -> lst


The first form returns a transient symbol with all characters in
lst packed in lines with
a maximal length of cnt. The second form converts a symbol to a
list of transient symbols each with a maximal length of cnt. See
also tab, align and center.


: (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"
: (wrap 8 "The quick brown fox jumps over the lazy dog")
-> ("The" "quick" "brown" "fox" "jumps" "over the" "lazy dog")







================================================
FILE: doc/refX.html
================================================
X
X



(xchg 'var 'var ..) -> any


Exchange the values of successive var argument pairs. See also
swap and set.


: (setq  A 1  B 2  C '(a b c))
-> (a b c)
: (xchg  'A C  'B (cdr C))
-> 2
: A
-> a
: B
-> b
: C
-> (1 2 c)




(xor 'any 'any) -> flg


Returns T if exactly one of the arguments evaluates to non-NIL.


: (xor T NIL)
-> T
: (xor T T)
-> NIL




(x| 'num ..) -> num


Returns the bitwise XOR of all num arguments. When
one of the arguments evaluates to NIL, it is returned immediately.
See also &, | and bit?.


: (x| 2 7)
-> 5
: (x| 2 7 1)
-> 4







================================================
FILE: doc/refY.html
================================================
Y
Y



(yield 'any ['any2] [. prg]) -> any


Transfers control from the current coroutine back to the caller (when the
any2 tag is not given), or to some other coroutine
(specified by any2) to continue execution at the point
where that coroutine had called yield before. In the first
case, the value any will be returned from the corresponding
co call, in the second case it
will be the return value of that yield call. If
prg is given, it is executed in the destination environment
before the coroutine resumes execution. See also stack, catch and throw.


: (co "rt1"                            # Start first routine
   (msg (yield 1) " in rt1 from rt2")  # Return '1', wait for value from "rt2"
   7 )                                 # Then return '7'
-> 1

: (co "rt2"                            # Start second routine
   (yield 2 "rt1") )                   # Send '2' to "rt1"
2 in rt1 from rt2
-> 7

: (co 'a (let N 0 (loop (yield (inc 'N)))))  # Incrementing coroutine
-> 1
: (co 'a T)                            # Next value
-> 2
: (yield NIL 'a (println N))           # Print value, then increment
2
-> 3
: (yield NIL 'a (println N))
3
-> 4
: (yield NIL 'a (yield N))             # Immediately yield back
-> 4                                   # Can be used to inspect a value
: (yield NIL 'a (yield N))             # in another coroutine
-> 4
: (co 'a T)                            # Next value
-> 5
: (yield NIL 'a (yield (env)))         # Return the whole environment




(yoke 'any ..) -> any


Inserts one or several new elements any in front of the list in
the current make environment.
yoke returns the last inserted argument. See also link, chain and made.


: (make (link 2 3) (yoke 1) (link 4))
-> (1 2 3 4)







================================================
FILE: doc/refZ.html
================================================
Z
Z



*Zap


A global variable holding a list and a pathname. If given, and the value of
*Solo is NIL, external
symbols which are no longer accessible can be collected in the CAR, e.g. during
DB tree processing, and written to the file in the CDR at the next commit. A (typically periodic) call to
zap_ will clean them up later.


: (setq *Zap '(NIL . "db/app/_zap"))
-> (NIL . "db/app/_zap")




(zap 'sym) -> sym


"Delete" the symbol sym. For internal symbols, that means to
remove it from the current namespace, effectively transforming it to a transient
symbol. For external symbols, it means to mark it as "deleted", so that upon a
later commit it will be removed from
the database file. See also intern.


: (de foo (Lst) (car Lst))          # 'foo' calls 'car'
-> foo
: (zap 'car)                        # Delete the symbol 'car'
-> "car"
: (pp 'foo)
(de foo (Lst)
   ("car" Lst) )                    # 'car' is now a transient symbol
-> foo
: (foo (1 2 3))                     # 'foo' still works
-> 1
: (car (1 2 3))                     # Reader returns a new 'car' symbol
!? (car (1 2 3))
car -- Undefined
?




(zapTree 'sym)


Recursively deletes a tree structure from the database. See also tree, chkTree and prune.


: (zapTree (cdr (root (tree 'nm '+Item))))




(zap_)


Delayed deletion (with zap) of
external symbols which were collected e.g. during DB tree processing. An
auxiliary file (with the name taken from the CDR of the value of *Zap, concatenated with a "_"
character) is used as an intermediary file.


: *Zap
-> (NIL . "db/app/Z")
: (call 'ls "-l" "db/app")
...
-rw-r--r-- 1 abu abu     1536 2007-06-23 12:34 Z
-rw-r--r-- 1 abu abu     1280 2007-05-23 12:15 Z_
...
: (zap_)
...
: (call 'ls "-l" "db/app")
...
-rw-r--r-- 1 abu abu     1536 2007-06-23 12:34 Z_
...




(zero var ..) -> 0


Stores 0 in all var arguments. See also one, on,
off and onOff.


: (zero A B)
-> 0
: A
-> 0
: B
-> 0







================================================
FILE: doc/ref_.html
================================================
Other
Other



(! . exe) -> any


Low level breakpoint function: The current execution environment is saved
and the I/O channels are redirected to the console. Then exe is
displayed, and a read-eval-print-loop is entered (with ! as its
prompt character), to evaluate expressions and examine the current program
environment. An empty input line terminates the read-eval-print-loop, the
environment and I/O channels are restored, and the result of exe is
returned. ! is normally inserted into existing programs with the
debug function. See also !!, e,
^ and *Dbg.


: (de foo (N) (and (println 1) (! println N) (println 2)))
-> foo
: (foo 7)
1                 # Executed '(println 1)'
(println N)       # Entered breakpoint
! N               # Examine the value of 'N'
-> 7
! (e)             # Evaluate '^', i.e. (println N)
7
-> 7
! (e @)           # Evaluate '@' -> the result of '(println 1)'
-> 1
!                 # Empty line: continue
7                 # Executed '(println N)'
2                 # Executed '(println 2)'
-> 2




(!! 'any . exe) -> any


Conditional low level breakpoint function. Behaves as !, but stops only if any evaluates to
non-NIL.


: (for N 7 (!! (= 4 N) println N))
1
2
3
(println N)
! N
-> 4
!
4
5
6
7
-> 7




($ sym|lst lst . prg) -> any


Low level trace function: The first argument sym|lst is printed
to the console with a proper indentation, followed by a colon :. If
a function is traced, the first argument is the function symbol, else if a
method is traced, it is a cons pair of message and class. The second argument
lst should be a list of symbols, identical to the function's
argument list. The current values of these symbols are printed, followed by a
newline. Then prg is executed, and its return value printed in a
similar way (this time with an equals sign = instead of a colon)
and returned. $ is normally inserted into existing programs with
the trace function.


: (de foo (A B) ($ foo (A B) (* A B)))
-> foo
: (foo 3 4)
 foo : 3 4        # Function entry, arguments 3 and 4
 foo = 12         # Function exit, return value 12
-> 12




($dat 'sym1 ['sym2]) -> dat


Converts a string sym1 in ISO format to a date, optionally using a delimiter character
sym2. See also dat$,
$tim, strDat and expDat.


: ($dat "20070601")
-> 733134
: ($dat "2007-06-01" "-")
-> 733134




($tim 'sym) -> tim


Converts a string to a time. The
minutes and seconds are optional and default to zero. See also tim$ and $dat.


: (time ($tim "10:57:56"))
-> (10 57 56)
: (time ($tim "10:57"))
-> (10 57 0)
: (time ($tim "10"))
-> (10 0 0)




(% 'num ..) -> num


Returns the remainder from the divisions of successive num
arguments. The sign of the result is that of the first argument. When one of the
arguments evaluates to NIL, it is returned immediately. See also
/ and */ .


: (% 17 5)
-> 2
: (% -17 5)  # Sign is that of the first argument
-> -2
: (% 5 2)
-> 1
: (% 15 10)
-> 5
: (% 15 10 2)  # (% 15 10) -> 5, then (% 5 2) -> 1
-> 1




(%@ 'cnt|sym 'any 'any ..) -> any


Convenience function for a common use case of native. (%@ "fun" ...) is
equivalent to (native "@" "fun" ...).


: (%@ "getenv" 'S "TERM")  # Same as (sys "TERM")
-> "xterm"
: (%@ "symlink" 'I "file" "link")
-> 0
: (%@ "isatty" 'I 0)
-> 1
: (round (%@ "cos" 1.0  3.1415926535897932))
-> "1.000"
: (use Tim
   (%@ "time" NIL '(Tim (8 B . 8)))  # time_t 8   # Get time_t structure
   (%@ "localtime" '(I . 9) (cons NIL (8) Tim)) ) # Read local time
-> (43 19 14 6 10 120 5 310 0)  # 14:19:43, Nov 6th, 2020




(& 'num ..) -> num


Returns the bitwise AND of all num arguments. When
one of the arguments evaluates to NIL, it is returned immediately.
See also |, x| and bit?.


: (& 6 3)
-> 2
: (& 7 3 1)
-> 1




(* 'num ..) -> num


Returns the product of all num arguments. When one of the
arguments evaluates to NIL, it is returned immediately. See also
/, */, + and
-.


: (* 1 2 3)
-> 6
: (* 5 3 2 2)
-> 60




(** 'num1 'num2) -> num


Integer exponentiation: Returns num1 to the power of
num2.


: (** 2 3)
-> 8
: (** 100 100)
-> 10000000000000000000000000000000000000000000000000000000000000000000000000000
00000000000000000000000000000000000000000000000000000000000000000000000000000000
00000000000000000000000000000000000000000000




(*/ 'num1 ['num2 ..] 'num3) -> num


Returns the product of num1 and all following num2
arguments, divided by the num3 argument. The result is rounded to
the nearest integer value. When one of the arguments evaluates to
NIL, it is returned immediately. Note that */ is
especially useful for fixed point arithmetic, by multiplying with (or dividing
by) the scale factor. See also *,
/, +, - and
sqrt.


: (*/ 3 4 2)
-> 6
: (*/ 1234 2 10)
-> 247
: (*/ 100 6)
-> 17

: (scl 2)
-> 2  # 0.02
: (format (*/ 3.0 1.5 1.0) *Scl)
-> "4.50"

: (scl 20)
-> 20  # 0.00000000000000000020
: (format (*/ 9.9 9.789 9.56789 `(sq 1.0)) *Scl)
-> "927.23474457900000000000"





(+ 'num ..) -> num


Returns the sum of all num arguments. When one of the arguments
evaluates to NIL, it is returned immediately. See also inc, -,
*, / and */.


: (+ 1 2 3)
-> 6




(++ var) -> any


Pops the first element (CAR) from the stack in var. (++
Lst) is equivalent to (pop 'Lst). See also pop.





(- 'num ..) -> num


Returns the difference of the first num argument and all
following arguments. If only a single argument is given, it is negated. When one
of the arguments evaluates to NIL, it is returned immediately. See
also dec, +, *,
/ and */.


: (- 7)
-> -7
: (- 7 2 1)
-> 4




(-> any [cnt]) -> any


Searches for the value of any (typically a Pilog variable, or an expression of variables) at top
level (or level cnt) in the current environment. See also prove and unify.


: (? (append (1 2 3) (4 5 6) @X) (^ @ (println 'X '= (-> @X))))
X = (1 2 3 4 5 6)
 @X=(1 2 3 4 5 6)
-> NIL




(/ 'num ..) -> num


Returns the first num argument successively divided by all
following arguments. When one of the arguments evaluates to NIL, it
is returned immediately. See also *,
*/, %, + and
-.


: (/ 12 3)
-> 4
: (/ 60 -3 2 2)
-> -5




(: sym|0 [sym1|cnt ..]) -> any


Fetches a value any from the properties (or value) of a symbol,
or from a list, by applying the get
algorithm to This and the following arguments. Used typically in
methods or with bodies. (:
..) is equivalent to (; This ..). See also ;, =: and
::.


: (put 'X 'a 1)
-> 1
: (with 'X (: a))
-> 1




(:: sym [sym1|cnt .. sym2]) -> var


Fetches a property for a property key sym or sym2
from a symbol. That symbol is This (if no other arguments are
given), or a symbol found by applying the get algorithm to This and the
following arguments. The property (the cons pair, not just its value) is
returned, suitable for direct (destructive) manipulations with functions
expecting a var argument. Used typically in methods or with bodies. See also =:, prop and :.


: (with 'X (=: cnt 0) (inc (:: cnt)) (: cnt))
-> 1




(; 'sym1|lst [sym2|cnt ..]) -> any


Fetches a value any from the properties of a symbol, or from a
list, by applying the get algorithm to
sym1|lst and the following arguments. See also :, =: and
::.


: (put 'A 'a 1)
-> 1
: (put 'A 'b 'B)
-> B
: (put 'B 'c 7)
-> 7
: (; 'A a)
-> 1
: (; 'A b c)
-> 7




(< 'any ..) -> flg


Returns T when all arguments any are in strictly
increasing order. See also Comparing.


: (< 3 4)
-> T
: (< 'a 'b 'c)
-> T
: (< 999 'a)
-> T




(<= 'any ..) -> flg


Returns T when all arguments any are in strictly
non-decreasing order. See also Comparing.


: (<= 3 3)
-> T
: (<= 1 2 3)
-> T
: (<= "abc" "abc" "def")
-> T




(<> 'any ..) -> flg


Returns T when not all any arguments are equal
(structure equality). (<> 'any ..) is equivalent to
(not (= 'any ..)). See also Comparing.


: (<> 'a 'b)
-> T
: (<> 'a 'b 'b)
-> T
: (<> 'a 'a 'a)
-> NIL




(= 'any ..) -> flg


Returns T when all any arguments are equal
(structure equality). See also Comparing.


: (= 6 (* 1 2 3))
-> T
: (= "a" "a")
-> T
: (== "a" "a")
-> T
: (= (1 (2) 3) (1 (2) 3))
-> T




(=0 'any) -> 0 | NIL


Returns 0 when any is a number with value zero.
See also n0, lt0, le0, ge0, gt0 and =1.


: (=0 (- 6 3 2 1))
-> 0
: (=0 'a)
-> NIL




(=1 'any) -> 1 | NIL


Returns 1 when any is a number with value one.
See also =0.


: (=1 (- 6 3 2))
-> 1
: (=1 'a)
-> NIL




(=: sym|0 [sym1|cnt ..] 'any) -> any


Stores a new value any for a property key (or in the symbol
value for zero) in a symbol, or in a list. That symbol is This (if
no other arguments are given), or a symbol found by applying the get algorithm to This and the
following arguments. If the final destination is a list, the value is stored in
the CDR of an asoqed element (if the
key argument is a symbol), or the n'th element (if the key is a number). Used
typically in methods or with bodies.
See also put, : and ::.


: (with 'X (=: a 1) (=: b 2))
-> 2
: (get 'X 'a)
-> 1
: (get 'X 'b)
-> 2




(== 'any ..) -> flg


Returns T when all any arguments are the same
(pointer equality). See also n== and Comparing.


: (== 'a 'a)
-> T
: (== 'NIL NIL (val NIL) (car NIL) (cdr NIL))
-> T
: (== (1 2 3) (1 2 3))
-> NIL




(====) -> NIL


Close the current transient scope by clearing the transient index. All
transient symbols become hidden and inaccessible by the reader.
See also extern and intern.


: (setq S "abc")           # Read "abc"
-> "abc"
: (== S "abc")             # Read again, get the same symbol
-> T
: (====)                   # Close scope
-> NIL
: (== S "abc")             # Read again, get another symbol
-> NIL




(=T 'any) -> flg


Returns T when any is the symbol T.
(=T X) is equivalent to (== T X). See also nT.


: (=T 0)
-> NIL
: (=T "T")
-> NIL
: (=T T)
-> T




(> 'any ..) -> flg


Returns T when all arguments any are in strictly
decreasing order. See also Comparing.


: (> 4 3)
-> T
: (> 'A 999)
-> T




(>= 'any ..) -> flg


Returns T when all arguments any are in strictly
non-increasing order. See also Comparing.


: (>= 'A 999)
-> T
: (>= 3 2 2 1)
-> T




(>> 'cnt 'num) -> num


Shifts right the num argument by cnt
bit-positions. If cnt is negative, a corresponding left shift is
performed. See also rev.


: (>> 1 8)
-> 4
: (>> 3 16)
-> 2
: (>> -3 16)
-> 128
: (>> -1 -16)
-> -32




(? [sym ..] [pat 'any ..] . lst) -> flg


Top-level function for interactive Pilog
queries. ? is a non-evaluating front-end to the query function. It displays each result, waits
for console input, and terminates when ESC is pressed. If a preceding list of
(non-pattern-) symbols is given, they will be taken as rules to be traced by
prove. The list of variable/value
pairs is passed to goal for an initial
Pilog environment. See also pilog and
solve.


: (? (append (a b c) (d e f) @X))
 @X=(a b c d e f)
-> NIL

: (? (append @X @Y (a b c)))
 @X=NIL @Y=(a b c)
 @X=(a) @Y=(b c)
 @X=(a b) @Y=(c)
 @X=(a b c) @Y=NIL
-> NIL

: (? (append @X @Y (a b c)))
 @X=NIL @Y=(a b c)                     # ESC was pressed
-> NIL

: (? append (append @X @Y (a b c)))    # Trace 'append'
1 (append NIL (a b c) (a b c))
 @X=NIL @Y=(a b c)
2 (append (a . @X) @Y (a b c))
1 (append NIL (b c) (b c))
 @X=(a) @Y=(b c).                      # Stopped
-> NIL




@


Holds the result of the last top level expression in the current
read-eval-print loop, or the result of the conditional expression during the
evaluation of flow functions (see @
Result). When @ is used as a formal parameter in lambda expressions, it denotes a variable number of
evaluated arguments.




@@


Holds the result of the second last top level expression in the current
read-eval-print loop (see @ Result).
Some functions store a secondary return value in @@.




@@@


Holds the result of the third last top level expression in the current
read-eval-print loop (see @ Result).




^


Holds the currently executed expression during a breakpoint or an error. See
also debug, !, e and
*Dbg.


: (* (+ 3 4) (/ 7 0))
!? (/ 7 0)
Div/0
? ^
-> (/ 7 0)




(| 'num ..) -> num


Returns the bitwise OR of all num arguments. When
one of the arguments evaluates to NIL, it is returned immediately.
See also x|, & and bit?.


: (| 1 2)
-> 3
: (| 1 2 4 8)
-> 15







================================================
FILE: doc/search
================================================
Search criteria
   Numbers
      3
      (3 . 4)
   Strings
      "abc"
      ("a" . "z")
   Objects
      {2}
   Symbols
      abc
      (a . z)

Relation types
   Number, Date, Time
      (+Key +Number)
         7 {2}

      (+Ref +Number)
         (7 . {2}) {2}

   Keywords
      (+Key +String)
         "Regen Axer" {2}

      (+Ref +String)
         ("Regen Axer" . {2}) {2}

   Phone numbers
      (+Fold +Ref +String)
         ("regenaxer" . {2}) {2}

   E-Mail addresses
      (+Fold +Idx +String)
         ("axer" {2}) {2}
         ("egenaxer" {2}) {2}
         ("enaxer" {2}) {2}
         ("genaxer" {2}) {2}
         ("naxer" {2}) {2}
         ("regenaxer" . {2}) {2}
         ("xer" {2}) {2}

   Personal names
      (+Sn +IdxFold +String)
         ("RSNSR" {2} . T) {2}
         ("Regen Axer" . {2}) {2}
         ("axer" {2}) {2}
         ("egen" {2}) {2}
         ("gen" {2}) {2}
         ("regenaxer" {2}) {2}
         ("xer" {2}) {2}

   Item names
      (+IdxFold +String)
         ("Regen Axer" . {2}) {2}
         ("axer" {2}) {2}
         ("egen" {2}) {2}
         ("gen" {2}) {2}
         ("regenaxer" {2}) {2}
         ("xer" {2}) {2}

      (+List +Fold +Ref +String)
         ("axer" . {2}) {2}
         ("regen" . {2}) {2}

   Identifiers
      (+Idx +String)
         ("Axer" {2}) {2}
         ("Regen Axer" . {2}) {2}
         ("egen" {2}) {2}
         ("gen" {2}) {2}
         ("xer" {2}) {2}

   GIS coordinates
      (+UB +Aux +Ref +Number)
         (56919522950766600 . {2}) {2}

   Objects
      (+Ref +Link)
         ({7} . {2}) {2}


================================================
FILE: doc/search.html
================================================
The 'search' Functionabu@software-lab.de
The 'search' Function
(c) Software Lab. Alexander Burger


The search function allows to search the database for a combination of search criteria.


It finds all objects - directly from the criteria or after traversing all
associations - which fulfill all given search criteria, and returns them
one at a time.


Examples
The examples in this document will use the demo application in "app/*.l" (in
demoApp.tgz).


To get an interactive prompt, start it as:


$ pil app/main.l -main +
:

As ever, you can terminate the interpreter by hitting Ctrl-D.



Syntax
search is called in two different forms.


The first form initializes a query. It takes two or more arguments, and
returns a query structure (a list).


The second form can then be called repeatedly with that structure, and will
subsequently return the next resulting object, or NIL if no more
results can be found.


To start a new query, search is called with an arbitrary number
of argument pairs, each consisting of a search criterion and a list of relation
specifications, and an optional extraction function which filters and possibly
modifies the results.


For example, to find the item with the number 2:


ap: (search 2 '((nr +Item)))
-> (NIL ...

The first argument 2 is a search criterion (the key to
look for), and ((nr +Item)) is a list with a single relation
specification (the nr index of the +Item class).


The returned query structure is abbreviated here, because it is big and not
relevant. It can now be used to fetch the result:


ap: (search @)
-> {B2}
ap: (show @)
{B2} (+Item)
   nr 2
   pr 1250
   inv 100
   sup {C2}
   nm "Spare Part"
-> {B2}

There are no further results, because nr is a unique key:


ap: (search @@@)  # '@@@' refers to the third-last REPL result, the query
-> NIL

Search Criteria
Each criterion is an attribute of a database object (like name, e-mail,
address etc.), or some given database object. It may be used to find objects
directly, or as a starting point for a recursive search for other objects
reachable by this object.


For every search criterion which is NIL, no search is performed,
and the following relation specification is ignored. If, however, all
search criteria are NIL, a full search over the last relation
specification is forced.



Numbers
If the search criterion is numeric (including derived types like date or
time), it can be atomic for an exact search, or a cons pair for searching a
range of numbers.


Extending the above example, we may search for all items with a number
between 2 and (including) 6:


ap: (search (2 . 6) '((nr +Item)))
-> (NIL ...

We may use a for loop to retrieve all results:


ap: (for
   (Q
      (search (2 . 6) '((nr +Item)))
      (search Q) )
   (printsp @) )
{B2} {B3} {B4} {B5} {B6}

Strings
If the search criterion is a string (transient symbol) or an internal symbol,
or a cons pair of those, the exact behavior depends on the relation type. It
includes all cases where it matches the heads of the result attributes (string
prefixes), but may also match substrings and/or tolerant (folded or soundex-encoded) searches.


ap: (for
   (Q
      (search "Api" '((em +CuSu)))
      (search Q) )
   (println (; @ em)) )
"info@api.tld"

ap: (for
   (Q
      (search "part" '((nm +Item)))
      (search Q) )
   (with @
      (println (: nr) (: nm)) ) )
1 "Main Part"
2 "Spare Part"

Or, combined with a number range search:


ap: (for
   (Q
      (search
         (2 . 6) '((nr +Item))
         "part" '((nm +Item)) )
      (search Q) )
   (with @
      (println (: nr) (: nm)) ) )
2 "Spare Part"

Objects
A database object can also be used as a search criterion. A cons pair (i.e. a
range) of objects makes no sense, because objects by themselves are not ordered.


Searching for all items from a given supplier:


ap: (for
   (Q
      (search '{C1} '((sup +Item)))
      (search Q) )
   (printsp @) )
{B1} {B3} {B5}

or for all positions in a given order:


ap: (for
   (Q
      (search '{B7} '((ord . pos)))
      (search Q) )
   (printsp @) )
{A1} {A2} {A4} {A3} ...

Relation Specifications
Every second argument to search is a list of relation
specifications. In typical use cases, a relation specification is either


    

  • a list (var cls [hook]) for an index relation, or

  •  a cons pair (sym . sym) for a +Joint relation

For general cases, the first specification in the list may be replaced
by two custom functions: A generator function and a filter function. This allows
to start the search from arbitrary resources like remote databases or
coroutines.


If a specification is (var cls) but var is not an
index of cls, a brute force search through the objects in the
database file of cls will be performed. This should only be done
for small files with ideally all objects of type cls.


The rest of the list contains associations (which are also relation
specifications) to recursively search through associated objects. They are
typically (+Joint), (+List +Joint),
or (+Ref +Link) relations.


Look for example at the choOrd ("choose Order") function in the
demo application. You can access it directly in the REPL with (vi
'choOrd). The search call is


(search
   *OrdCus '((nm +CuSu) (cus +Ord))
   *OrdOrt '((ort +CuSu) (cus +Ord))
   *OrdItem '((nm +Item) (itm +Pos) (pos . ord))
   *OrdSup '((nm +CuSu) (sup +Item) (itm +Pos) (pos . ord))
   (and *OrdNr (cons @)) '((nr +Ord))
   (and *OrdDat (cons @)) '((dat +Ord)) )

The global variables *OrdCus through *OrdDat hold
the search criteria from the search fields in the dialog GUI.


The line with the longest chain of associations is:


   *OrdSup '((nm +CuSu) (sup +Item) (itm +Pos) (pos . ord))

This means:


    

  1. Search suppliers by name

  2. For each matching supplier, go through his items

  3. For each item, find order positions where it is referred

  4. For each position, return the order where it is in

Testing this line stand-alone, searching orders only by supplier name:


ap: (for
   (Q
      (search
         "Seven Oaks"
         (quote
            (nm +CuSu)
            (sup +Item)
            (itm +Pos)
            (pos . ord) ) )
      (search Q) )
   (printsp @) )
{B7}

Custom Generators and Filters
If the list of relation specifications does not start with an index relation
(var cls) or a joint relation (sym . sym), but instead
with a function like ((X) (foo)), the first two elements of
the list are taken as generator and filter functions, respectively.


We could rewrite the last example in a slightly simplified form, but with
custom functions:


ap: (for
   (Q
      (search
         "Seven Oaks"
         (quote
            ((X)  # Generator function
               (iter> (meta '(+CuSu) 'nm)
                  "Seven Oaks"
                  '(nm +CuSu) ) )
            ((This X)  # Filter function
               (pre? "Seven Oaks" (: nm)) )
            (sup +Item)
            (itm +Pos)
            (pos . ord) ) )
      (search Q) )
   (printsp @) )
{B7}

The iter> method implements the mechanisms to produce the
internal query structures for individual relations. There is a convenience
function relQ for this. It can be used to simplify such standard
generators. Instead of:


   ((X)  # Generator function
      (iter> (meta '(+CuSu) 'nm)
         "Seven Oaks"
         '(nm +CuSu) ) )

we can write:


   ((X)  # Generator function
      (relQ "Seven Oaks" '(nm +CuSu)) )

Multiple Indexes
While relQ is normally not used directly by application
programs, because its functionality is provided by the standard relation
specification syntax, there is a function relQs which is indeed
useful.


relQs produces proper generator and filter functions which can
search multiple indexes for a singe search criterion.


The general syntax is:


   (relQs '((var1 +Cls1) (var2 +Cls2) ..) (sym1 ..) (sym2 ..)..)

to search first the index (var1 +Cls1), then (var2
+Cls2) etc., and then follow the optional associations (sym1
..), (sym2 ..) etc.


A typical use case is searching for a telephone number in both the landline
and mobile attributes. You find an example in the choCuSu ("choose
Customer/Supplier") function in the demo application, in the line:


   *CuSuTel (relQs '((tel +CuSu) (mob +CuSu)))

Note that (relQs ..) must not be quoted, because it needs
to be evaluate to produce the right functions and query structure.



Extraction Function
Sometimes it is necessary to to do further checks on a search result, which
may not be covered by the standard matching of combined search criteria.


An example can be found in the tut.tgz tutorial in the file
"db/family.l", in the contemporaries report. It searches for people
living roughly at the same time as the given person:


   '(let @Fin
      (or
         (: home obj fin)
         (+ (: home obj dat) 36525) )
      (search
         (cons (- (: home obj dat) 36525) @Fin) '((dat +Person))
         (curry (@Fin) (Obj)
            (and
               (n== Obj (: home obj))
               (>= (; Obj fin) (: home obj dat))
               (>= @Fin (; Obj dat))
               Obj ) ) ) )

@Fin is set to either the date when the given person died, or to
the birth date plus ten years if not known. Then all persons born in the range
of ten years before the given person and @Fin are searched.


curry builds the filter function, taking an
object and doing range checks to see if that person died after the given person
was born, and that he or she was born before @Fin.


If those conditions are not met, the function returns NIL, and
search continues to search for the next result.


The extraction function may also - instead of returning the object or
NIL, return some other value as appropriate for the application.



Sorting
In general, the values returned by search are not sorted when
multiple search criteria are given. This is because the indexes are iterated
over in an unpredictable order.


If, however, only a single search criterion is given, or only one of the
search criteria is non-NIL, then the results will be returned in
sorted order according to the given index.


If all search criteria are NIL, and thus the last
relation specification is used (see above under Search
Criteria), then the results will turn up in increasing order.





================================================
FILE: doc/select.html
================================================






The 'select' Predicate



abu@software-lab.de


The 'select' Predicate
(c) Software Lab. Alexander Burger


Note: 'select' and related database Pilog predicates are deprecated since
version 25.5.30, and moved to a separate "@lib/select.l" file! New applications
should use search instead (see search.html).


The Pilog select/3 predicate is rather complex, and quite
different from other predicates. This document tries to explain it in detail,
and shows some typical use cases.


Syntax
select takes at least three arguments:


    

  • A list of unification variables,

  • a list of generator clauses

  • and an arbitrary number of filter clauses

We will describe these arguments in the following, but demonstrate them first
on a concrete example.



First Example
The examples in this document will use the demo application in "app/*.l" (in
demoApp.tgz). To get an
interactive prompt, start it as


$ pil app/main.l -ap~main +
:

As ever, you can terminate the interpreter by hitting Ctrl-D.


For a first, typical example, let's write a complete call to solve that returns a list of articles with numbers
between 1 and 4, which contain "Part" in their description, and have a price
less than 100:


(let (Nr (1 . 4)  Nm "Part"  Pr '(NIL . 100.00))
   (solve
      (quote
         @Nr Nr
         @Nm Nm
         @Pr Pr
         (select (@Item)
            ((nr +Item @Nr) (nm +Item @Nm) (pr +Item @Pr))
               (range @Nr @Item nr)
               (part @Nm @Item nm)
               (range @Pr @Item pr) ) )
      @Item ) )

This expression will return, with the default database setup of "app/init.l",
a list of exactly one item ({B2}), the item with the number 2.


The let statement assigns values to
the search parameters for number Nr, description Nm
and price Pr. The Pilog query (the first argument to
solve) passes these values to the Pilog variables @Nr,
@Nm and @Pr. Ranges of values are always specified by
cons pairs, so (1 . 4) includes the numbers 1 through 4, while
(NIL . 100.00) includes prices from minus infinite up to one
hundred.


The list of unification variables is


   (@Item)

The list of generator clauses is


      ((nr +Item @Nr) (nm +Item @Nm) (pr +Item @Pr))

The filter clauses are


         (range @Nr @Item nr)
         (part @Nm @Item nm)
         (range @Pr @Item pr)

Unification Variables
As stated above, the first argument to select should be a list
of variables. These variables communicate values (via unify) from the select
environment to the enclosing Pilog environment.


The first variable in this list (@Item in the above example) is
mandatory, it takes the direct return value of select. Additional
optional variables may be unified by clauses in the body of select,
and return further values.



Generator Clauses
The second argument to select is a list of "generator clauses".
Each of these clauses specifies some kind of database B-Tree +index, to be traversed by
select, step by step, where each step returns a suitable single
database object. In the simplest case, they consist like here just of a relation
name (e.g. nr), a class (e.g. +Item), an optional hook
specifier (not in this example), and a pattern (values or ranges, e.g. (1 . 4)
or "Part").


The generator clauses are the core of 'select'. In some way, they behave
analog to or/2, as each of them
generates a sequence of values. However, the generator clauses behave different,
as they will not generate an exhaustive set of values upon backtracking, one
after the other, where the next gets its turn when the previous one is
exhausted. Instead, all clauses will generate their values quasi-parallel, with
a built-in optimization so that successful clauses will be called with a higher
probability. "Successful" means that the returned values successfully pass
select's filter clauses.



B-Tree Stepping
In its basic form, a generator clause is equivalent to the db/3 predicate, stepping through a single
B-Tree. The clause


(nr +Item @Nr)

generates the same values as would be produced by a stand-alone Pilog clause


(db nr +Item @Nr @Item)

as can be seen in the following two calls:


: (? (db nr +Item (1 . 4) @Item))
 @Item={B1}
 @Item={B2}
 @Item={B3}
 @Item={B4}
-> NIL
: (? (select (@Item) ((nr +Item (1 . 4)))))
 @Item={B1}
 @Item={B2}
 @Item={B3}
 @Item={B4}
-> NIL

Interaction of Generator Clauses
select is mostly useful if more than one generator clause is
involved. The tree search parameters of all clauses are meant to form a logical
AND. Only those objects should be returned, for which all search
parameters (and the associated filter clauses) are valid. As soon as one of the
clauses finishes stepping through its database (sub)tree, the whole call to
select will terminate, because further values returned from other
generator clauses cannot be part of the result set.


Therefore, select would find all results most quickly if it
could simply call only the generator clause with the smallest (sub)tree.
Unfortunately, this is usually not known in advance. It depends on the
distribution of the data in the database, and on the search parameters to each
generator clause.


Instead, select single-steps each generator clause in turn, in a
round-robin scheme, applies the filter clauses to each generated object, and
re-arranges the order of generator clauses so that the more successful clauses
will be preferred. This process usually converges quickly and efficiently.



Combined Indexes
A generator clause can also combine several (similar) indexes into a single
one. Then the clause is written actually as a list of clauses.


For example, a generator clause to search for a customer by phone number is


(tel +CuSu @Tel)



If we want to search for a customer without knowing whether a given number is a
normal or a mobile phone number, then a combined generator clause searching both
index trees could look like


((tel +CuSu @Tel  mob +CuSu @Tel))

The generator will first traverse all matching entries in the +Ref tree of the tel relation, and
then, when these are exhausted, all matching entries in the mob
index tree.



Indirect Object Associations
But generator clauses are not limited to the direct B-Tree interaction of
db/3. They can also traverse trees of
associated objects, and then follow +Link / +Joint relations, or tree relations like
+Ref to arrive at database objects
with a type suitable for return values from select.


To locate appropriate objects from associated objects, the generator clause
can contain - in addition to the standard relation/class/pattern specification
(see Generator Clauses above) - an arbitrary number of
association specifiers. Each association specifier can be


    

  1. A symbol. Then a +Link or
+Joint will be followed, or a
+List of those will be traversed to
locate appropriate objects.


  2. A list. Then this list should hold a relation and a class (and an optional
hook) which specify some B-Tree +index to be traversed to locate appropriate
objects.




In this way, a single generator clause can cause the traversal of a tree of
object relations to generate the desired sequence of objects.

An example can be found in "app/gui.l", in the 'choOrd' function which
implements the search dialog for +Ord (order) objects. Orders can
be searched for order number and date, customer name and city, item description
and supplier name:


(select (@@)
   ((nr +Ord @Nr) (dat +Ord @Dat)
      (nm +CuSu @Cus (cus +Ord))
      (ort +CuSu @Ort (cus +Ord))
      (nm +Item @Item (itm +Pos) ord)
      (nm +CuSu @Sup (sup +Item) (itm +Pos) ord) )

While (nr +Ord @Nr) and (dat +Ord @Dat) are direct
index traversals, (nm +CuSu @Cus (cus +Ord)) iterates the
nm (name) index of customers/suppliers +CuSu, and then
follows the +Ref +Link of the cus relation to the
orders. The same applies to the search for city names via ort.


The most complex example is (nm +CuSu @Sup (sup +Item) (itm +Pos)
ord), where the supplier name is searched in the nm tree of
+CuSu, then the +Ref tree
(sup +Item) tree is followed to locate items of that supplier, then
all positions for those items are found using (itm +Pos), and
finally the ord +Joint
is followed to arrive at the order object(s).



Nested Pilog Queries
In the most general case, a generator clause can be an arbitrary Pilog query.
Often this is a query to a database on a remote machine, using the remote/2 predicate, or some other resource
not accessible via database indexes, like iterating a +List of +Links or +Joints.


Syntactically, such a generator clause is recognized by the fact that its CAR
is a Pilog variable to denote the return value.


The second argument is a list of Pilog variables to communicate values (via
unify) from the surrounding
select environment.


The third argument is the actual list of clauses for the nested query.


Finally, an arbitrary number of association specifiers may follow, as
described in the Indirect Object Associations
section.


We can illustrate this with a somewhat useless (but simple) example, which
replaces the standard generators for item number and supplier name


(select (@Item)
   ((nr +Item @Nr) (nm +CuSu @Sup (sup +Item)))
   ...

with the equivalent form


(select (@Item)
   ((@A (@Nr) ((db nr +Item @Nr @A)))
      (@B (@Sup) ((db nm +CuSu @Sup @B)) (sup +Item)) )

That is, a query with the db/3 tree
iteration predicate is used to generate appropriate values.



Filter Clauses
The generator clauses produce - independent from each other - lots of
objects, which match the patterns of individual generator clauses, but not
necessarily the desired result set of the total select call.
Therefore, the filter clauses are needed to retain the good, and throw away the
bad objects. In addition, they give feedback to the generator for optimizing its
traversal priorities (as described in Generator Clauses).


select then collects all objects which passed through the
filters into a unique list, to avoid duplicates which would otherwise appear,
because most objects can be found by more than one generator clause.


Technically, the filters are normal Pilog clauses, which just happen to be
evaluated in the context of select. Arbitrary Pilog predicates can
be used, though there exist some predicates (e.g. isa/2, same/3, bool/3, range/3, head/3, fold/3, part/3 or tolr/3) especially suited for that task.



A Little Report
Assume we want to know how many pieces of item #2 were sold in the year 2007.
Then we must find all +Pos (position) objects referring to that
item and at the same time belonging to orders of the year 2007 (see the class
definition for +Pos in "app/er.l"). The number of sold pieces is
then in the cnt property of the +Pos objects.


As shown in the complete select below, we will hold the item
number in the variable @Nr and the date range for the year in
@Year.


Now, all positions referred by item #2 can be found by the generator clause


(nr +Item @Nr (itm +Pos))

and all positions sold in 2007 can be found by


(dat +Ord @Year pos)

However, the combination of both generator clauses


(select (@Pos)
   ((nr +Item @Nr (itm +Pos)) (dat +Ord @Year pos)) )

will probably generate too many results, namely all positions with item #2
OR from the year 2007. Thus, we need two filter clauses. With them, the
full search expression will be:


(?
   @Nr 2                                                 # Item number
   @Year (cons (date 2007 1 1) (date 2007 12 31))        # Date range 2007
   (select (@Pos)
      ((nr +Item @Nr (itm +Pos)) (dat +Ord @Year pos))   # Generator clauses
      (same @Nr @Pos itm nr)                             # Filter item number
      (range @Year @Pos ord dat) ) )                     # Filter order date

For completeness, let's calculate the total count of sold items:


(let Cnt 0     # Counter variable
   (pilog
      (quote
         @Nr 2
         @Year (cons (date 2007 1 1) (date 2007 12 31))
         (select (@Pos)
            ((nr +Item @Nr (itm +Pos)) (dat +Ord @Year pos))
            (same @Nr @Pos itm nr)
            (range @Year @Pos ord dat) ) )
      (inc 'Cnt (get @Pos 'cnt)) )  # Increment total count
   Cnt )  # Return count

Filter Predicates
As mentioned under Filter Clauses, some predicates
exists mainly for select filtering.


Some of these predicates are of general use: isa/2 can be used to check for a type,
same/3 checks for a definite value,
bool/3 looks if the value is
non-NIL. These predicates are rather independent of the +relation type.


range/3 checks whether a value
is within a given range. This could be used with any +relation type, but typically it will be
used for numeric (+Number) or time
( +Date and +Time) relations.


Other predicates make only sense in the context of a certain +relation type:





================================================
FILE: doc/structures
================================================
# 09jul24 Software Lab. Alexander Burger

   ### Primary data types ###

   cnt   xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxS010
   big   xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxS100
   sym   xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx1000
   pair  xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx0000


         Bignum
         |
         V
      +-----+-----+
      | DIG |  |  |
      +-----+--+--+
               |
               V
            +-----+-----+
            | DIG |  |  |
            +-----+--+--+
                     |
                     V
                  +-----+-----+
                  | DIG | CNT |
                  +-----+-----+


      Pair
      |
      V
      +-----+-----+
      | CAR | CDR |
      +-----+-----+


            Symbol
            |
            V
      +-----+-----+                                +-----+-----+
      |  |  | VAL |                                |'cba'|'fed'|
      +--+--+-----+                                +-----+-----+
         | tail                                       ^
         |                                            |
         V                                            | name
         +-----+-----+     +-----+-----+     +-----+--+--+
         |  |  |  ---+---> | KEY |  ---+---> |  |  |  |  |
         +--+--+-----+     +-----+-----+     +--+--+-----+
            |                                   |
            V                                   V
            +-----+-----+                       +-----+-----+
            | VAL | KEY |                       | VAL | KEY |
            +-----+-----+                       +-----+-----+


      NIL:  /
            |
            V
      +-----+-----+-----+-----+
      |'LIN'|  /  |  /  |  /  |
      +-----+-----+-----+-----+


   Symbol tail
      Internal/Transient
         0010 Short name
         0100 Long name
         0000 Properties

      External
         1010 Short name
         1000 Properties

   Name final short
      Internals, Transients
         0000.xxxxxxx.xxxxxxx.xxxxxxx.xxxxxxx.xxxxxxx.xxxxxxx.xxxxxxx0010
           60      52      44      36      28      20      12       4

      Externals
         42 bit Object (4 Tera objects)
         16 bit File (64 K files)
          2 bit Status
            Loaded    01........
            Dirty     10........
            Deleted   11........

         1+2 Bytes: 1 file, 64K objects                  {177777}
         1+3 Bytes: 16 files, 1M objects               {O3777777}
         1+4 Bytes: 256 files, 16M objects           {OO77777777}
         1+5 Bytes: 256 files, 4G objects         {OO37777777777}
         1+6 Bytes: 65536 files, 4G objects     {OOOO37777777777}
         1+8 Bytes: 65536 files, 4T objects  {OOOO77777777777777}
         (2 + 10 + 8 + 12 + 8 + 20)
         xx.xxxxxxxxx.xxxxxxx.xxxxxxxxxxx.xxxxxxx.xxxxxxxxxxxxxxxxxxxE010
           obj       file    obj         file    obj
                     ^6      ^5      ^4      ^3      ^2


   ### Heap ###

      Heaps, Avail
      |
      |  +-----------------------+
      |  |                       |
      V  |                       V
      +--+--+-----+-----+-----+-----+-----+---     ---+-----+-----+-----+
      |  |  |     |           |  /  |     |    ...    |  |  |     |  |  |
      +-----+-----+-----+-----+-----+-----+---     ---+--+--+-----+--+--+
                                                         |           |
                                                         |           +-----> Heaps
                                                         |
                                                         +-----> Avail


   ### Stack ###

      Saved values:

         ^
         |
         +---- LINK
               val  <-- Link


      Bind frame:

                        ^
               Expr     |
               LINK ----+
                @
         +---> [@]
         |
         +---- LINK
               sym1
         +---> val1
         .
         .
         +---- LINK
               symN
               valN  <-- Bind


      VarArgs frame:

            [Bind frame]
         ^
         |
         +---- LINK
               arg1 <------------+
         +-------   <-- Next     |
         |                       |
         |     LINK -------------+
         | +-> arg2
         +-|->   ----------------+
           |                     |
           +-- LINK              |
               arg3 <-- Link     |
                /   <------------+


      Apply args:

         ^
         |
         +---- LINK
               fun  <---+  <-----+
               zero     |        |
         +---- cdr      |        |
         |     car  ----+  <-- E |
         |                       |
         |     LINK -------------+
         | +-> val1 <---+
         | |   zero     |
         | |   cdr1 ----|-----+
         +---> car1 ----+     |
           |                  |
           +-- LINK           |
         +---> valN  <-- Link |
         |     zero           |
         |      /             |
         +---- carN <---------+


      I/O frame:
                        ^
               put/get  |
               pid      |
               fd       |
               LINK ----+  <-- InFrames, OutFrames, ErrFrames, CtlFrames


      Catch frame:
                        ^
               [rst]    |
               [env]    |
               ...      |
               co       |
               fin      |
               tag      |
               LINK ----+  <-- Catch


      Coroutine:

               [rst]
               [env]
               ...
               [@]
               lim
               prg
               otg
               org
         +---- nxt
         |     tag   <----- Coroutines
         |
         |
         |     [rst]
         |     [env]
         |     ...
         |     [@]
         |     lim
         |     prg
         |     otg
         |     org
         |     nxt
         +---> tag


      IPC pipes:

                  +--------------------------+ Mic
                  |
                  |  +-----------------+ Tell         
                  |  |
                  |  +-----------------> Hear
          |  |
                  |  |
         Spkr <---+  |
                  |  |
                  |  |
                  |  +-----------------+ Tell
                  |  |
                  |  +-----------------> Hear         
                  |
                  +--------------------------+ Mic


   ### Database file ###

                  +-------------+-+-------------+-+----+
      Block 0:    |   Free       0|   Next       0| << |
                  +-------------+-+-------------+-+----+
                  0               BLK                  2*Blk+1


                  +-------------+-+
      Free:       |   Link       0|
                  +-------------+-+
                  0


                  +-------------+-+----
      ID-Block:   |   Link       1| Data
                  +-------------+-+----
                  0              BLK


                  +-------------+-+----
      EXT-Block:  |   Link       n| Data
                  +-------------+-+----
                  0              BLK


   ### Assumptions ###

   - 8 bit per byte
   - 64 bit per word
   - Pointer size is 64 bit
   - Stack grows downwards
   - sizeof(float) = 4 bytes
   - sizeof(double) = 8 bytes


================================================
FILE: doc/tut.html
================================================






PicoLisp Tutorial



abu@software-lab.de


A PicoLisp Tutorial



(c) Software Lab. Alexander Burger


This document demonstrates some aspects of the PicoLisp system in detail and
example. For a general description of the PicoLisp kernel please look at the PicoLisp Reference.


This is not a Lisp tutorial, as it assumes some basic knowledge of
programming, Lisp, and even PicoLisp. Please read these sections before coming
back here: Introduction and The PicoLisp Machine. This tutorial concentrates on the
specificities of PicoLisp, and its differences with other Lisp dialects.


Now let's start



If not stated otherwise, all examples assume that PicoLisp was started from a
global installation (see Installation) from the
shell prompt as


$ pil +
:




It loads the PicoLisp base system and the debugging environment, and waits
for you to enter input lines at the interpreter prompt (:). You can
terminate the interpreter and return to the shell at any time, by either hitting
the Ctrl-D key, or by executing the function (bye).


Input editing is done via the readline(3) library. You will want
to configure it according to your taste via your "~/.inputrc" file. Useful value
for PicoLisp are


set keyseq-timeout 40
set blink-matching-paren on
TAB: menu-complete
C-y: menu-complete-backward



In addition to the above, I (preferring vi-style) do also have


set editing-mode vi
set keymap vi-command
v: ""




Table of content



If you are new to PicoLisp, you might want to read the following sections in
the given order, as some of them assume knowledge about previous ones. Otherwise
just jump anywhere you are interested in.







Browsing



PicoLisp provides some functionality for inspecting pieces of data and code
within the running system.


Basic tools


The really basic tools are of course available and their name alone is enough
to know:
print,
size
...


But you will appreciate some more powerful tools like:

  • match, a predicate which
    compares S-expressions with bindable wildcards when matching,
    • 




Inspect a symbol with show



The most commonly used tool is probably the show function. It takes a symbolic argument,
and shows the symbol's name (if any), followed by its value, and then the
contents of the property list on the following lines (assignment of such things
to a symbol can be done with set,
setq, and put).


: (setq A '(This is the value))  # Set the value of 'A'
-> (This is the value)
: (put 'A 'key1 'val1)           # Store property 'key1'
-> val1
: (put 'A 'key2 'val2)           # and 'key2'
-> val2
: (show 'A)                      # Now 'show' the symbol 'A'
A (This is the value)
   key2 val2
   key1 val1
-> A




show accepts an arbitrary number of arguments which are
processed according to the rules of get, resulting in a symbol which is showed then.


: (put 'B 'a 'A)        # Put 'A' under the 'a'-property of 'B'
-> A
: (setq Lst '(A B C))   # Create a list with 'B' as second argument
-> (A B C)
: (show Lst 2 'a)       # Show the property 'a of the 2nd element of 'Lst'
A (This is the value)   # (which is 'A' again)
   key2 val2
   key1 val1
-> A




Inspect and edit symbols in-memory



If you pass one or more symbols as a list to vi, they are written to a temporary file in a
format similar to show, and Vip is started with that
file.


: (vi '(A B))




The Vip window will look like


A (This is the value)
key1 val1
key2 val2

(=======)

B NIL
a A  # (This is the value)

(=======)




A convenient shortcut is the non-evaluating version v of
vi. An equivalent call to the above is:


(v A B)




Now you can modify values or properties. You should not touch the
parenthesized hyphens, as they serve as delimiters. If you position the cursor
on the first character of a symbol name and type 'K' ("Keyword
lookup"), the editor will be restarted with that symbol added to the editor
window. 'Q' (for "Quit") will bring you back to the previous view.


If you exit Vip with e.g. ":x", any changes you made in your editing session
will be communicated back to the REPL.


In-memory editing is also very useful to browse in a database. You can follow
the links between objects with 'K', and even - e.g. for low-level
repairs - modify the data (but only if you are really sure about what you are
doing, and don't forget to commit
when you are done).


Built-in pretty print with pp



The pretty-print function pp
takes a symbol that has a function defined (or two symbols that specify message
and class for a method definition), and displays that definition in a formatted
and indented way.


: (pp 'pretty)
(de pretty (X N)
   (setq N (abs (space (or N 0))))
   (while (and (pair X) (== 'quote (car X)))
      (prin "'")
      (pop 'X) )
   (cond
      ...
      (T (prtty0 X N)) ) )
-> pretty




The style is the same as we use in source files:


    


  • The indentation level is three spaces


  • If a list is too long (to be precise: if its size is greater than 12), pretty-print the CAR
on the current line, and each element of the CDR recursively on its own line.


  • A closing parenthesis a preceded by a space if the corresponding open
parenthesis is not on the same line





Inspect elements one by one with more



more is a simple tool that displays
the elements of a list one by one. It stops after each element and waits for
input. If you just hit ENTER, more continues with the next element,
otherwise (usually I type a dot (.) followed by ENTER) it
terminates.


: (more (1 2 3 4 5 6))
1                          # Hit ENTER
2   .                      # Hit '.' and ENTER
-> T                       # stopped




Optionally more takes a function as a second argument and
applies that function to each element (instead of the default print). Here, often show or
pp (see below) is used.


: (more '(A B))            # Step through 'A' and 'B'
A
B
-> NIL
: (more '(A B) show)       # Step through 'A' and 'B' with 'show'
A (This is the value)      # showing 'A'
   key2 val2
   key1 val1
                           # Hit ENTER
B NIL                      # showing 'B'
   a A
-> NIL




Search through available symbols with what



The what function returns a list of
all internal symbols in the system which match a given pattern (with
'@' wildcard characters).


: (what "prin@")
-> (prin print prinl print> printsp println)




Search through values or properties of symbols with who



The function who returns "who
contains that", i.e. a list of symbols that contain a given argument
somewhere in their value or property list.


: (who 'print)
-> (query _pretty spPrt prtty1 prtty2 prtty3 pretty ("syms>" . "+Buffer")
msg more show view (print> . +Date) rules select (print> . +relation) pico)




A dotted pair indicates either a method definition or a property entry. So
(print> . +relation) denotes the print> method of
the +relation class.


who can be conveniently combined with more and
pp:


: (more (who 'print) pp)
(de query ("Q" "Dbg")  # Pretty-print these functions one by one
   (use "R"
      (loop
         (NIL (prove "Q" "Dbg"))
         (T (=T (setq "R" @)) T)
         (for X "R"
            (space)
            (print (car X))
            (print '=)
            (print (cdr X))
            (flush) )
         (T (line)) ) ) )

(de pretty (X N)
   ...




The argument to who may also be a pattern list (see match):


: (who '(print @ (less (val @))))
-> (show)

: (more (who '(% @ 7)) pp)
(de day (Dat Lst)
   (when Dat
      (get
         (or Lst *DayFmt)
         (inc (% (inc Dat) 7)) ) ) )

(de _week (Dat)
   (/ (- Dat (% (inc Dat) 7)) 7) )




Find what classes can accept a given message with can



The function can returns a list
which indicates which classes can accept a given message. Again, this
list is suitable for iteration with pp:


: (can 'del>)                                   # Which classes accept 'del>' ?
-> ((del> . +List) (del> . +Entity) (del> . +relation))

: (more (can 'del>) pp)                         # Inspect the methods with 'pp'
(dm (del> . +List) (Obj Old Val)
   (and ((<> Old Val) (delete Val Old)) )

(dm (del> . +Entity) (Var Val)
   (when
      (and
         Val
         (has> (meta This Var) Val (get This Var)) )
      (let Old (get This Var)
         (rel>
            (meta This Var)
            This
            Old
            (put This Var (del> (meta This Var) This Old @)) )
         (when (asoq Var (meta This 'Aux))
            (relAux This Var Old (cdr @)) )
         (upd> This Var Old) ) ) )

(dm (del> . +relation) (Obj Old Val)
   (and ((<> Old Val) Val) )




Inspect dependencies with dep



dep shows the dependencies in a
class hierarchy. That is, for a given class it displays the tree of its
(super)class(es) above it, and the tree of its subclasses below it.


To view the complete hierarchy of input fields, we start with the root class
+relation:


: (dep '+relation)
+relation
   +Bag
   +Any
   +Blob
   +Link
      +Joint
   +Bool
   +Symbol
      +String
   +Number
      +Time
      +Date
-> +relation




If we are interested in +Link:


: (dep '+Link)
   +relation
+Link
   +Joint
-> +Link




This says that +Link is a subclass of +relation, and has a single subclass
(+Joint).





Defining Functions



Most of the time during programming is spent defining functions (or methods).
In the following we will concentrate on functions, but most will be true for
methods as well except for using dm
instead of de.


Functions with no argument



The notorious "Hello world" function must be defined:


: (de hello ()
   (prinl "Hello world") )
-> hello




The () in the first line indicates a function without arguments.
The body of the function is in the second line, consisting of a single
statement. The last line is the return value of de, which here is
the defined symbol. From now on we will omit the return values of examples when
they are unimportant.


Now you can call this function this way:


: (hello)
Hello world




Functions with one argument



A function with an argument might be defined this way:


: (de hello (X)
   (prinl "Hello " X) )
# hello redefined
-> hello




PicoLisp informs you that you have just redefined the function. This might be
a useful warning in case you forgot that a bound symbol with that name already
existed.


: (hello "world")
Hello world




: (hello "Alex")
Hello Alex




Preventing arguments evaluation and variable number of arguments



Normally, PicoLisp evaluates the arguments before it passes them to a
function:


: (hello (+ 1 2 3))
Hello 6




: (setq A 1  B 2)       # Set 'A' to 1 and 'B' to 2
-> 2
: (de foo (X Y)         # 'foo' returns the list of its arguments
   (list X Y) )
-> foo
: (foo A B)             # Now call 'foo' with 'A' and 'B'
-> (1 2)                # -> We get a list of 1 and 2, the values of 'A' and 'B'




In some cases you don't want that. For some functions (setq for example) it is better if the function
gets all arguments unevaluated, and can decide for itself what to do with them.


For such cases you do not define the function with a list of
parameters, but give it a single atomic parameter instead. PicoLisp will
then bind all (unevaluated) arguments as a list to that parameter.


: (de foo X
   (list (car X) (cadr X)) )        # 'foo' lists the first two arguments

: (foo A B)                         # Now call it again
-> (A B)                            # -> We don't get '(1 2)', but '(A B)'

: (de foo X
   (list (car X) (eval (cadr X))) ) # Now evaluate only the second argument

: (foo A B)
-> (A 2)                            # -> We get '(A 2)'




Mixing evaluated arguments and variable number of unevaluated arguments



As a logical consequence, you can combine these principles. To define a
function with 2 evaluated and an arbitrary number of unevaluated arguments:


: (de foo (X Y . Z)     # Evaluate only the first two args
   (list X Y Z) )

: (foo A B C D E)
-> (1 2 (C D E))        # -> Get the value of 'A' and 'B' and the remaining list




Variable number of evaluated arguments



More common, in fact, is the case where you want to pass an arbitrary number
of evaluated arguments to a function. For that, PicoLisp recognizes the
symbol @ as a single atomic parameter and remembers all evaluated
arguments in an internal frame. This frame can then be accessed sequentially
with the args, next, arg and rest functions.


: (de foo @
   (list (next) (next)) )     # Get the first two arguments

: (foo A B)
-> (1 2)




Again, this can be combined:


: (de foo (X Y . @)
   (list X Y (next) (next)) ) # 'X' and 'Y' are fixed arguments

: (foo A B (+ 3 4) (* 3 4))
-> (1 2 7 12)                 # All arguments are evaluated




These examples are not very useful, because the advantage of a variable
number of arguments is not used. A function that prints all its evaluated
numeric arguments, each on a line followed by its squared value:


: (de foo @
   (while (args)                    # Check if there are some args left
      (let N (next)
         (println N (* N N)) ) ) )

: (foo (+ 2 3) (- 7 1) 1234 (* 9 9))
5 25
6 36
1234 1522756
81 6561
-> 6561




This next example shows the behaviour of args and
rest:


: (de foo @
   (while (args)
      (println (next) (args) (rest)) ) )
: (foo 1 2 3)
1 T (2 3)
2 T (3)
3 NIL NIL




Finally, it is possible to pass all these evaluated arguments to another
function, using pass:


: (de foo @
   (pass println 9 8 7)       # First print all arguments preceded by 9, 8, 7
   (pass + 9 8 7) )           # Then add all these values

: (foo (+ 2 3) (- 7 1) 1234 (* 9 9))
9 8 7 5 6 1234 81             # Printing ...
-> 1350                       # Return the result




Anonymous functions without the lambda keyword


There's no distinction between code and data in PicoLisp,
quote will do what you want (see
also this FAQ entry).


: ((quote (X) (* X X)) 9)
-> 81




: (setq f '((X) (* X X)))  # This is equivalent to (de f (X) (* X X))
-> ((X) (* X X))
: f
-> ((X) (* X X))
: (f 3)
-> 9







Debugging



There are two major ways to debug functions (and methods) at runtime:
Tracing and single-stepping.


In this section we will use the REPL to explore the debugging facilities, but
in the Scripting section, you will learn how to launch
PicoLisp scripts with some selected functions debugged:


$ pil app/file1.l -"trace 'foo" -main -"debug 'bar" app/file2.l +




Tracing



Tracing means letting functions of interest print their name and arguments
when they are entered, and their name again and the return value when they are
exited.


For demonstration, let's define the unavoidable factorial function:


(de fact (N)
   (if (=0 N)
      1
      (* N (fact (dec N))) ) )




With trace we can put it in trace
mode:


: (trace 'fact)
-> fact




Calling fact now will display its execution trace.


: (fact 3)
 fact : 3
  fact : 2
   fact : 1
    fact : 0
    fact = 1
   fact = 1
  fact = 2
 fact = 6
-> 6




As can be seen here, each level of function call will indent by an additional
space. Upon function entry, the name is separated from the arguments with a
colon (:), and upon function exit with an equals sign
(=) from the return value.


trace works by modifying the function body, so generally it
works only for functions defined as lists (lambda expressions, see Evaluation). Tracing a built-in function (SUBR) is
possible, however, when it is a function that evaluates all its arguments.


So let's trace the functions =0 and
*:


: (trace '=0)
-> =0
: (trace '*)
-> *




If we call fact again, we see the additional output:


: (fact 3)
 fact : 3
  =0 : 3
  =0 = NIL
  fact : 2
   =0 : 2
   =0 = NIL
   fact : 1
    =0 : 1
    =0 = NIL
    fact : 0
     =0 : 0
     =0 = 0
    fact = 1
    * : 1 1
    * = 1
   fact = 1
   * : 2 1
   * = 2
  fact = 2
  * : 3 2
  * = 6
 fact = 6
-> 6




To reset a function to its untraced state, call untrace:


: (untrace 'fact)
-> fact
: (untrace '=0)
-> =0
: (untrace '*)
-> *




or simply use mapc:


: (mapc untrace '(fact =0 *))
-> *




Single-stepping



Single-stepping means to execute a function step by step, giving the
programmer an opportunity to look more closely at what is happening. The
function debug inserts a breakpoint
into each top-level expression of a function. When the function is called, it
stops at each breakpoint, displays the expression it is about to execute next
(this expression is also stored into the global variable ^) and enters a read-eval-loop. The programmer
can then


    


  • inspect the current environment by typing variable names or calling
functions


  • execute (d) to recursively debug the
next expression (looping through subexpressions of this expression)


  • execute (e) to evaluate the next
expression, to see what will happen without actually advancing on


  • type ENTER (that is, enter an empty line) to leave the read-eval loop and
continue with the next expression





Thus, in the simplest case, single-stepping consists of just hitting ENTER
repeatedly to step through the function.


To try it out, let's look at the stamp system function. You may need to have a
look at


    

  • =T (T test),
    • 


  • date and time (grab system date and time)


  • default (conditional
assignments)


  • pack (kind of concatenation), and


  • dat$ and tim$ (date and time formats)
    • 




to understand this definition.


: (pp 'stamp)
(de stamp (Dat Tim)
   (and (=T Dat) (setq Dat (date T)))
   (default Dat (date) Tim (time T))
   (pack (dat$ Dat "-") " " (tim$ Tim T)) )
-> stamp




: (debug 'stamp)                       # Debug it
-> T
: (stamp)                              # Call it again
(and (=T Dat) (setq Dat (date T)))     # stopped at first expression
!                                      # ENTER
(default Dat (date) Tim (time T))      # second expression
!                                      # ENTER
(pack (dat$ Dat "-") " " (tim$ ...     # third expression
! Tim                                  # inspect 'Tim' variable
-> 41908
! (time Tim)                           # convert it
-> (11 38 28)
!                                      # ENTER
-> "2004-10-29 11:38:28"               # done, as there are only 3 expressions




Now we execute it again, but this time we want to look at what's happening
inside the second expression.


: (stamp)                              # Call it again
(and (=T Dat) (setq Dat (date T)))
!                                      # ENTER
(default Dat (date) Tim (time T))
!                                      # ENTER
(pack (dat$ Dat "-") " " (tim$ ...     # here we want to look closer
! (d)                                  # debug this expression
-> T
!                                      # ENTER
(dat$ Dat "-")                         # stopped at first subexpression
! (e)                                  # evaluate it
-> "2004-10-29"
!                                      # ENTER
(tim$ Tim T)                           # stopped at second subexpression
! (e)                                  # evaluate it
-> "11:40:44"
!                                      # ENTER
-> "2004-10-29 11:40:44"               # done




The breakpoints still remain in the function body. We can see them when we
pretty-print it:


: (pp 'stamp)
(de stamp (Dat Tim)
   (! and (=T Dat) (setq Dat (date T)))
   (! default Dat (date) Tim (time T))
   (! pack
      (! dat$ Dat "-")
      " "
      (! tim$ Tim T) ) )
-> stamp




To reset the function to its normal state, call unbug:


: (unbug 'stamp)




Often, you will not want to single-step a whole function. Just use
v (see above) to insert a single breakpoint (the exclamation mark
followed by a space) as CAR of an expression, and run your program. Execution
will then stop there as described above; you can inspect the environment and
continue execution with ENTER when you are done.





Functional I/O



Input and output in PicoLisp is functional, in the sense that there are not
variables assigned to file descriptors, which need then to be passed to I/O
functions for reading, writing and closing. Instead, these functions operate on
implicit input and output channels, which are created and maintained as dynamic
environments.


Standard input and standard output are the default channels. Try reading a
single expression:


: (read)
(a b c)        # Console input
-> (a b c)




To read from a file, we redirect the input with in. Note that comments and whitespace are
automatically skipped by read:


: (in "@lib.l" (read))
-> (de task (Key . Prg) (nond (...




The skip function can also be used
directly. To get the first non-white character in the file with char:


: (in "@lib.l" (skip "#") (char))
-> "("




from searches through the input
stream for given patterns. Typically, this is not done with Lisp source files
(there are better ways), but for a simple example let's extract all items
immediately following fact in the file,


: (in "@lib.l" (while (from "nond") (println (read))))
(Prg (del (assoc Key *Run) '*Run))
((pair "X") (or (pair (getd "X")) (expr "X")))
("Prg" (caar (idx "Var" "K")))




or the word following "(de " with till:


: (in "@lib.l" (from "(de ") (till " " T))
-> "task"




 To read the contents of a whole file (or the rest of it starting from the
current position):


: (in "f.l" (till NIL T))
-> "... file contents ..."





With line, a line of characters is
read, either into a single transient symbol
(the type used by PicoLisp for strings),


: (in "@doc/tut.html" (line T))
-> "<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.0 Transitional//EN" "http://..."




or into a list of symbols (characters):


: (in "@doc/tut.html" (line))
-> ("<" "!" "D" "O" "C" "T" "Y" "P" "E" " " "H" "T" "M" "L" ...




line is typically used to read tabular data from a file.
Additional arguments can split the line into fixed-width fields, as described in
the reference manual. If, however, the
data are of variable width, delimited by some special character, the split function can be used to extract the
fields. A typical way to import the contents of such a file is:


(in '("bin/utf2" "importFile.txt")              # Pipe: Convert to UTF-8
   (until (eof)                                 # Process whole file
      (let L (split (line) "\t")                # TAB-delimited data
         ...                                    # process them




Some more examples with echo:


(in "a"                                         # Copy the first 40 Bytes
   (out "b"                                     # from file "a" to file "b"
      (echo 40) ) )

(in "@doc/tut.html"                             # Show the HTTP-header
   (line)
   (echo "<body>") )

(out "file.mac"                                 # Convert to Macintosh
   (in "file.txt"                               # from Unix or DOS format:
      (while (char)
         (prin
            (case @
               ("\r" NIL)                       # ignore CR
               ("\n" "\r")                      # convert LF to CR
               (T @) ) ) ) ) )                  # otherwise no change

(out "c"                                        # Merge the contents of "a"
   (in "b"                                      # and "b" into "c"
      (in "a"
         (while (read)                          # Read an item from "a",
            (println @ (in -1 (read))) ) ) ) )  # print it with an item from "b"







Scripting



There are two possibilities to get the PicoLisp interpreter into doing useful
work: via command line arguments, or as a stand-alone script.


Command line arguments for the PicoLisp interpreter



The command line can specify either files for execution, or arbitrary Lisp
expressions for direct evaluation (see Invocation):
if an argument starts with a hyphen, it is evaluated, otherwise it is loaded as a file. A typical invocation might
look like:


$ pil app/file1.l -main app/file2.l +




It loads the debugging environment, an application source file, calls the
main function, and then loads another application source. In a typical
development and debugging session, this line is often modified using the shell's
history mechanisms, e.g. by inserting debugging statements:


$ pil app/file1.l -"trace 'foo" -main -"debug 'bar" app/file2.l +




Another convenience during debugging and testing is to put things into the
command line (shell history) which would otherwise have to be done each time in
the application's user interface:


$ pil app/file1.l -main app/file2.l -go -'login "name" "password"' +




The final production release of an application usually includes a shell
script, which initializes the environment, does some bookkeeping and cleanup,
and calls the application with a proper command line. It is no problem if the
command line is long and complicated.


For small utility programs, however, this is overkill. Enter full PicoLisp
scripts.


PicoLisp scripts


It is better to write
a single executable file using the mechanisms of "interpreter files". If the
first two characters in an executable file are "#!", the operating
system kernel will pass this file to an interpreter program whose pathname is
given in the first line (optionally followed by a single argument). This is fast
and efficient, because the overhead of a subshell is avoided.


Let's assume you installed PicoLisp in the directory "/home/foo/pil21/",
and put links to the executable and the installation directory as:


$ ln -s /home/foo/pil21 /usr/lib/picolisp
$ ln -s /usr/lib/picolisp/bin/picolisp /usr/bin



Then a simple hello-world script might look like:


#!/usr/bin/picolisp /usr/lib/picolisp/lib.l
(prinl "Hello world!")
(bye)




If you write this into a text file, and use chmod to set it to
"executable", it can be executed like any other command. Note that (because
# is the comment character in PicoLisp) the first line will not be
interpreted, and you can still use that file as a normal command line argument
to PicoLisp (useful during debugging).


Grab command line arguments from PicoLisp scripts



The fact that a hyphen causes evaluation of command line arguments can be
used to implement command line options. The following script defines two
functions a and f, and then calls (load T) to process the rest of the command line
(which otherwise would be ignored because of the (bye) statement):


#!/usr/bin/picolisp /usr/lib/picolisp/lib.l

(de a ()
   (println '-a '-> (opt)) )

(de f ()
   (println '-f '-> (opt)) )

(load T)
(bye)



(opt retrieves the next command line
option)


Calling this script (let's say we named it "testOpts") gives:


$ ./testOpts -f abc
-f -> "abc"
$ ./testOpts -a xxx  -f yyy
-a -> "xxx"
-f -> "yyy"




We have to be aware of the fact, however, that the aggregation of arguments
like


$ ./testOpts -axxx  -fyyy




or


$ ./testOpts -af yyy




cannot be achieved with this simple and general mechanism of command line
processing.


Run scripts from arbitrary places on the host file system



Utilities are typically used outside the context of the PicoLisp environment.
All examples above assumed that the current working directory is the PicoLisp
installation directory, which is usually all right for applications developed in
that environment. Command line file arguments like "app/file1.l" will be
properly found.


To allow utilities to run in arbitrary places on the host file system, the
concept of home directory substitution was introduced. The interpreter
remembers internally at start-up the pathname of its first argument (usually
"lib.l"), and substitutes any leading "@" character in subsequent
file names with that pathname. Thus, to run the above example in some other
place, simply write:


$ /home/foo/pil21/pil @app/file1.l -main @app/file2.l +




that is, supply a full path name to the initial command (here 'pil'), or put
it into your PATH variable, and prefix each file which has to be
loaded from the PicoLisp home directory with a @ character.
"Normal" files (not prefixed by @) will be opened or created
relative to the current working directory as usual.


Stand-alone scripts will often want to load additional modules from the
PicoLisp environment, beyond the "lib.l" we provided in the first line of the
hello-world script. Typically, at least a call to


(load "@lib/misc.l")




(note the home directory substitution) will be included near the beginning of
the script.


As a more complete example, here is a script which extracts the date, name
and size of the latest official PicoLisp release version from the download web
site, and prints it to standard output:


#!/usr/bin/picolisp /usr/lib/picolisp/lib.l

(load "@lib/misc.l" "@lib/http.l")

(use (@Date @Name @Size)
   (when
      (match
         '(@Date ~(chop " - <a href=\"") @Name "\"" ">"
             @Name ~(chop "</a> (") @Size )
         (client "software-lab.de" 80 "down.html"
            (from "Release Archive")
            (from "<li>")
            (till ",") ) )
      (prinl @Name)
      (prinl @Date " -- " @Size) ) )

(bye)







================================================
FILE: doc/viprc.sample
================================================
# 21dec25 Software Lab. Alexander Burger
# Copy to ~/.pil/viprc

## Uncomment to enable the ":cal" (calendar) command
## (load "@lib/vip/cal.rc.l")

(map+q "d" ":bd\r")

## If you prefer LEFT and RIGHT to move the cursor:
## (map+ "\e[D" "h")
## (map+ "\e[C" "l")

(cmd "pb1n" (L Lst Cnt)  # Pastebin
   (pipe
      (out '("curl" "-F" "f=@-;" "pb1n.de")
         (mapc prinl (: buffer text)) )
      (prCmd (rdLines)) ) )

(cmd "ix.io" (L Lst Cnt)
   (pipe
      (out '("curl" "-sF" "f:1=<-" "ix.io")
         (mapc prinl (: buffer text)) )
      (prCmd (rdLines)) ) )

(cmd "tabs" (L Lst Cnt)
   (let N (or (format L) 3)
      (=: buffer text
         (mapcar
            '((L)
               (make
                  (for (I . C) L
                     (if (= "\t" C)
                        (loop
                           (link (name " "))
                           (T (=0 (% I N)))
                           (inc 'I) )
                        (link C) ) ) ) )
            (: buffer text) ) ) ) )

(cmd "words" (L Lst Cnt)
   (xchg 'delimNs
      (quote
         ((C)
            (nand C
               (sub? C
                  "0123456789\
                  ABCDEFGHIJKLMNOPQRSTUVWXYZ\
                  _\
                  abcdefghijklmnopqrstuvwxyz" ) ) ) ) )
   (prCmd
      (list (chop (xchg '(" C") '(" Lisp")))) ) )

(de *F7  # Find current definition
   (let L (nth (: buffer text) (: posY))
      (prCmd
         (list
            (loop
               (NIL (setq L (prior L (: buffer text))))
               (T (head '`(chop "(class ") (car L))
                  (car L) )
               (T (head '`(chop "(extend ") (car L))
                  (car L) ) ) ) ) ) )

(de *F8  # Expression size
   (evCmd (size (s-expr))) )

# Timestamp
(local) vipDat

(de vipDat (N)
   (when (<> N (: posY))
      (let (@L (get (: text) N)  @A)
         (and
            (match '(@A " " @L) @L)
            (member @A '(("#") ("/" "/") ("/" "*")))
            (>= 31 (format (cut 2 '@L)) 1)
            (member (pack (cut 3 '@L)) *mon)
            (format (cut 2 '@L))
            (mapc set
               (set (nth (: text) N)
                  (conc
                     @A
                     (list (char 32))
                     (chop (datSym (date)))
                     @L ) )
               1 ) ) ) ) )

(daemon '(save> . +Buffer)
   (or (vipDat 1) (vipDat 2) (vipDat 3)) )

# Local
(and (info ".viprc") (load ".viprc"))


================================================
FILE: ext.l
================================================
# 27oct20 Software Lab. Alexander Burger

(load "@lib/net.l" "@lib/misc.l" "@lib/btree.l" "@lib/db.l" "@lib/pilog.l")

`*Dbg
(docs "@doc/")


================================================
FILE: lib/adm.l
================================================
# 30dec24 Software Lab. Alexander Burger

# *Salt *Login *Users *Perms

# crypt(3) algorithm, e.g. (setq *Salt (16 . "$6$@1$"))
(de passwd (Str Salt)
   (if *Salt
      (native "libcrypt.so" "crypt" 'S Str (or Salt (salt)))
      Str ) )

(de salt ()
   (text (cdr *Salt) (randpw (car *Salt))) )

(de randpw (Len)
   (make
      (in "/dev/urandom"
         (do Len
            (link
               (get
                  '`(mapcar char
                     (conc
                        (range (char ".") (char "9"))
                        (range (char "A") (char "Z"))
                        (range (char "a") (char "z")) ) )
                  (inc (& 63 (rd 1))) ) ) ) ) ) )

(de auth (Nm Pw Cls)
   (with (db 'nm (or Cls '+User) Nm)
      (and
         (: pw 0)
         (= @ (passwd Pw @))
         This ) ) )

### Login ###
(de login (Nm Pw Cls)
   (ifn (setq *Login (auth Nm Pw Cls))
      (msg *Pid " ? " Nm)
      (msg *Pid " * " (stamp) " " Nm)
      (tell 'hi *Pid Nm *Adr)
      (push1 '*Bye '(logout))
      (when *Timeout
         (timeout (setq *Timeout `(* 3600 1000))) ) )
   *Login )

(de logout ()
   (when *Login
      (rollback)
      (off *Login)
      (tell 'hi *Pid)
      (msg *Pid " / " (stamp))
      (when *Timeout
         (timeout (setq *Timeout `(* 300 1000))) ) ) )

(de hi (Pid Nm Adr)
   (if (and Nm (= Nm (; *Login nm)) (= Adr *Adr))
      (bye)
      (hi2 Pid Nm)
      (tell 'hi2 *Pid (; *Login nm)) ) )

(de hi2 (Pid Nm)
   (if2 Nm (lup *Users Pid)
      (con @ Nm)
      (idx '*Users (cons Pid Nm) T)
      (idx '*Users @ NIL) ) )


### Role ###
(class +Role +Entity)

(rel nm (+Need +Key +String))          # Role name
(rel perm (+List +Symbol))             # Permission list
(rel usr (+List +Joint) role (+User))  # Associated users

(allow "@lib/role.l")

(dm url> (Tab)
   (and (may RoleAdmin) (list "@lib/role.l" '*ID This)) )


### User ###
(class +User +Entity)

(rel nm (+Need +Key +String))          # User name
(rel pw (+Swap +String))               # Password
(rel role (+Joint) usr (+Role))        # User role
(rel nam (+String))                    # Full Name
(rel tel (+String))                    # Phone
(rel em (+String))                     # E-Mail

(allow "@lib/user.l")

(dm url> (Tab)
   (and
      (or (may UserAdmin) (== *Login This))
      (list "@lib/user.l" '*ID This) ) )

(dm gui> (This)
   ( 2
      ,"Full Name" (gui '(+E/R +TextField) '(nam : home obj) 40)
      ,"Phone" (gui '(+E/R +TelField) '(tel : home obj) 40)
      ,"E-Mail" (gui '(+E/R +MailField) '(em : home obj) 40) ) )

(dm login> ())


### Permission management ###
(de permission Lst
   (while Lst
      (queue '*Perms (car Lst))
      (def (++ Lst) (++ Lst)) ) )

(de may Args
   (mmeq Args (; *Login role perm)) )

(de must Args
   (unless
      (if (cdr Args)
         (find
            '((X)
               (if (atom X)
                  (memq X (; *Login role perm))
                  (eval X) ) )
            @ )
         *Login )
      (forbidden (car Args)) ) )

### GUI ###
(de choUser (Dst)
   (choDlg Dst ,"Users" '(nm +User)) )

(de loginForm "Opt"
   (form NIL
      (when "Opt"
         (eval (car "Opt"))
         (----) )
      ( 2
         ,"Name" (gui 'nm '(+Focus +Able +TextField) '(not *Login) 20)
         ,"Password" (gui 'pw '(+Able +PwField) '(not *Login) 20) )
      (--)
      (gui '(+Button) '(if *Login ,"logout" ,"login")
         '(cond
            (*Login (post (logout)))
            ((login (val> (: home nm)) (val> (: home pw)))
               (post
                  (clr> (: home pw))
                  (login> *Login) ) )
            (T (error ,"Permission denied")) ) )
      (when *Login
         ( 4)
         ( "bold green"
            (ht:Prin "'" (; *Login nm) ,"' logged in") ) )
      (when "Opt"
         (----)
         (htPrin (cdr "Opt")) ) ) )

(class +PasswdField +E/R +Fmt +TextField)

(dm T @
   (pass super
      '(pw : home obj)
      '((V) (and V "****"))
      '((V)
         (if (= V "****")
            (: home obj pw 0)
            (passwd V (: home obj pw 0)) ) ) ) )


================================================
FILE: lib/app.l
================================================
# 13apr23 Software Lab. Alexander Burger

# Exit on error
(de *Err
   (prinl *Pid " ! " (stamp) " [" *Adr " " (host *Adr) "] " *Agent)
   (for ("L" (trail T)  "L")
      (cond
         ((pair (car "L"))
            (let "E" (++ "L")
               (println
                  (if (getd (box? (car "E")))
                     (cons @ (cdr "E"))
                     "E" ) ) ) )
         ((== '"L" (car "L"))
            (setq "L" (cddr "L")) )
         (T
            (space 3)
            (println (++ "L") (++ "L")) ) ) )
   (println '====)
   (show This)
   (println '*Uri (pack *Uri))
   (println '*Host (pack *Host))
   (for "X" '(*Port *SesId *ConId *Tab *Gui *Btn *Get *ID)
      (println "X" (val "X")) )
   (println '*PRG *PRG (val *PRG))
   (rollback) )

# User identification
(de user (Pid1 Pid2 Nm To)
   (nond
      (Pid1 (tell 'user *Pid))
      (Pid2
         (tell 'user Pid1 *Pid (get *Login 'nm)
            (/ (- *Timeout (cadr (assoc -1 *Run))) 60000) ) )
      ((<> *Pid Pid1) (println Pid2 Nm To)) ) )

# Timestamp
(msg *Pid " + " (stamp))
(flush)

# Extend 'app' function
(conc (last app)
   '((msg *Pid " + " (stamp) " [" *Adr " " (host *Adr) (and *Cipher (pack " / " @)) "] " *Agent)) )

# Bye message
(push '*Fork
   '(finish (and *SesId (msg *Pid " - " (stamp)))) )


================================================
FILE: lib/bash_completion
================================================
# Bash completion for picolisp + pil
# Alexander Burger 

_pil()
{
    local -a ARGS
    local IFS=$'\n'

    for A in "${COMP_WORDS[@]:1:$((COMP_CWORD-1))}"
    do
        test "${A:0:1}" = "-" || ARGS[${#ARGS[@]}]="${A//\\ / }"
    done
    COMPREPLY=($(${COMP_WORDS[0]} ${ARGS[@]} /usr/lib/picolisp/lib/complete.l "${COMP_WORDS[$COMP_CWORD]}" -bye + 2>&1))
    return 0
} &&
complete -o nospace  -F _pil  picolisp  &&
complete -o nospace  -F _pil  pil


================================================
FILE: lib/btree.l
================================================
# 13apr25 Software Lab. Alexander Burger

# *Prune

(private) (_store _put _splitBt _del)

(de root (Tree)
   (cond
      ((not Tree) (val *DB))
      ((atom Tree) (val Tree))
      ((ext? (cdr Tree)) (get @ (car Tree)))
      ((atom (cdr Tree))
         (get *DB (cdr Tree) (car Tree)) )
      (T (get (cddr Tree) (cadr Tree) (car Tree))) ) )

# Fetch
(de fetch (Tree Key)
   (let? Node (cdr (root Tree))
      (and *Prune (idx '*Prune Node T))
      (use R
         (loop
            (and *Prune (set (prop Node NIL) 0))
            (T
               (and
                  (setq R (rank Key (cdr (val Node))))
                  (= Key (car R)) )
               (or (cddr R) (fin (car R))) )
            (NIL
               (setq Node (if R (cadr R) (car (val Node)))) ) ) ) ) )

# Store
(de store (Tree Key Val Dbf)
   (default Dbf (1 . 256))
   (if (atom Tree)
      (let Base (or Tree *DB)
         (_store (or (val Base) (set Base (cons 0)))) )
      (let Base
         (if (atom (cdr Tree))
            (or
               (ext? (cdr Tree))
               (get *DB (cdr Tree))
               (put *DB (cdr Tree) (new T 0)) )
            (or
               (get (cddr Tree) (cadr Tree))
               (put (cddr Tree) (cadr Tree) (new T)) ) )
         (_store
            (or
               (get Base (car Tree))
               (put Base (car Tree) (cons 0)) ) ) ) ) )

(de _store (Root)
   (and *Prune (cdr Root) (idx '*Prune @ T))
   (ifn Val
      (when (and (cdr Root) (_del @))
         (touch Base)
         (cond
            (*Solo (zap (cdr Root)))
            (*Zap (push @ (cdr Root))) )
         (con Root) )
      (and (= Val (fin Key)) (off Val))
      (if (cdr Root)
         (when (_put @)
            (touch Base)
            (con Root (def (new (car Dbf)) (list (car @) (cdr @)))) )
         (touch Base)
         (con Root
            (def (new (car Dbf))
               (list NIL (cons Key NIL Val)) ) )
         (and *Prune (set (prop (cdr Root) NIL) 0))
         (inc Root) ) ) )

(de _put (Top)
   (and *Prune (set (prop Top NIL) 0))
   (let (V (val Top)  R (rank Key (cdr V)))
      (cond
         (R
            (if (= Key (car R))
               (nil (touch Top) (con (cdr R) Val))
               (let X (memq R V)
                  (if (cadr R)
                     (when (_put @)
                        (touch Top)
                        (set (cdr R) (car @))
                        (con X (cons (cdr @) (cdr X)))
                        (_splitBt) )
                     (touch Top)
                     (con X
                        (cons (cons Key (cons NIL Val)) (cdr X)) )
                     (touch Base)
                     (inc Root)
                     (_splitBt) ) ) ) )
         ((car V)
            (when (_put @)
               (touch Top)
               (set V (car @))
               (con V (cons (cdr @) (cdr V)))
               (_splitBt) ) )
         (T
            (touch Top)
            (con V
               (cons (cons Key (cons NIL Val)) (cdr V)) )
            (touch Base)
            (inc Root)
            (_splitBt) ) ) ) )

(de _splitBt ()
   (when (and (cddddr V) (> (size Top) (cdr Dbf)))
      (let (N (>> 1 (length V))  X (get V (inc N)))
         (set (cdr X)
            (def (new (car Dbf))
               (cons (cadr X) (nth V (+ 2 N))) ) )
         (cons
            (if *Solo
               (prog (set Top (head N V)) Top)
               (and *Zap (push @ Top))
               (def (new (car Dbf)) (head N V)) )
            X ) ) ) )

# Del
(de _del (Top)
   (and *Prune (set (prop Top NIL) 0))
   (let (V (val Top)  R (rank Key (cdr V)))
      (cond
         ((not R)
            (when (and (car V) (_del @))
               (touch Top)
               (cond
                  (*Solo (zap (car V)))
                  (*Zap (push @ (car V))) )
               (set V)
               (not (cdr V)) ) )
         ((= Key (car R))
            (if (cadr R)
               (let X (val @)
                  (while (car X) (setq X (val @)))
                  (touch Top)
                  (xchg R (cadr X))
                  (con (cdr R) (cddr (cadr X)))
                  (when (_del (cadr R))
                     (cond
                        (*Solo (zap (cadr R)))
                        (*Zap (push @ (cadr R))) )
                     (set (cdr R)) ) )
               (touch Base)
               (dec Root)
               (nand
                  (or
                     (con V (delq R (cdr V)))
                     (car V) )
                  (touch Top) ) ) )
         ((cadr R)
            (when (_del @)
               (touch Top)
               (cond
                  (*Solo (zap (cadr R)))
                  (*Zap (push @ (cadr R))) )
               (set (cdr R)) ) ) ) ) )


# Delayed deletion
(de zap_ ()
   (let (F (cdr *Zap)  Z (pack F "_"))
      (cond
         ((info Z)
            (in Z (while (rd) (zap @)))
            (if (info F)
               (call "mv" F Z)
               (%@ "unlink" NIL Z) ) )
         ((info F) (call "mv" F Z)) ) ) )

# Tree node count
(de count (Tree)
   (or (car (root Tree)) 0) )

# Return first leaf
(de leaf (Tree)
   (let (Node (cdr (root Tree))  X)
      (while (val Node)
         (setq X (cadr @)  Node (car @)) )
      (cddr X) ) )

(private) revNode

# Reverse node
(de revNode (Node)
   (let? Lst (val Node)
      (let (L (car Lst)  R)
         (for X (cdr Lst)
            (push 'R (cons (car X) L (cddr X)))
            (setq L (cadr X)) )
         (cons L R) ) ) )

# Key management
(de minKey (Tree Min Max)
   (default Max T)
   (let (Node (cdr (root Tree))  K)
      (use (V R X)
         (loop
            (NIL (setq V (val Node)) K)
            (T
               (and
                  (setq R (rank Min (cdr V)))
                  (= Min (car R)) )
               Min )
            (if R
               (prog
                  (and
                     (setq X (cdr (memq R V)))
                     (>= Max (caar X))
                     (setq K (caar X)) )
                  (setq Node (cadr R)) )
               (when (>= Max (caadr V))
                  (setq K (caadr V)) )
               (setq Node (car V)) ) ) ) ) )

(de maxKey (Tree Min Max)
   (default Max T)
   (let (Node (cdr (root Tree))  K)
      (use (V R X)
         (loop
            (NIL (setq V (revNode Node)) K)
            (T
               (and
                  (setq R (rank Max (cdr V) T))
                  (= Max (car R)) )
               Max )
            (if R
               (prog
                  (and
                     (setq X (cdr (memq R V)))
                     (>= (caar X) Min)
                     (setq K (caar X)) )
                  (setq Node (cadr R)) )
               (when (>= (caadr V) Min)
                  (setq K (caadr V)) )
               (setq Node (car V)) ) ) ) ) )

# Step
(de init (Tree Beg End)
   (or Beg End (on End))
   (let (Node (cdr (root Tree))  Q)
      (use (V R X)
         (if (>= End Beg)
            (loop
               (NIL (setq V (val Node)))
               (T
                  (and
                     (setq R (rank Beg (cdr V)))
                     (= Beg (car R)) )
                  (push 'Q (memq R V)) )
               (if R
                  (prog
                     (and
                        (setq X (cdr (memq R V)))
                        (>= End (caar X))
                        (push 'Q X) )
                     (setq Node (cadr R)) )
                  (and
                     (cdr V)
                     (>= End (caadr V))
                     (push 'Q (cdr V)) )
                  (setq Node (car V)) ) )
            (loop
               (NIL (setq V (revNode Node)))
               (T
                  (and
                     (setq R (rank Beg (cdr V) T))
                     (= Beg (car R)) )
                  (push 'Q (memq R V)) )
               (if R
                  (prog
                     (and
                        (setq X (cdr (memq R V)))
                        (>= (caar X) End)
                        (push 'Q X) )
                     (setq Node (cadr R)) )
                  (and
                     (cdr V)
                     (>= (caadr V) End)
                     (push 'Q (cdr V)) )
                  (setq Node (car V)) ) ) ) )
      (cons (cons (cons Beg End) Q)) ) )

(de step (Q Flg)
   (use (L F X)
      (loop
         (T
            (loop
               (T (cdar Q))
               (NIL (cdr Q) T)
               (set Q (cadr Q))
               (con Q (cddr Q)) ) )
         (setq
            L (car Q)
            F (>= (cdar L) (caar L))
            X (pop (cdr L)) )
         (or (cadr L) (con L (cddr L)))
         (T
            (if ((if F > <) (car X) (cdar L))
               (con (car Q))
               (for
                  (V (cadr X)
                     ((if F val revNode) V)
                     (car @) )
                  (con L (cons (cdr @) (cdr L))) )
               (unless (and Flg (flg? (fin (car X))))
                  (if (cddr X)
                     (prog (setq @@ (car X)) @)
                     (setq @@ (caar X))
                     (fin (car X)) ) ) )
            @ ) ) ) )

(private) (_scan _nacs _iter _reti)
(private) (Tree Fun Beg End Flg Node R X V)

# Scan tree nodes
(de scan (Tree Fun Beg End Flg)
   (default Fun println)
   (or Beg End (on End))
   (let Node (cdr (root Tree))
      (and *Prune (idx '*Prune Node T))
      ((if (>= End Beg) _scan _nacs) Node) ) )

(de _scan (Node)
   (let? V (val Node)
      (for X
         (if (rank Beg (cdr V))
            (let R @
               (if (= Beg (car R))
                  (memq R (cdr V))
                  (_scan (cadr R))
                  (cdr (memq R (cdr V))) ) )
            (_scan (car V))
            (cdr V) )
         (T (> (car X) End))
         (unless (and Flg (flg? (fin (car X))))
            (Fun
               (car X)
               (or (cddr X) (fin (car X))) ) )
         (_scan (cadr X)) )
      (and *Prune (set (prop Node NIL) 0)) ) )

(de _nacs (Node)
   (let? V (revNode Node)
      (for X
         (if (rank Beg (cdr V) T)
            (let R @
               (if (= Beg (car R))
                  (memq R (cdr V))
                  (_nacs (cadr R))
                  (cdr (memq R (cdr V))) ) )
            (_nacs (car V))
            (cdr V) )
         (T (> End (car X)))
         (unless (and Flg (flg? (fin (car X))))
            (Fun
               (car X)
               (or (cddr X) (fin (car X))) ) )
         (_nacs (cadr X)) )
      (and *Prune (set (prop Node NIL) 0)) ) )

# Iterate tree values
(de iter (Tree Fun Beg End Flg)
   (default Fun println)
   (or Beg End (on End))
   (let Node (cdr (root Tree))
      (and *Prune (idx '*Prune Node T))
      ((if (>= End Beg) _iter _reti) Node) ) )

(de _iter (Node)
   (let? V (val Node)
      (for X
         (if (rank Beg (cdr V))
            (let R @
               (if (= Beg (car R))
                  (memq R (cdr V))
                  (_iter (cadr R))
                  (cdr (memq R (cdr V))) ) )
            (_iter (car V))
            (cdr V) )
         (T (> (car X) End))
         (unless (and Flg (flg? (fin (car X))))
            (Fun (or (cddr X) (fin (car X)))) )
         (_iter (cadr X)) )
      (and *Prune (set (prop Node NIL) 0)) ) )

(de _reti (Node)
   (let? V (revNode Node)
      (for X
         (if (rank Beg (cdr V) T)
            (let R @
               (if (= Beg (car R))
                  (memq R (cdr V))
                  (_reti (cadr R))
                  (cdr (memq R (cdr V))) ) )
            (_reti (car V))
            (cdr V) )
         (T (> End (car X)))
         (unless (and Flg (flg? (fin (car X))))
            (Fun (or (cddr X) (fin (car X)))) )
         (_reti (cadr X)) )
      (and *Prune (set (prop Node NIL) 0)) ) )

# UB-Trees
(de ub>= (Dim End Val Beg)
   (let (D (>> (- 1 Dim) 1)  Pat D)
      (while (> End Pat)
         (setq Pat (| D (>> (- Dim) Pat))) )
      (do Dim
         (NIL
            (>=
               (& Pat End)
               (& Pat Val)
               (& Pat Beg) ) )
         (setq Pat (>> 1 Pat)) ) ) )

(private) (Tree Dim Fun X1 X2 Node Lst Left Beg End B E X Msb Pat N Min Max Lo Hi)

(de ubIter (Tree Dim Fun X1 X2)
   (let
      (Node (cdr (root Tree))
         Lst (val Node)
         Left (++ Lst)
         Beg (ubZval (copy X1))
         End (ubZval (copy X2) T)
         B (car Beg)
         E (car End) )
      (recur (Left Lst Beg End  X)
         (while (setq X (++ Lst))
            (cond
               ((> (car X) End)
                  (setq Lst (; Left 0 -1)  Left (; Left 0 1)) )
               ((> Beg (car X))
                  (if Lst
                     (setq Left (cadr X))
                     (setq Left (; X 2 0 1)  Lst (; X 2 0 -1)) ) )
               ((ub>= Dim E (caar X) B)
                  (Fun (cdar X))
                  (recurse (; Left 0 1) (; Left 0 -1) Beg (car X))
                  (setq Beg (car X))
                  (if Lst
                     (setq Left (cadr X))
                     (setq Left (; X 2 0 1)  Lst (; X 2 0 -1)) ) )
               (T
                  (let (Msb 1  Pat 0  N 0  Min B  Max E  Lo (caar X)  Hi Lo)
                     (while (>= Max Msb)
                        (setq Msb (>> -1 Msb)  Pat (>> -1 Pat))  # Msb 100000000
                        (when (= Dim (inc 'N))                           # Pat 000100100
                           (inc 'Pat)
                           (zero N) ) )
                     (catch "ub"                                    # Clr 111..111011011
                        (let (Top Msb   Clr (| Top (x| Pat (dec Msb))))
                           (loop
                              (T (=0 (setq Msb (>> 1 Msb))))
                              (setq
                                 Pat (>> 1 Pat)
                                 Clr (| Top (>> 1 Clr)) )
                              (ifn (bit? Msb (caar X))
                                 (when (bit? Msb Max)
                                    (ifn (bit? Msb Min)  # 001
                                       (setq
                                          Max (- (| Pat Max) Msb)  # 0111(Max)
                                          Lo (| Msb (& Min Clr)) )   # 1000(Min)
                                       (setq Lo Min)     # 011
                                       (throw "ub") ) )
                                 (unless (bit? Msb Min)
                                    (if (bit? Msb Max)   # 101
                                       (setq
                                          Hi (- (| Pat Max) Msb)   # 0111(Max)
                                          Min (| Msb (& Min Clr)) )  # 1000(Min)
                                       (setq Hi Max)     # 100
                                       (throw "ub") ) ) ) ) ) )
                     (recurse (; Left 0 1) (; Left 0 -1) Beg (cons Hi T))
                     (setq Beg (cons Lo))
                     (if Lst
                        (setq Left (cadr X))
                        (setq Left (; X 2 0 1)  Lst (; X 2 0 -1)) ) ) ) ) ) ) ) )

(de prune (N)
   (for Node (idx '*Prune)
      (recur (Node)
         (let? V (val (lieu Node))
            (if (>= (inc (prop Node NIL)) N)
               (wipe Node)
               (recurse (car V))
               (for X (cdr V)
                  (recurse (cadr X)) ) ) ) ) )
   (or (gt0 N) (setq *Prune N)) )

# Delete Tree
(de zapTree (Node)
   (let? V (val Node)
      (zapTree (car V))
      (for L (cdr V)
         (zapTree (cadr L)) )
      (zap Node) ) )

(private) (Node Fun N L V X Y)

# Check tree structure
(de chkTree (Node Fun)
   (let (N 0  X)
      (when Node
         (recur (Node)
            (let V (val Node)
               (let L (car V)
                  (for Y (cdr V)
                     (when L
                        (unless (ext? L)
                           (quit "Bad node link" Node) )
                        (recurse L) )
                     (when (>= X (car Y))
                        (quit "Bad sequence" Node) )
                     (setq X (car Y))
                     (inc 'N)
                     (and
                        Fun
                        (not (Fun (car Y) (cddr Y)))
                        (quit "Check fail" Node) )
                     (setq L (cadr Y)) )
                  (and L (recurse L)) ) )
            (wipe Node) ) )
      N ) )


================================================
FILE: lib/canvas.js
================================================
/* 21jan25 Software Lab. Alexander Burger */

function renderCanvas(cvs, lst) {
   var ctx = cvs.getContext("2d");
   var cmd, i, j;

   if (lst) {
      for (i = 0; i < lst.length; ++i) {
         switch ((cmd = lst[i])[0]) {  // Sync with "@lib/canvas.l"
         /*** Functions ***/
         case 1:  // (csFont Str)
            ctx.font = cmd[1];
         case 2:  // (csFillText Str X Y)
            ctx.fillText(cmd[1], cmd[2], cmd[3]);
            break;
         case 3:  // (csStrokeLine X1 Y1 X2 Y2)
            ctx.beginPath();
            ctx.moveTo(cmd[1], cmd[2]);
            ctx.lineTo(cmd[3], cmd[4]);
            ctx.closePath();
            ctx.stroke();
            break;
         case 4:  // (csClearRect X Y DX DY)
            ctx.clearRect(cmd[1], cmd[2], cmd[3], cmd[4]);
            break;
         case 5:  // (csStrokeRect X Y DX DY)
            ctx.strokeRect(cmd[1], cmd[2], cmd[3], cmd[4]);
            break;
         case 6:  // (csFillRect X Y DX DY)
            ctx.fillRect(cmd[1], cmd[2], cmd[3], cmd[4]);
            break;
         case 7:  // (csBeginPath)
            ctx.beginPath();
            break;
         case 8:  // (csClosePath)
            ctx.closePath();
            break;
         case 9:  // (csMoveTo X Y)
            ctx.moveTo(cmd[1], cmd[2]);
            break;
         case 10:  // (csLineTo X Y)
            ctx.lineTo(cmd[1], cmd[2]);
            break;
         case 11:  // (csBezierCurveTo X1 Y1 X2 Y2 X Y)
            ctx.bezierCurveTo(cmd[1], cmd[2], cmd[3], cmd[4], cmd[5], cmd[6]);
            break;
         case 12:  // (csQuadraticCurveTo X1 Y1 X2 Y2)
            ctx.quadraticCurveTo(cmd[1], cmd[2], cmd[3], cmd[4]);
            break;
         case 13:  // (csLine X1 Y1 X2 Y2)
            ctx.moveTo(cmd[1], cmd[2]);
            ctx.lineTo(cmd[3], cmd[4]);
            break;
         case 14:  // (csRect X Y DX DY)
            ctx.rect(cmd[1], cmd[2], cmd[3], cmd[4]);
            break;
         case 15:  // (csArc X Y R A B F)
            ctx.arc(cmd[1], cmd[2], cmd[3], cmd[4], cmd[5], cmd[6]);
            break;
         case 16:  // (csStroke)
            ctx.stroke();
            break;
         case 17:  // (csFill)
            ctx.fill();
            break;
         case 18:  // (csClip)
            ctx.clip();
            break;
         case 19:  // (csDef Key [DX DY Lst])
            if (!cvs.pre)
               cvs.pre = new Array();
            var buf = cvs.pre[cmd[1]] = document.createElement('canvas');
            if (cmd[2]) {
               buf.width = cmd[2];
               buf.height = cmd[3];
               renderCanvas(buf, cmd[4]);
            }
            else {
               buf.width = cvs.width;
               buf.height = cvs.height;
               buf.getContext("2d").drawImage(cvs, 0, 0);
            }
            break;
         case 20:  // (csDraw Key X Y)
            var buf = cvs.pre[cmd[1]];
            ctx.clearRect(cmd[2], cmd[3], buf.width, buf.height);
            ctx.drawImage(buf, cmd[2], cmd[3]);
            break;
         case 21:  // (csDrawDots DX DY Lst)
            if (cmd[3])
               for (j = 0; j < cmd[3].length; j += 2)
                  ctx.fillRect(cmd[3][j], cmd[3][j+1], cmd[1], cmd[2]);
            break;
         case 22:  // (csDrawImage Img X Y Lst DX DY [Key])
            var img;

            if (cmd[7]  &&  (img = (cvs.img || (cvs.img = new Array()))[cmd[7]])) {
               if (img.lst.length > 0)
                  img.lst.push([cmd[2], cmd[3], cmd[4], cmd[5], cmd[6]]);
               else {
                  if (cmd[5])
                     ctx.drawImage(img, cmd[2], cmd[3], cmd[5], cmd[6]);
                  else
                     ctx.drawImage(img, cmd[2], cmd[3]);
                  if (cmd[4])
                     renderCanvas(cvs, cmd[4]);
               }
            }
            else {
               (img = new Image()).src = cmd[1];
               img.lst = [[cmd[2], cmd[3], cmd[4], cmd[5], cmd[6]]];
               (function (img) {
                  img.onload = function() {
                     do {
                        var a = img.lst.shift();
                        if (a[3])
                           ctx.drawImage(img, a[0], a[1], a[3], a[4]);
                        else
                           ctx.drawImage(img, a[0], a[1]);
                        if (a[2])
                           renderCanvas(cvs, a[2]);
                     } while (img.lst.length > 0);
                  } } )(img);
               if (cmd[7])
                  cvs.img[cmd[7]] = img;
            }
            break;
         case 23:  // (csTranslate X Y)
            ctx.translate(cmd[1], cmd[2]);
            break;
         case 24:  // (csRotate A)
            ctx.rotate(cmd[1]);
            break;
         case 25:  // (csScale X Y)
            ctx.scale(cmd[1], cmd[2]);
            break;
         case 26:  // (csSave)
            ctx.save();
            break;
         case 27:  // (csRestore)
            ctx.restore();
            break;
         /*** Variables ***/
         case 28:  // (csCursor Lst)
            cvs.curs = cmd[1];
            break;
         case 29:  // (csFillStyle V)
            ctx.fillStyle = cmd[1];
            break;
         case 30:  // (csStrokeStyle V)
            ctx.strokeStyle = cmd[1];
            break;
         case 31:  // (csGlobalAlpha V)
            ctx.globalAlpha = cmd[1];
            break;
         case 32:  // (csLineWidth V)
            ctx.lineWidth = cmd[1];
            break;
         case 33:  // (csLineCap V)
            ctx.lineCap = cmd[1];
            break;
         case 34:  // (csLineJoin V)
            ctx.lineJoin = cmd[1];
            break;
         case 35:  // (csMiterLimit V)
            ctx.miterLimit = cmd[1];
            break;
         case 36:  // (csGlobalCompositeOperation V)
            ctx.globalCompositeOperation = cmd[1];
            break;
         case 37:  // (csDelay N)
            cvs.dly = cmd[1];
            break;
         case 38:  // (csPost)
            cvs.post = true;
            break;
         }
      }
   }
}

function drawCanvas(id, dly) {
   var req = new XMLHttpRequest();
   var url = document.getElementsByTagName("BASE")[0].href + SesId + "!jsDraw?" + id + "&+" + dly;
   var flg = arguments[2];

   for (var i = 2; i < arguments.length; ++i)
      if (typeof arguments[i] === "number")
         url += "&+" + arguments[i];
      else
         url += "&" + arguments[i];
   try {req.open("POST", url);}
   catch (e) {return true;}
   req.responseType = "arraybuffer";
   req.onload = function() {
      var ele = document.getElementById(id);

      ele.dly = dly;
      renderCanvas(ele, plio(new Uint8Array(req.response)));
      if (ele.post) {
         ele.post = false;
         while (ele = ele.parentNode) {
            if (ele.tagName == "FORM") {
               post(ele, false, null, null);
               break;
            }
         }
      }
      if (!flg) {
         if (ele.auto)
            clearTimeout(ele.auto);
         if (ele.dly == 0)
            drawCanvas(id, 0);
         else if (ele.dly > 0)
            ele.auto = setTimeout(function() {drawCanvas(id, dly)}, ele.dly);
      }
      ele.dly = dly;
   };
   try {req.send(null);}
   catch (e) {
      req.abort();
      return true;
   }
   return false;
}

function doCsDn(cvs, x, y) {
   var r = cvs.getBoundingClientRect();

   cvs.csDn = true;
   cvs.csDnX = x - r.left;
   cvs.csDnY = y - r.top;
   cvs.csMv = false;
   return false;
}

function csMouseDn(cvs, event) {
   return doCsDn(cvs, event.clientX, event.clientY);
}

function csTouchDn(cvs, event) {
   return doCsDn(cvs, event.touches[0].clientX, event.touches[0].clientY);
}

function doCsMv(cvs, x, y) {
   var r = cvs.getBoundingClientRect();

   if (cvs.curs)
      csCursor(cvs, x - r.left, y - r.top);
   if (!cvs.csDn)
      return true;
   if (!cvs.csMv)
      cvs.csMv = [x, y];
   else {
      if (Array.isArray(cvs.csMv)) {
         if (drawCanvas(cvs.id, cvs.dly, 0, cvs.csDnX, cvs.csDnY, cvs.csMv[0] - r.left, cvs.csMv[1] - r.top))
            return true;
         cvs.csMv = true;
      }
      if (drawCanvas(cvs.id, cvs.dly, -1, cvs.csDnX, cvs.csDnY, x - r.left, y - r.top))
         return true;
   }
   return false;
}

function csMouseMv(cvs, event) {
   return doCsMv(cvs, event.clientX, event.clientY);
}

function csTouchMv(cvs, event) {
   if (event.targetTouches.length == 1) {
      event.preventDefault();
      return doCsMv(cvs, event.touches[0].clientX, event.touches[0].clientY);
   }
   return false;
}

function csMouseUp(cvs) {
   cvs.csDn = false;
   if (cvs.clicked) {
      clearTimeout(cvs.clicked);
      cvs.clicked = null;
      return drawCanvas(cvs.id, cvs.dly, 2, cvs.csDnX, cvs.csDnY);
   }
   if (cvs.csMv)
      return drawCanvas(cvs.id, cvs.dly, "$T");
   cvs.clicked = setTimeout(
      function() {
         cvs.clicked = null;
         drawCanvas(cvs.id, cvs.dly, 1, cvs.csDnX, cvs.csDnY);
      },
      200 );
   return false;
}

function csTouchEnd(cvs) {
   cvs.csDn = false;
   if (cvs.csMv)
      return drawCanvas(cvs.id, cvs.dly, "$T");
   return false;
}

function csLeave(cvs) {
   cvs.style.cursor = "";
   cvs.csDn = cvs.csMv = false;
   if (cvs.clicked) {
      clearTimeout(cvs.clicked);
      cvs.clicked = null;
   }
   return drawCanvas(cvs.id, cvs.dly, "$T");
}

function csCursor(cvs, x, y) {
   var a;

   for (var i = 0; i < cvs.curs.length; ++i) {
      if (typeof (a = cvs.curs[i]) === "string") {
         cvs.style.cursor = a;
         return;
      }
      for (var j = 1; j < a.length; j += 4) {
         if (a[j] <= x && x <= a[j+2] && a[j+1] <= y && y <= a[j+3]) {
            cvs.style.cursor = a[0];
            return;
         }
      }
   }
   cvs.style.cursor = "";
}


================================================
FILE: lib/canvas.l
================================================
# 19sep23 Software Lab. Alexander Burger

(allow "!jsDraw" )
(push1 '*JS (allow "@lib/plio.js") (allow "@lib/canvas.js"))

# Draw   (drawCanvas Id Dly [T])
# Click  (drawCanvas Id Dly 1 X Y)
# Double (drawCanvas Id Dly 2 X Y)
# Start  (drawCanvas Id Dly 0 X Y X2 Y2)
# Move   (drawCanvas Id Dly -1 X Y X2 Y2)
(de jsDraw (Id Dly F X Y X2 Y2)
   (http1 "application/octet-stream" 0)
   (let Lst (drawCanvas Id Dly F X Y X2 Y2)
      (prinl "Content-Length: " (bytes Lst) "\r\n\r")
      (pr Lst) ) )

# Canvas Commands
(for (Opc . L)
   (quote  # In sync with "@lib/canvas.js"
      ### Functions ###
      (csFont Str)
      (csFillText Str X Y)
      (csStrokeLine X1 Y1 X2 Y2)
      (csClearRect X Y DX DY)
      (csStrokeRect X Y DX DY)
      (csFillRect X Y DX DY)
      (csBeginPath)
      (csClosePath)
      (csMoveTo X Y)
      (csLineTo X Y)
      (csBezierCurveTo X1 Y1 X2 Y2 X Y)
      (csQuadraticCurveTo X1 Y1 X2 Y2)
      (csLine X1 Y1 X2 Y2)
      (csRect X Y DX DY)
      (csArc X Y R A B F)
      (csStroke)
      (csFill)
      (csClip)
      (csDef Key DX DY Lst)
      (csDraw Key X Y)
      (csDrawDots DX DY Lst)
      (csDrawImage Img X Y Lst DX DY Key)
      (csTranslate X Y)
      (csRotate A)
      (csScale X Y)
      (csSave)
      (csRestore)
      ### Variables ###
      (csCursor Lst)
      (csFillStyle V)
      (csStrokeStyle V)
      (csGlobalAlpha V)
      (csLineWidth V)
      (csLineCap V)
      (csLineJoin V)
      (csMiterLimit V)
      (csGlobalCompositeOperation V)
      (csDelay N)
      (csPost) )
   (def (car L)
      (list
         (cdr L)
         (list 'link
            (if (cdr L)
               (cons 'list Opc @)
               (list Opc) ) ) ) ) )

(de  (Id DX DY Alt)
   (prin
      "" Alt "" ) )

(de  (Id DX DY Dly Post)
   (unless (str? Id)
      (put Id 'home *Top)
      (setq Id (pack "$" Id)) )
   ( Id DX DY)
   (if Post
      ( "Post = function() {drawCanvas('" Id "', " Dly ")}; Post()")
      ( "drawCanvas('" Id "', " Dly ")") ) )

### Debug ###
`*Dbg

(noLint 'drawCanvas)


================================================
FILE: lib/clang.l
================================================
# 19may21 Software Lab. Alexander Burger

(de clang (Nm L . Lst)
   (out (tmp Nm ".c") (here "/**/"))
   (apply call L "clang" "-o" (tmp Nm)
      "-fPIC" "-O" "-w" "-shared" (tmp Nm ".c"))
   (for L Lst
      (def (car L)
         (list
            (cadr L)
            (cons 'native (tmp Nm) (name (caddr L)) (cdddr L)) ) )
      (when (== '@ (fin (cadr L)))
         (push (cdaar L) 'pass) ) ) )


================================================
FILE: lib/complete.l
================================================
# 29dec20 Software Lab. Alexander Burger

(if (opt)
   (let "Lst" (chop @)
      (if (= "-" (car "Lst"))
         (let "Pre" (++ "Lst")
            (when (member (car "Lst") '("\"" "'"))
               (setq "Pre" (++ "Lst")) )
            (let "Str" (pack "Lst")
               (for "Sym" (all)
                  (and
                     (pre? "Str" "Sym")
                     (getd "Sym")
                     (prinl "Pre" "Sym" (and (= "-" "Pre") " ")) ) ) ) )
         (let ("Path" (rot (split "Lst" "/"))  "Str" (pack (car "Path")))
            (setq "Path" (and (cdr "Path") (pack (glue "/" @) "/")))
            (for "Sym" (dir "Path" T)
               (when (pre? "Str" "Sym")
                  (prinl "Path"
                     (replace (chop "Sym") " " "\\ ")
                     (if (=T (car (info (pack "Path" "Sym"))))
                        "/"
                        " " ) ) ) ) ) ) )
   (prinl '+) )


================================================
FILE: lib/db.l
================================================
# 12apr26 Software Lab. Alexander Burger

# *Jnl *Blob

### Tree Access ###
(de tree (Var Cls Hook)
   (cons Var
      (if Hook
         (cons Cls Hook)
         Cls ) ) )

(de genKey (Var Cls Hook Min Max)
   (if (lt0 Max)
      (let K (minKey (tree Var Cls Hook) Min Max)
         (if (lt0 K) (dec K) (or Max -1)) )
      (let K (maxKey (tree Var Cls Hook) Min Max)
         (if (gt0 K) (inc K) (or Min 1)) ) ) )

(de useKey (Var Cls Hook)
   (let (Tree (tree Var Cls Hook)  Max (* 2 (inc (count Tree)))  N)
      (while (fetch Tree (setq N (rand 1 Max))))
      N ) )

(de genStrKey (Str Var Cls Hook)
   (while (fetch (tree Var Cls Hook) Str)
      (setq Str (pack "# " Str)) )
   Str )

(de ubZval (Lst X)
   (let (Res 0  P 1  Q 1)
      (while (find '((N) (>= N Q)) Lst)
         (for N Lst
            (and
               N
               (bit? Q N)
               (setq Res (| Res P)) )
            (setq P (>> -1 P)) )
         (setq Q (>> -1 Q)) )
      (cons Res X) ) )


### Relations ###
(class +relation)

(dm T (Var)
   (=: cls *Class)
   (=: var Var) )

# Type check
(dm mis> (Val Obj))  #> lst
(dm ele> (Val))

# Value present?
(dm has> (Val X)  #> flg
   (= Val X) )

# Set value
(dm put> (Obj Old New)
   New )

# Delete value
(dm del> (Obj Old Val)
   (and (<> Old Val) Val) )

# Maintain relations
(dm rel> (Obj Old New))

(dm rel?> (Obj Val)
   T )

(dm lose> (Obj Val))

(dm keep> (Obj Val))

# Search
(dm iter> (X Lst)
   (cons
      (list (: cls Dbf 1))
      (let @Cls (: cls)
         (curry (@Cls) (P)
            (loop
               (NIL (and (car P) (set P (seq (car P)))))
               (T (and (isa '@Cls @) (not (; @ T)))
                  (car P) ) ) ) ) ) )

(dm match> (X Val Obj)
   (cond
      ((not X) Val)
      ((str? X) (pre? X Val))
      ((atom X) (and (= X Val) Val))
      ((>= (cdr X) (car X))
         (and (>= (cdr X) Val (car X)) Val) )
      ((>= (car X) Val (cdr X)) Val) ) )

# Finalizer
(dm zap> (Obj Val))


(class +Any +relation)

# (+Bag) (cls ..) (..) (..)
(class +Bag +relation)

(dm T (Var Lst)
   (=: bag
      (mapcar
         '((L)
            (prog1
               (new (car L) Var (cdr L))
               (and (get @ 'hook) (=: hook T)) ) )
         Lst ) )
   (super Var) )

(dm mis> (Val Obj)
   (ifn (lst? Val)
      "Not a Bag"
      (pick
         '((This V)
            (mis> This V Obj
               (when (: hook)
                  (get (if (sym? @) Obj Val) (: hook)) ) ) )
         (: bag)
         Val ) ) )

(dm ele> (Val)
   (and Val
      (or
         (atom Val)
         (find 'ele> (: bag) Val) ) ) )

(dm has> (Val X)
   (when Val
      (if (atom Val)
         (find 'has> (: bag) Val X)
         (fully 'has> (: bag) Val X) ) ) )

(dm put> (Obj Old New)
   (trim
      (mapcar
         '((X O N) (put> X Obj O N))
         (: bag)
         Old
         New ) ) )

(dm rel> (Obj Old New)
   (when Old
      (mapc
         '((This O)
            (rel> This Obj O NIL
               (when (: hook)
                  (get (if (sym? @) Obj Old) (: hook)) ) ) )
         (: bag)
         Old ) )
   (when New
      (mapc
         '((This N)
            (rel> This Obj NIL N
               (when (: hook)
                  (get (if (sym? @) Obj New) (: hook)) ) ) )
         (: bag)
         New ) ) )

(dm rel?> (Obj Val)
   (fully
      '((This V)
         (or
            (not V)
            (rel?> This Obj V
               (when (: hook)
                  (get (if (sym? @) Obj Val) (: hook)) ) ) ) )
      (: bag)
      Val ) )

(dm lose> (Obj Val)
   (mapc
      '((This V)
         (lose> This Obj V
            (when (: hook)
               (get (if (sym? @) Obj Val) (: hook)) ) ) )
      (: bag)
      Val ) )

(dm keep> (Obj Val)
   (mapc
      '((This V)
         (keep> This Obj V
            (when (: hook)
               (get (if (sym? @) Obj Val) (: hook)) ) ) )
      (: bag)
      Val ) )

(dm iter> (X Lst)
   (if
      (find
         '((B) (isa '+index B))
         (: bag) )
      (iter> @ X Lst)
      (super X Lst) ) )

(dm match> (X Val Obj)
   (pick 'match> (: bag)
      (circ X)
      Val
      (circ Obj) ) )


(class +Bool +relation)

(dm mis> (Val Obj)
   (and Val (nT Val) ,"Boolean input expected") )


# (+Number) [num]
(class +Number +relation)

(dm T (Var Lst)
   (=: scl (car Lst))
   (super Var) )

(dm mis> (Val Obj)
   (and Val (not (num? Val)) ,"Numeric input expected") )


# (+Date)
(class +Date +Number)

(dm T (Var Lst)
   (super Var (cons NIL Lst)) )


# (+Time)
(class +Time +Number)

(dm T (Var Lst)
   (super Var (cons NIL Lst)) )


# (+Symbol)
(class +Symbol +relation)

(dm mis> (Val Obj)
   (unless (sym? Val)
      ,"Symbolic type expected" ) )


# (+String)
(class +String +Symbol)

(dm mis> (Val Obj)
   (and Val (not (str? Val)) ,"String type expected") )


(private) canQuery

# (+Link) typ
(class +Link +relation)

(dm T (Var Lst)
   (unless (=: type (car Lst))
      (quit "No Link" Var) )
   (super Var) )

(de canQuery (Val)
   (and
      (pair Val)
      (pair (car Val))
      (fully
         '((L)
            (find
               '((Cls)
                  (get Cls
                     ((if (lst? (car L)) cadr car) L) ) )
               (: type) ) )
         Val ) ) )

(dm mis> (Val Obj)
   (and
      Val
      (nor
         (isa (: type) Val)
         (canQuery Val) )
      ,"Type error" ) )


# (+Joint) var typ [put get]
(class +Joint +Link)

(dm T (Var Lst)
   (=: slot (car Lst))
   (=: put (caddr Lst))
   (=: get (cadddr Lst))
   (super Var (cdr Lst)) )

(dm mis> (Val Obj)
   (and
      Val
      (nor
         (canQuery Val)
         (and
            (isa (: type) Val)
            (with (meta Val (: slot))
               (or
                  (isa '+Link This)
                  (find
                     '((B) (isa '+Link B))
                     (: bag) ) ) ) ) )
      ,"Type error" ) )

(dm rel> (Obj Old New)
   (and Old
      (del> Old (: slot)
         (if (: get)
            (@ Obj (get Old (: slot)))
            Obj ) ) )
   (and New
      (not (get Obj T))
      (not (has> New (: slot) Obj))
      (put> New (: slot)
         (if (: put) (@ Obj) Obj) ) ) )

(dm rel?> (Obj Val)
   (let X (get Val (: slot))
      (cond
         ((atom X) (== Obj X))
         ((: get) (@ Obj X))
         (T (memq Obj X)) ) ) )

(dm lose> (Obj Val)
   (when Val
      (put Val (: slot)
         (del> (meta Val (: slot))
            Obj
            (get Val (: slot))
            (if (: put) (@ Obj) Obj) ) ) ) )

(dm keep> (Obj Val)
   (when Val
      (put Val (: slot)
         (put> (meta Val (: slot))
            Obj
            (get Val (: slot))
            (if (: put) (@ Obj) Obj) ) ) ) )


# +Link or +Joint prefix
(class +Hook)

(dm rel> (Obj Old New Hook)
   (let L
      (extract
         '((X)
            (and (atom X) (setq X (cons T X)))
            (and
               (or
                  (== (: var) (meta Obj (cdr X) 'hook))
                  (find
                     '((B) (== (: var) (get B 'hook)))
                     (meta Obj (cdr X) 'bag) ) )
               X ) )
         (getl Obj) )
      (for X L
         (rel> (meta Obj (cdr X)) Obj (car X) NIL (or Old *DB))
         (rel> (meta Obj (cdr X)) Obj NIL (car X) (or New *DB)) ) )
   (extra Obj Old New Hook) )


# +Index prefix
(class +Hook2)

(dm rel> (Obj Old New Hook)
   (extra Obj Old New *DB)
   (when (or (and Hook (n== Hook *DB)) (and (: hook) (get Obj @)))
      (extra Obj Old New Hook) ) )

(dm lose> (Obj Val Hook)
   (extra Obj Val *DB)
   (when (or (and Hook (n== Hook *DB)) (and (: hook) (get Obj @)))
      (extra Obj Val Hook) ) )

(dm keep> (Obj Val Hook)
   (extra Obj Val *DB)
   (when (or (and Hook (n== Hook *DB)) (and (: hook) (get Obj @)))
      (extra Obj Val Hook) ) )


# (+Blob)
(class +Blob +relation)

(de blob (Obj Var)
   (pack *Blob (glue "/" (chop Obj)) "." Var) )

(dm put> (Obj Old New)
   (and
      New
      (dirname (blob Obj))
      (call "mkdir" "-p" @) )
   (if (flg? New)
      New
      (in New (out (blob Obj (: var)) (echo)))
      T ) )

(dm zap> (Obj Val)
   (and Val (%@ "unlink" NIL (blob Obj (: var)))) )


### Index classes ###
(private) (idxRel? relAux)

(class +index)

(dm T (Var Lst)
   (=: hook (car Lst))
   (extra Var (cdr Lst)) )

(dm rel?> (Obj Val Hook))


# (+Key +relation) [hook]
(class +Key +index)

(dm mis> (Val Obj Hook)
   (or
      (extra Val Obj Hook)
      (and
         Val
         (not (has> Obj (: var) Val))
         (fetch
            (tree (: var) (: cls) (or Hook (and (: hook) (get Obj @))))
            Val )
         ,"Not unique" ) ) )

(dm rel> (Obj Old New Hook)
   (let Tree (tree (: var) (: cls) (or Hook (and (: hook) (get Obj @))))
      (and Old
         (= Obj (fetch Tree Old))
         (store Tree Old NIL (: dbf)) )
      (and New
         (not (get Obj T))
         (not (fetch Tree New))
         (store Tree New Obj (: dbf)) ) )
   (extra Obj Old New Hook) )

(dm rel?> (Obj Val Hook)
   (== Obj
      (fetch
         (tree (: var) (: cls) (or Hook (and (: hook) (get Obj @))))
         Val ) ) )

(dm lose> (Obj Val Hook)
   (store
      (tree (: var) (: cls) (or Hook (and (: hook) (get Obj @))))
      Val NIL (: dbf) )
   (extra Obj Val Hook) )

(dm keep> (Obj Val Hook)
   (store
      (tree (: var) (: cls) (or Hook (and (: hook) (get Obj @))))
      Val Obj (: dbf) )
   (extra Obj Val Hook) )

(dm iter> (X Lst)
   (let Tree (tree (: var) (: cls) (caddr Lst))
      (cons
         (nond
            ((atom X)
               (nond
                  ((str? (car X))
                     (init Tree (car X) (cdr X)) )
                  ((>= (cdr X) (car X))
                     (init Tree (pack (car X) `(char T)) (cdr X)) )
                  (NIL
                     (init Tree (car X) (pack (cdr X) `(char T))) ) ) )
            ((str? X) (init Tree X X))
            (NIL (init Tree X (pack X `(char T)))) )
         (let @Cls (cadr Lst)
            (curry (@Cls) (Q)
               (loop
                  (NIL (step Q))
                  (T (isa '@Cls @) @) ) ) ) ) ) )


# (+Ref +relation) [hook]
(class +Ref +index)

(dm rel> (Obj Old New Hook)
   (let
      (Tree (tree (: var) (: cls) (or Hook (and (: hook) (get Obj @))))
         Aux (mapcar '((S) (get Obj S)) (: aux)) )
      (when Old
         (let Key (cons Old Aux)
            (store Tree
               (if (: ub)
                  (ubZval Key Obj)
                  (append Key Obj) )
               NIL
               (: dbf) ) ) )
      (and New
         (not (get Obj T))
         (let Key (cons New Aux)
            (store Tree
               (if (: ub)
                  (ubZval Key Obj)
                  (conc Key Obj) )
               Obj
               (: dbf) ) ) ) )
   (extra Obj Old New Hook) )

(dm rel?> (Obj Val Hook)
   (let Key (cons Val (mapcar '((S) (get Obj S)) (: aux)))
      (== Obj
         (fetch
            (tree (: var) (: cls) (or Hook (and (: hook) (get Obj @))))
            (if (: ub)
               (ubZval Key Obj)
               (append Key Obj) ) ) ) ) )

(dm lose> (Obj Val Hook)
   (let Key (cons Val (mapcar '((S) (get Obj S)) (: aux)))
      (store
         (tree (: var) (: cls) (or Hook (and (: hook) (get Obj @))))
         (if (: ub)
            (ubZval Key Obj)
            (conc Key Obj) )
         NIL
         (: dbf) ) )
   (extra Obj Val Hook) )

(dm keep> (Obj Val Hook)
   (let Key (cons Val (mapcar '((S) (get Obj S)) (: aux)))
      (store
         (tree (: var) (: cls) (or Hook (and (: hook) (get Obj @))))
         (if (: ub)
            (ubZval Key Obj)
            (conc Key Obj) )
         Obj
         (: dbf) ) )
   (extra Obj Val Hook) )

(dm iter> (X Lst @Flg)
   (let Tree (tree (: var) (: cls) (caddr Lst))
      (cons
         (nond
            (X (init Tree NIL T))
            ((atom X)
               (nond
                  ((str? (car X))
                     (if (>= (cdr X) (car X))
                        (init Tree
                           (cons (car X))
                           (cons (cdr X) T) )
                        (init Tree
                           (cons (car X) T)
                           (cons (cdr X)) ) ) )
                  ((>= (cdr X) (car X))
                     (init Tree
                        (cons (pack (car X) `(char T)) T)
                        (cons (cdr X)) ) )
                  (NIL
                     (init Tree
                        (cons (car X))
                        (cons (pack (cdr X) `(char T)) T) ) ) ) )
            ((str? X)
               (init Tree (cons X) (cons X T)) )
            (NIL
               (init Tree (cons X) (cons (pack X `(char T)) T)) ) )
         (let @Cls (cadr Lst)
            (curry (@Flg @Cls) (Q)
               (loop
                  (NIL (step Q @Flg))
                  (T (isa '@Cls @) @) ) ) ) ) ) )


# Backing index prefix
(class +Ref2)

(dm T (Var Lst)
   (unless (meta *Class Var)
      (quit "No Ref2" Var) )
   (extra Var Lst) )

(dm rel> (Obj Old New Hook)
   (with (meta (: cls) (: var))
      (let Tree (tree (: var) (: cls))
         (when Old
            (store Tree (cons Old Obj) NIL (: dbf)) )
         (and New
            (not (get Obj T))
            (store Tree (cons New Obj) Obj (: dbf)) ) ) )
   (extra Obj Old New Hook) )

(dm rel?> (Obj Val Hook)
   (and
      (with (meta (: cls) (: var))
         (== Obj
            (fetch
               (tree (: var) (: cls))
               (cons Val Obj) ) ) )
      (extra Obj Val Hook) ) )

(dm lose> (Obj Val Hook)
   (with (meta (: cls) (: var))
      (store (tree (: var) (: cls)) (cons Val Obj) NIL (: dbf)) )
   (extra Obj Val Hook) )

(dm keep> (Obj Val Hook)
   (with (meta (: cls) (: var))
      (store (tree (: var) (: cls)) (cons Val Obj) Obj (: dbf)) )
   (extra Obj Val Hook) )


# (+Idx +relation) [cnt [hook]]
(class +Idx +Ref)

(dm T (Var Lst)
   (=: min (or (car Lst) 3))
   (super Var (cdr Lst)) )

(de idxRel (Obj Old Old2 Olds New New2 News Hook)
   (let
      (Tree (tree (: var) (: cls) (or Hook (and (: hook) (get Obj @))))
         Aux (mapcar '((S) (get Obj S)) (: aux))
         Aux2 (append Aux (cons Obj)) )
      (setq Aux (conc Aux Obj))
      (and Old (store Tree (cons @ Aux) NIL (: dbf)))
      (and Old2 (store Tree (cons @ Aux2) NIL (: dbf)))
      (for S Olds
         (while (nth S (: min))
            (store Tree (cons (pack S) Aux2) NIL (: dbf))
            (++ S) ) )
      (unless (get Obj T)
         (and New (store Tree (cons @ Aux) Obj (: dbf)))
         (and New2 (store Tree (cons @ Aux2) Obj (: dbf)))
         (for S News
            (while (nth S (: min))
               (store Tree (cons (pack S) Aux2) Obj (: dbf))
               (++ S) ) ) ) ) )

(de idxRel? (Obj Val Val2 Vals Hook)
   (let
      (Tree (tree (: var) (: cls) (or Hook (and (: hook) (get Obj @))))
         Aux (mapcar '((S) (get Obj S)) (: aux))
         Aux2 (append Aux (cons Obj)) )
      (setq Aux (conc Aux Obj))
      (and
         (== Obj (fetch Tree (cons Val Aux)))
         (or (not Val2) (== Obj (fetch Tree (cons Val2 Aux2))))
         (fully
            '((S)
               (loop
                  (NIL (nth S (: min)) T)
                  (NIL (== Obj (fetch Tree (cons (pack S) Aux2))))
                  (++ S) ) )
            Vals ) ) ) )

(dm rel> (Obj Old New Hook)
   (idxRel Obj
      Old NIL (split (cdr (chop Old)) " " "\n")
      New NIL (split (cdr (chop New)) " " "\n")
      Hook )
   (extra Obj Old New Hook) )

(dm rel?> (Obj Val Hook)
   (and
      (idxRel? Obj
         Val NIL (split (cdr (chop Val)) " " "\n")
         Hook )
      (extra Obj Val Hook) ) )

(dm lose> (Obj Val Hook)
   (idxRel Obj
      Val NIL (split (cdr (chop Val)) " " "\n")
      NIL NIL NIL
      Hook )
   (extra Obj Val Hook) )

(dm keep> (Obj Val Hook)
   (idxRel Obj
      NIL NIL NIL
      Val NIL (split (cdr (chop Val)) " " "\n")
      Hook )
   (extra Obj Val Hook) )

(dm iter> (X Lst)
   (on *Iter+)
   (super X Lst (not X)) )

(dm match> (X Val Obj)
   (sub? X Val) )


# (+Sn +index) [hook]
(class +Sn)

(dm rel> (Obj Old New Hook)
   (let Tree (tree (: var) (: cls) (or Hook (and (: hook) (get Obj @))))
      (and Old
         (ext:Snx Old)
         (store Tree (cons @ Obj T) NIL (: dbf)) )
      (and New
         (not (get Obj T))
         (ext:Snx New)
         (store Tree (cons @ Obj T) Obj (: dbf)) ) )
   (extra Obj Old New Hook) )

(dm rel?> (Obj Val Hook)
   (and
      (let S (ext:Snx Val)
         (or
            (not S)
            (== Obj
               (fetch
                  (tree (: var) (: cls) (or Hook (and (: hook) (get Obj @))))
                  (cons S Obj T) ) ) ) )
      (extra Obj Val Hook) ) )

(dm lose> (Obj Val Hook)
   (let? S (ext:Snx Val)
      (store
         (tree (: var) (: cls) (or Hook (and (: hook) (get Obj @))))
         (cons S Obj T)
         NIL (: dbf) ) )
   (extra Obj Val Hook) )

(dm keep> (Obj Val Hook)
   (let? S (ext:Snx Val)
      (store
         (tree (: var) (: cls) (or Hook (and (: hook) (get Obj @))))
         (cons S Obj T)
         Obj (: dbf) ) )
   (extra Obj Val Hook) )

(dm iter> (X Lst)
   (on *Iter+)
   (cons
      (list
         (list
            (car (extra X Lst))
            (init (tree (: var) (: cls) (caddr Lst))
               (cons (setq X (ext:Snx X)))
               (cons (pack X `(char T)) T) ) ) )
      (let @Cls (cadr Lst)
         (curry (@Cls) (Q)
            (loop
               (NIL
                  (or
                     (step (caar Q))
                     (and (cdar Q) (shift Q) (step (caar Q))) ) )
               (T (isa '@Cls @) @) ) ) ) ) )

(dm match> (X Val Obj)
   (or
      (extra X Val Obj)
      (and (pre? (ext:Snx X) (ext:Snx Val)) Val) ) )


# (+Fold +index) [hook]
(class +Fold)

(dm has> (Val X)
   (extra Val
      (if (= Val (fold Val)) (fold X) X) ) )

(dm rel> (Obj Old New Hook)
   (extra Obj (fold Old) (fold New) Hook) )

(dm rel?> (Obj Val Hook)
   (let V (fold Val)
      (or (not V) (extra Obj V Hook)) ) )

(dm lose> (Obj Val Hook)
   (extra Obj (fold Val) Hook) )

(dm keep> (Obj Val Hook)
   (extra Obj (fold Val) Hook) )

(dm iter> (X Lst)
   (extra
      (if (pair X)
         (cons (fold (car X)) (fold (cdr X)))
         (fold X) )
      Lst ) )

(dm match> (X Val Obj)
   (when
      (extra
         (if (pair X)
            (cons (fold (car X)) (fold (cdr X)))
            (fold X) )
         (fold Val)
         Obj )
      Val ) )


# (+IdxFold +relation) [cnt [hook]]
(class +IdxFold +Ref)

(dm T (Var Lst)
   (=: min (or (car Lst) 3))
   (super Var (cdr Lst)) )

(dm rel> (Obj Old New Hook)
   (idxRel Obj
      Old (fold Old)
      (extract '((L) (extract fold L))
         (split (cdr (chop Old)) " " "\n") )
      New (fold New)
      (extract '((L) (extract fold L))
         (split (cdr (chop New)) " " "\n") )
      Hook )
   (extra Obj Old New Hook) )

(dm rel?> (Obj Val Hook)
   (and
      (let V (fold Val)
         (or (not V)
            (idxRel? Obj
               Val V
               (extract '((L) (extract fold L))
                  (split (cdr (chop Val)) " " "\n") )
               Hook ) ) )
      (extra Obj Val Hook) ) )

(dm lose> (Obj Val Hook)
   (idxRel Obj
      Val (fold Val)
      (extract '((L) (extract fold L))
         (split (cdr (chop Val)) " " "\n") )
      NIL NIL NIL
      Hook )
   (extra Obj Val Hook) )

(dm keep> (Obj Val Hook)
   (idxRel Obj
      NIL NIL NIL
      Val (fold Val)
      (extract '((L) (extract fold L))
         (split (cdr (chop Val)) " " "\n") )
      Hook )
   (extra Obj Val Hook) )

(dm iter> (X Lst)
   (on *Iter+)
   (super (fold X) Lst (not X)) )

(dm match> (X Val Obj)
   (and (sub? (fold X) (fold Val)) Val) )


# (+Aux) lst
(class +Aux)

(dm T (Var Lst)
   (=: aux (car Lst))
   (with *Class
      (for A (car Lst)
         (if (asoq A (: Aux))
            (queue '@ Var)
            (queue (:: Aux) (list A Var)) ) ) )
   (extra Var (cdr Lst)) )

(de relAux (Obj Var Old Lst)
   (let New (get Obj Var)
      (put Obj Var Old)
      (for A Lst
         (rel> (meta Obj A) Obj (get Obj A) NIL) )
      (put Obj Var New)
      (for A Lst
         (rel> (meta Obj A) Obj NIL (get Obj A)) ) ) )

(dm iter> (X Lst)
   (if (or (atom X) (atom (car X)))
      (extra X Lst)
      (let Tree (tree (: var) (: cls) (caddr Lst))
         (cons
            (if (>= (cdr X) (car X))
               (init Tree
                  (car X)
                  (append (cdr X) T) )
               (init Tree
                  (append (car X) T)
                  (cdr X) ) )
            (let @Cls (cadr Lst)
               (curry (@Cls) (Q)
                  (loop
                     (NIL (step Q))
                     (T (isa '@Cls @) @) ) ) ) ) ) ) )

(dm match> (X Val Obj)
   (if (or (atom X) (atom (car X)))
      (extra X Val Obj)
      (setq Val
         (cons Val
            (mapcar '((S) (get Obj S)) (: aux)) ) )
      (when
         (if (>= (cdr X) (car X))
            (>= (append (cdr X) T) Val (car X))
            (>= (append (car X) T) Val (cdr X)) )
         Val ) ) )


# UB-Tree (+Aux prefix)
(class +UB)

(dm T (Var Lst)
   (=: ub T)
   (extra Var Lst) )

(dm has> (Val X)
   (and Val
      (or
         (extra Val X)
         (extra
            (let (N (inc (length (: aux)))  M 1  V 0)
               (while (gt0 Val)
                  (and (bit? 1 Val) (inc 'V M))
                  (setq M (>> -1 M)  Val (>> N Val)) )
               V )
            X ) ) ) )

(dm iter> (X Lst)
   (cons
      (init (tree (: var) (: cls) (caddr Lst))
         (ubZval (car X))
         (ubZval (cdr X) T) )
      (let @Cls (cadr Lst)
         (curry (@Cls) (Q)
            (loop
               (NIL (step Q))
               (T (isa '@Cls @) @) ) ) ) ) )


### Relation prefix classes ###
(class +Dep)

(dm T (Var Lst)
   (=: dep (car Lst))
   (extra Var (cdr Lst)) )

(dm rel> (Obj Old New Hook)
   (unless New
      (for Var (: dep)
         (let? V (get Obj Var)
            (rel> (meta Obj Var) Obj V
               (put Obj Var (put> (meta Obj Var) Obj V NIL)) )
            (when (asoq Var (meta Obj 'Aux))
               (relAux Obj Var V (cdr @)) )
            (upd> Obj Var V) ) ) )
   (extra Obj Old New Hook) )


(class +List)

(dm mis> (Val Obj)
   (ifn (lst? Val)
      "Not a List"
      (pick '((V) (extra V Obj)) Val) ) )

(dm ele> (Val)
   (and Val (or (atom Val) (find extra Val))) )

(dm has> (Val X)
   (when Val
      (or
         (= Val X)
         (find '((X) (extra Val X)) X)
         (loop
            (NIL
               (let (V (++ Val)  Y (++ X))
                  (or (= V Y) (extra V Y)) ) )
            (NIL (or Val X) T)
            (T (xor Val X)) ) ) ) )

(dm put> (Obj Old New)
   (if (ele> This New)
      (cons (extra Obj Old New) Old)
      (mapcar
         '((N O) (extra Obj O N))
         New
         Old ) ) )

(dm del> (Obj Old Val)
   (and
      (<> Old Val)
      (delete Val Old T) ) )

(dm rel> (Obj Old New Hook)
   (if (or (ele> This Old) (ele> This New))
      (extra Obj Old New Hook)
      (for O Old
         (if (: bag)
            (for (I . This) @
               (let V (get O I)
                  (unless (find '((L) (= V (get L I))) New)
                     (rel> This Obj V NIL
                        (when (: hook)
                           (get (if (sym? @) Obj O) (: hook)) ) ) ) ) )
            (unless (member O New)
               (extra Obj O NIL Hook) ) ) )
      (for N New
         (if (: bag)
            (for (I . This) @
               (let V (get N I)
                  (unless (find '((L) (= V (get L I))) Old)
                     (rel> This Obj NIL V
                        (when (: hook)
                           (get (if (sym? @) Obj N) (: hook)) ) ) ) ) )
            (unless (member N Old)
               (extra Obj NIL N Hook) ) ) ) ) )

(dm rel?> (Obj Val Hook)
   (for V Val
      (NIL (or (not V) (extra Obj V Hook)))
      T ) )

(dm lose> (Obj Val Hook)
   (if (ele> This Val)
      (extra Obj Val Hook)
      (for V Val
         (extra Obj V Hook) ) ) )

(dm keep> (Obj Val Hook)
   (if (ele> This Val)
      (extra Obj Val Hook)
      (for V Val
         (extra Obj V Hook) ) ) )

(dm iter> (X Lst)
   (on *Iter+)
   (extra X Lst (not X)) )

(dm match> (X Val Obj)
   (pick '((Y) (extra X Y Obj)) Val) )


(class +Need)

(dm mis> (Val Obj)
   (ifn Val
      ,"Input required"
      (extra Val Obj) ) )


(class +Mis)

(dm T (Var Lst)
   (=: mis (car Lst))
   (extra Var (cdr Lst)) )

(dm mis> (Val Obj)
   (or ((: mis) Val Obj) (extra Val Obj)) )


(class +Alt)

(dm T (Var Lst)
   (extra Var (cdr Lst))
   (=: cls (car Lst)) )


(class +Swap)

(dm mis> (Val Obj)
   (extra (if (ext? Val) (val Val) Val) Obj) )

(dm has> (Val X)
   (if (ext? Val)
      (== Val X)
      (extra Val (val X)) ) )

(dm put> (Obj Old New)
   (let N
      (extra
         Obj
         (val Old)
         (if (ext? New) (val @) New) )
      (cond
         ((ext? Old)
            (if (ext? New)
               New
               (set Old N)
               Old ) )
         (N
            (prog1
               (new (or (: dbf 1) 1))
               (set @ N) ) ) ) ) )

(dm del> (Obj Old Val)
   (ifn (ext? Old)
      (extra Obj Old Val)
      (set @ (extra Obj (val Old) Val))
      @ ) )

(dm rel> (Obj Old New Hook)
   (extra
      Obj
      (if (ext? Old) (val @) Old)
      (if (ext? New) (val @) New)
      Hook ) )

(dm rel?> (Obj Val Hook)
   (if (ext? Val)
      (if (val @)
         (extra Obj @ Hook)
         T )
      (extra Obj Val Hook) ) )

(dm lose> (Obj Val Hook)
   (extra Obj (if (ext? Val) (val @) Val) Hook) )

(dm keep> (Obj Val Hook)
   (extra Obj (if (ext? Val) (val @) Val) Hook) )


### Entities ###
(de dbSync (Obj)
   (let *Run NIL
      (while (lock (or Obj *DB))
         (wait 40) )
      (sync) ) )

(class +Entity)

(var Dbf)
(var Aux)

(de incECnt (Obj)
   (let M NIL
      (for Cls (type Obj)
         (recur (Cls)
            (or
               (== '+Entity Cls)
               (memq Cls M)
               (when (isa '+Entity (push 'M Cls))
                  (for C (type @)
                     (recurse C) )
                  (if (get *DB Cls)
                     (inc @)
                     (put *DB Cls (new T 1)) ) ) ) ) ) ) )

(de decECnt (Obj)
  (let M NIL
     (for Cls (type Obj)
        (recur (Cls)
           (or
              (== '+Entity Cls)
              (memq Cls M)
              (when (isa '+Entity (push 'M Cls))
                 (for C (type @)
                    (recurse C) )
                 (and (get *DB Cls) (dec @)) ) ) ) ) ) )

(private) (cloneKey cloneAny)

(dm T @
   (incECnt This)
   (while (args)
      (let A (next)
         (cond
            ((=T A) (put This T T))
            ((atom A) (put> This A (next)))
            (T (put> This (car A) (eval (cdr A)))) ) ) )
   (upd> This (val This)) )

(dm zap> ()
   (for X (getl This)
      (let V (or (atom X) (++ X))
         (and (meta This X) (zap> @ This V)) ) )
   (unless (: T) (decECnt This)) )

(dm url> (Tab Fld))

(dm url1> (Tab Fld) (url> This 1 Fld))
(dm url2> (Tab Fld) (url> This 2 Fld))
(dm url3> (Tab Fld) (url> This 3 Fld))
(dm url4> (Tab Fld) (url> This 4 Fld))
(dm url5> (Tab Fld) (url> This 5 Fld))
(dm url6> (Tab Fld) (url> This 6 Fld))
(dm url7> (Tab Fld) (url> This 7 Fld))
(dm url8> (Tab Fld) (url> This 8 Fld))
(dm url9> (Tab Fld) (url> This 9 Fld))

(dm gui> ())

(dm upd> (X Old))

(dm has> (Var Val)
   (or
      (nor
         Val
         (if2 (get This Var) (ext? @) (val @) @) )
      (has> (meta This Var) Val (get This Var)) ) )

(dm rel?> (Var Val)
   (nond
      (Val T)
      ((meta This Var) T)
      (NIL (rel?> @ This Val)) ) )

(dm put> (Var Val)
   (unless (has> This Var Val)
      (let Old (get This Var)
         (rel> (meta This Var) This Old
            (put This Var (put> (meta This Var) This Old Val)) )
         (when (asoq Var (meta This 'Aux))
            (relAux This Var Old (cdr @)) )
         (upd> This Var Old) ) )
   Val )

(dm put!> (Var Val)
   (unless (has> This Var Val)
      (dbSync)
      (let Old (get This Var)
         (rel> (meta This Var) This Old
            (put This Var (put> (meta This Var) This Old Val)) )
         (when (asoq Var (meta This 'Aux))
            (relAux This Var Old (cdr @)) )
         (upd> This Var Old)
         (commit 'upd) ) )
   Val )

(dm del> (Var Val)
   (when (and Val (has> (meta This Var) Val (get This Var)))
      (let Old (get This Var)
         (rel> (meta This Var) This Old
            (put This Var (del> (meta This Var) This Old Val)) )
         (when (asoq Var (meta This 'Aux))
            (relAux This Var Old (cdr @)) )
         (upd> This Var Old) ) ) )

(dm del!> (Var Val)
   (when (and Val (has> (meta This Var) Val (get This Var)))
      (dbSync)
      (let Old (get This Var)
         (rel> (meta This Var) This Old
            (put This Var (del> (meta This Var) This Old Val)) )
         (when (asoq Var (meta This 'Aux))
            (relAux This Var Old (cdr @)) )
         (upd> This Var Old)
         (commit 'upd) ) ) )

(dm inc> (Var Val)
   (let P (prop This Var)
      (when (num? (car P))
         (let Old @
            (rel> (meta This Var) This Old
               (inc P (or Val 1)) )
            (when (asoq Var (meta This 'Aux))
               (relAux This Var Old (cdr @)) )
            (upd> This Var Old) )
         (car P) ) ) )

(dm inc!> (Var Val)
   (when (num? (get This Var))
      (dbSync)
      (let (P (prop This Var)  Old (car P))
         (rel> (meta This Var) This Old
            (inc P (or Val 1)) )
         (when (asoq Var (meta This 'Aux))
            (relAux This Var Old (cdr @)) )
         (upd> This Var Old)
         (commit 'upd)
         (car P) ) ) )

(dm dec> (Var Val)
   (let P (prop This Var)
      (when (num? (car P))
         (let Old @
            (rel> (meta This Var) This Old
               (dec P (or Val 1)) )
            (when (asoq Var (meta This 'Aux))
               (relAux This Var Old (cdr @)) )
            (upd> This Var Old) )
         (car P) ) ) )

(dm dec!> (Var Val)
   (when (num? (get This Var))
      (dbSync)
      (let (P (prop This Var)  Old (car P))
         (rel> (meta This Var) This Old
            (dec P (or Val 1)) )
         (when (asoq Var (meta This 'Aux))
            (relAux This Var Old (cdr @)) )
         (upd> This Var Old)
         (commit 'upd)
         (car P) ) ) )

(dm mis> (Var Val)
   (mis> (meta This Var) Val This) )

(dm lose1> (Var)
   (when (meta This Var)
      (lose> @ This (get This Var)) ) )

(dm lose> (Lst)
   (unless (: T)
      (for X (getl This)
         (let V (or (atom X) (++ X))
            (and
               (not (memq X Lst))
               (meta This X)
               (lose> @ This V) ) ) )
      (decECnt This)
      (=: T T)
      (upd> This) ) )

(dm lose!> (Lst)
   (dbSync)
   (lose> This Lst)
   (commit 'upd) )

(de lose "Prg"
   (let "Flg" (: T)
      (=: T T)
      (run "Prg")
      (=: T "Flg") ) )

(dm keep1> (Var)
   (when (meta This Var)
      (keep> @ This (get This Var)) ) )

(dm keep> (Lst)
   (when (: T)
      (=: T)
      (incECnt This)
      (for X (getl This)
         (let V (or (atom X) (++ X))
            (and
               (not (memq X Lst))
               (meta This X)
               (keep> @ This V) ) ) )
      (upd> This T) ) )

(dm keep?> (Lst)
   (extract
      '((X)
         (with (and (pair X) (meta This (cdr X)))
            (and
               (isa '+Key This)
               (fetch (tree (: var) (: cls) (and (: hook) (get (up This) @))) (car X))
               (cons (car X) ,"Not unique") ) ) )
      (getl This) ) )

(dm keep!> (Lst)
   (dbSync)
   (keep> This Lst)
   (commit 'upd) )

(de keep "Prg"
   (let "Flg" (: T)
      (=: T)
      (run "Prg")
      (=: T "Flg") ) )

(dm set> (Val)
   (unless (= Val (val This))
      (decECnt This)
      (let Lst (make (maps '((X) (link (fin X))) This))
         (for Var Lst
            (let? Rel (meta This Var)
               (unless (== Rel (meta Val Var))
                  (let V (get This Var)
                     (and (isa '+Swap Rel) (setq V (val V)))
                     (rel> Rel This V (put> Rel This V NIL)) ) ) ) )
         (xchg This 'Val)
         (for Var Lst
            (let? Rel (meta This Var)
               (unless (== Rel (meta Val Var))
                  (let V (get This Var)
                     (rel> Rel This NIL
                        (put> Rel This NIL
                           (if (isa '+Swap Rel) (val V) V) ) ) ) ) ) ) )
      (incECnt This)
      (upd> This (val This) Val) )
   (val This) )

(dm set!> (Val)
   (unless (= Val (val This))
      (dbSync)
      (decECnt This)
      (let Lst (make (maps '((X) (link (fin X))) This))
         (for Var Lst
            (let? Rel (meta This Var)
               (unless (== Rel (meta Val Var))
                  (let V (get This Var)
                     (and (isa '+Swap Rel) (setq V (val V)))
                     (rel> Rel This V (put> Rel This V NIL)) ) ) ) )
         (xchg This 'Val)
         (for Var Lst
            (let? Rel (meta This Var)
               (unless (== Rel (meta Val Var))
                  (let V (get This Var)
                     (rel> Rel This NIL
                        (put> Rel This NIL
                           (if (isa '+Swap Rel) (val V) V) ) ) ) ) ) ) )
      (incECnt This)
      (upd> This (val This) Val)
      (commit 'upd) )
   (val This) )

(dm clone> (Lst)
   (let Obj (new (or (var: Dbf 1) 1) (val This))
      (for X
         (by
            '((X)
               (nand
                  (pair X)
                  (isa '+Hook (meta This (cdr X))) ) )
            sort
            (getl This) )
         (unless (memq (fin X) Lst)
            (if (atom X)
               (ifn (meta This X)
                  (put Obj X T)
                  (let Rel @
                     (put> Obj X T)
                     (when (isa '+Blob Rel)
                        (in (blob This X)
                           (out (blob Obj X) (echo)) )
                        (blob+ Obj X) ) ) )
               (ifn (meta This (cdr X))
                  (put Obj (cdr X) (car X))
                  (let Rel @
                     (cond
                        ((find '((B) (isa '+Key B)) (get Rel 'bag))
                           (let (K @  H (get K 'hook))
                              (put> Obj (cdr X)
                                 (mapcar
                                    '((Lst)
                                       (mapcar
                                          '((B Val)
                                             (if (== B K)
                                                (cloneKey B (cdr X) Val
                                                   (and H (get (if (sym? H) This Lst) H)) )
                                                Val ) )
                                          (get Rel 'bag)
                                          Lst ) )
                                    (car X) ) ) ) )
                        ((isa '+Key Rel)
                           (put> Obj (cdr X)
                              (cloneKey Rel (cdr X) (car X)
                                 (and (get Rel 'hook) (get This @)) ) ) )
                        ((or (not (isa '+Joint Rel)) (isa '+List (meta Obj (cdr X))))
                           (put> Obj (cdr X) (cloneAny (car X) Rel)) ) ) ) ) ) ) )
      Obj ) )

(de cloneKey (Rel Var Val Hook)
   (cond
      ((isa '+Number Rel)
         (genKey Var (get Rel 'cls) Hook) )
      ((isa '+String Rel)
         (genStrKey (pack "# " Val) Var (get Rel 'cls) Hook) ) ) )

(de cloneAny (Val Rel)
   (cond
      ((isa '+Swap Rel) (val Val))
      ((isa '+Bag Rel)
         (if (isa '+List Rel)
            (mapcar
               '((B) (mapcar cloneAny B (; Rel bag)))
               Val )
            (mapcar cloneAny Val (; Rel bag)) ) )
      (T Val) ) )

(dm clone!> ()
   (prog2
      (dbSync)
      (clone> This)
      (commit 'upd) ) )

(de new! ("Typ" . @)
   (prog2
      (dbSync)
      (pass new (or (meta "Typ" 'Dbf 1) 1) "Typ")
      (commit 'upd) ) )

(de set! (Obj Val)
   (unless (= Val (val Obj))
      (dbSync)
      (set Obj Val)
      (commit 'upd) )
   Val )

(de put! (Obj Var Val)
   (unless (= Val (get Obj Var))
      (dbSync)
      (put Obj Var Val)
      (commit 'upd) )
   Val )

(de inc! (Obj Var Val)
   (when (num? (get Obj Var))
      (prog2
         (dbSync)
         (inc (prop Obj Var) (or Val 1))
         (commit 'upd) ) ) )

(de blob! (Obj Var File)
   (put!> Obj Var File)
   (blob+ Obj Var)
   File )

(de blob+ (Obj Var)
   (when *Jnl
      (chdir *Blob
         (%@ "symlink" 'I
            (pack (glue "/" (chop Obj)) "." Var)
            (pack "=" (name Obj) "." Var) ) ) ) )


# Remote entities
(class +Remote)

(dm zap> ())
(dm has> ~(method 'has> '+Entity))
(dm url> (Tab Fld))
(dm url1> ~(method 'url1> '+Entity))
(dm url2> ~(method 'url2> '+Entity))
(dm url3> ~(method 'url3> '+Entity))
(dm url4> ~(method 'url4> '+Entity))
(dm url5> ~(method 'url5> '+Entity))
(dm url6> ~(method 'url6> '+Entity))
(dm url7> ~(method 'url7> '+Entity))
(dm url8> ~(method 'url8> '+Entity))
(dm url9> ~(method 'url9> '+Entity))
(dm put> (Var Val))
(dm put!> (Var Val))
(dm del> (Var Val))
(dm del!> (Var Val))
(dm inc> (Var Val))
(dm inc!> (Var Val))
(dm dec> (Var Val))
(dm dec!> (Var Val))
(dm mis> (Var Val))
(dm lose1> (Var))
(dm lose> (Lst))
(dm lose!> (Lst))
(dm keep1> (Var))
(dm keep> (Lst))
(dm keep?> (Lst))
(dm keep!> (Lst))
(dm set> (Val))
(dm set!> (Val))


# Default syncronization function
(de upd Lst
   (wipe Lst) )

### DB Sizes ###
(de dbs Lst
   (setq *Dbs
      (make
         (for (N . L) Lst
            (let Dbf (cons N (>> (- (link (car L))) 64))
               (for Cls (cdr L)
                  (if (atom Cls)
                     (put Cls 'Dbf Dbf)
                     (for Var (cdr Cls)
                        (let Rel (get Cls 1 Var)
                           (unless Rel
                              (quit "Bad relation" (cons Var (car Cls))) )
                           (when (or (isa '+index Rel) (isa '+Swap Rel))
                              (put @ 'dbf Dbf) )
                           (for B (; Rel bag)
                              (when (or (isa '+index B) (isa '+Swap B))
                                 (put @ 'dbf Dbf)) ) ) ) ) ) ) ) ) ) )

(de db: Typ
   (or (meta Typ 'Dbf 1) 1) )

### Utilities ###
(private) _db

(de treeRel (Var Cls)
   (with (or (get Cls Var) (meta Cls Var))
      (or
         (find '((B) (isa '+index B)) (: bag))
         This ) ) )

# (db 'var 'cls ['hook] 'any ['var 'any ..]) -> sym
(de db (Var Cls . @)
   (with (treeRel Var Cls)
      (let (Tree (tree (: var) (: cls) (and (: hook) (next)))  Val (next))
         (if (isa '+Key This)
            (if (args)
               (and (fetch Tree Val) (pass _db @))
               (fetch Tree Val) )
            (let Key (cons (if (isa '+Fold This) (fold Val) Val))
               (let? A (: aux)
                  (while (and (args) (== (++ A) (arg 1)))
                     (next)
                     (queue 'Key (next)) )
                  (and (: ub) (setq Key (ubZval Key))) )
               (let Q (init Tree Key (append Key T))
                  (loop
                     (NIL (step Q T))
                     (T (pass _db @ Var Val) @) ) ) ) ) ) ) )

(de _db (Obj . @)
   (when (isa Cls Obj)
      (loop
         (NIL (next) Obj)
         (NIL (has> Obj @ (next))) ) ) )

# (aux 'var 'cls ['hook] 'any ..) -> sym
(de aux (Var Cls . @)
   (with (treeRel Var Cls)
      (use Key
         (step
            (init (tree (: var) (: cls) (and (: hook) (next)))
               (setq Key (if (: ub) (ubZval (rest)) (rest)))
               (append Key T) ) ) ) ) )

# (collect 'var 'cls ['hook] ['any|beg ['end [var ..]]]) -> lst
(de collect (Var Cls . @)
   (with (treeRel Var Cls)
      (let
         (Tree (tree (: var) (: cls) (and (: hook) (next)))
            X1 (next)
            X2 (if (args) (next) (or X1 T)) )
         (make
            (cond
               ((isa '+Key This)
                  (iter Tree
                     '((X) (and (isa Cls X) (link (pass get X))))
                     X1 X2 ) )
               ((: ub)
                  (if X1
                     (ubIter Tree (inc (length (: aux)))
                        '((X) (and (isa Cls X) (link (pass get X))))
                        X1 X2 )
                     (iter Tree
                        '((X) (and (isa Cls X) (link (pass get X)))) ) ) )
               (T
                  (when (isa '+Fold This)
                     (setq X1 (fold X1)  X2 (or (=T X2) (fold X2))) )
                  (if (>= X2 X1)
                     (if (pair X1)
                        (setq X2 (append X2 T))
                        (setq X1 (cons X1)  X2 (cons X2 T)) )
                     (if (pair X1)
                        (setq X1 (append X1 T))
                        (setq X1 (cons X1 T)  X2 (cons X2)) ) )
                  (iter Tree
                     '((X)
                        (and (isa Cls X) (link (pass get X))) )
                     X1 X2
                     (or (isa '+Idx This) (isa '+IdxFold This)) ) ) ) ) ) ) )

# Combined 'search' function
(private) (*SX *SY search1)

(de relQ (X Lst)
   (iter> (meta (cdr Lst) (car Lst)) X Lst) )

(de search1 (Val Lst)  # ((Q . stepFun) . lst)
   (let X (++ Lst)
      (cons
         (cond
            ((pair (cdr X)) (relQ Val X))
            ((pair (setq X (get Val (cdr X))))
               (cons (list X) pop) )
            (T (cons (list (list X)) pop)) )
         Lst ) ) )

(de search (*SX *SY . @)
   (ifn *SY
      (for (P (cddr *SX)  P  (or (cdr P) (cddr *SX)))  # Next search result
         (NIL (setq *SY ((cadar P) (caaar P))))
         (T
            (and
               (fully  # Filter
                  '((L) ((cddr L) *SY (cdar L)))
                  (cddr *SX) )
               (nand  # Deduplicate
                  (val *SX)
                  (idx *SX (cons (hash *SY) *SY) T) )
               ((cadr *SX) *SY) )  # Extract
            (setq P
               (rot (cddr *SX) (offset P (cddr *SX))) )
            @ ) )
      # Init search
      (let
         (*Iter+ NIL
            Lst
            (make
               (link prog)  # idx and extract
               (loop
                  (when (or *SX (nor (args) (cdr (made))))
                     (link  # ((Q . V) genFun . filterFun)
                        (cons
                           (cons
                              (list
                                 (if (pair (caar *SY))
                                    (cons ((car *SY) *SX) (cddr *SY))  # (init . step)
                                    (search1 *SX *SY) ) )
                              *SX )
                           '((Q)  # Generator
                              (use Obj
                                 (loop
                                    (T
                                       (nor  # Done
                                          (setq Obj ((cdaar Q) (caaar Q)))
                                          (cdr Q) ) )
                                    (T (unless (cdar Q) Obj) Obj)  # Result
                                    (if Obj
                                       (let L (cdar Q)
                                          (con Q (cons (car Q) (cdr Q)))
                                          (or
                                             (val *SX)  # 'idx'
                                             (not
                                                (isa '+List
                                                   (if (pair (cdar L))
                                                      (meta @ (caar L))  # (+Ref +Link)
                                                      (with (meta Obj (cdar L))  # +Joint
                                                         (meta (: type) (: slot)) ) ) ) )
                                             (set *SX T) )
                                          (set Q (search1 Obj L)) )
                                       (set Q (cadr Q))
                                       (con Q (cddr Q)) ) ) ) )
                           (let  # Filter
                              (@Exe
                                 (if (pair (caar *SY))
                                    (cons
                                       (lit (car (shift '*SY)))
                                       '(X V) )
                                    (list 'match>
                                       (lit
                                          (if (atom (cdar *SY))
                                             (with (meta *SX (cdar *SY))  # +Joint
                                                (meta (: type) (: slot)) )
                                             (meta (cdar *SY) (caar *SY)) ) )  # +index
                                       'V
                                       (list '; 'X (caar *SY))
                                       'X ) )
                                 @Lst (flip (mapcar car (cdr *SY))) )
                              (curry (@Lst @Exe) (X V)
                                 (let L '@Lst
                                    (recur (X L)
                                       (if L
                                          (pick recurse
                                             (fish ext? (get X (++ L)))
                                             (circ L) )
                                          @Exe ) ) ) ) ) ) ) )
                  (setq *SX (next))
                  (NIL (setq *SY (next))
                     (and *SX (set (made) @)) ) ) ) )
         (cons
            (or *Iter+ (bool (cddr Lst)))  # 'idx'
            Lst ) ) ) )

# Multiple indexes
(de relQs (@Lst . @)
   (cons
      (curry (@Lst) (X)
         (on *Iter+)
         (cons
            (list
               (mapcar '((Y) (relQ X Y)) '@Lst) )
            '((Q)
               (or
                  ((cdaar Q) (caaar Q))
                  (and
                     (cdar Q)
                     (shift Q)
                     ((cdaar Q) (caaar Q)) ) ) ) ) )
      (let
         (@L
            (mapcar
               '((Y) (meta (cdr Y) (car Y)))
               @Lst )
            @V (mapcar car @Lst) )
         (curry (@L @V) (X Val)
            (find
               '((R V) (match> R Val (get X V) X))
               '@L
               '@V ) ) )
      (rest) ) )

# Iterate all objects of given class or search query
(private) (X Prg)

(de forall (X . Prg)
   (cond
      ((or (atom X) (num? (car X)))  # 'seq'
         (for
            (This
               (seq
                  (or
                     (and (pair X) (++ X))
                     (; X Dbf 1)
                     (meta X 'Dbf 1)
                     1 ) )
               This
               (seq This) )
            (and (isa X This) (run Prg 1)) ) )
      ((flg? (car X))  # 'search'
         (while (search X)
            (with @ (run Prg 1)) ) )
      (T  # 'init'
         (while (step X)
            (with @ (run Prg 1)) ) ) ) )

# Define object variables as relations
(de rel Lst
   (def *Class
      (car Lst)
      (new (cadr Lst) (car Lst) (cddr Lst)) ) )

# Find or create object
(de request (Typ Var . @)
   (let Dbf (or (meta Typ 'Dbf 1) 1)
      (ifn Var
         (new Dbf Typ)
         (with (meta Typ Var)
            (or
               (pass db Var (: cls))
               (if (: hook)
                  (pass new Dbf Typ @ (next) Var)
                  (pass new Dbf Typ Var) ) ) ) ) ) )

(de request! (Typ Var . @)
   (prog2
      (dbSync)
      (pass request Typ Var)
      (commit 'upd) ) )

# Create or update object
(private) *ObjIdx

(de obj Lst
   (let Obj
      (let L (++ Lst)
         (if (pair (car L))
            (apply request L)
            (cache '*ObjIdx (++ Lst)
               (new (or (meta L 'Dbf 1) 1) L) ) ) )
      (while Lst
         (let (K (++ Lst)  V (++ Lst))
            (if (=T K)
               (lose> Obj)
               (put> Obj K V) ) ) )
      Obj ) )

# Create or update lots of objects
(de create (Typ Key Vars . Prg)
   (prune 0)
   (setq Vars  # ((var fd lst cnt . cnt) ..)
      (mapcar
         '((Var)
            (if (isa '+index (meta Typ Var))
               (cons Var
                  (open (tmp (pack "create-" Var)))
                  NIL 0 1000000 )
               Var ) )
         Vars ) )
   (while (run Prg)  # (val ..)
      (let (Lst @  Obj (or (fin Lst) (new (meta Typ 'Dbf 1) Typ)))
         (and Key (++ Lst) (put> Obj Key @))
         (let store '((Tree Key Val Dbf) (link Key))
            (mapc
               '((V Val)
                  (when (or Val (fin Lst))
                     (if (atom V)
                        (put> Obj V Val)
                        (out (cadr V)
                           (for Key (make (put> Obj (car V) Val))
                              (at (cdddr V) (push (cddr V) Key))
                              (pr Key Obj) ) ) ) ) )
               Vars
               Lst ) ) )
      (at (0 . 1000000) (commit) (prune 2)) )
   (commit)
   (prune 0)
   (let Lst
      (extract
         '((V)
            (unless (atom V)
               (close (cadr V))
               (let
                  (Var (car V)
                     File (tmp (pack "create-" Var))
                     N 0 )
                  (setq V
                     (mapcar
                        '((Key)
                           (let F (tmp (pack "create-" (inc 'N)))
                              (cons Key F
                                 (or (open F) (quit "Too many files")) ) ) )
                        (cons NIL (sort (caddr V))) ) )
                  (in File
                     (while (setq Key (rd))
                        (out (cddr (rank Key V))
                           (pr Key (rd)) ) ) )
                  (%@ "unlink" NIL File)
                  (let (Dbf (meta Typ Var 'dbf)  Tree (cons Var (new T)))
                     (for R V
                        (close (cddr R))
                        (for X
                           (sort
                              (make
                                 (in (cadr R)
                                    (while (rd)
                                       (link (cons @ (rd))) ) ) ) )
                           (store Tree (car X) (cdr X) Dbf)
                           (at (0 . 1000) (prune 2)) )
                        (commit)
                        (prune 2)
                        (%@ "unlink" NIL (cadr R)) )
                     (commit)
                     Tree ) ) ) )
         Vars )
      (prune)
      (for Tree Lst
         (let
            (Base (get *DB (meta Typ (car Tree) 'cls))
               Root (get (cdr Tree) (car Tree)) )
            (ifn (get Base (car Tree))
               (put Base (car Tree) Root)
               (touch Base)
               (inc @ (car Root)) ) )
         (zap (cdr Tree)) )
      (commit) ) )

### Debug ###
`*Dbg

(noLint 'create 'store)

(load "@lib/sq.l")


================================================
FILE: lib/dbgc.l
================================================
# 04jun23 Software Lab. Alexander Burger

### DB Garbage Collection ###

(private) (markData markExt)

(de markExt (S)
   (unless (mark S T)
      (markData (val S))
      (maps markData S)
      (wipe S) ) )

(de markData (X)
   (while (pair X)
      (markData (++ X)) )
   (and (ext? X) (markExt X)) )

(let Cnt 0
   (dbSync)
   (markExt *DB)
   (for L *ExtDBs  # ("path/"  )
      (let ((P N E) L  Lck)
         (for I N
            (let (Fd (open (pack P (hax (dec I))))  (Cnt . Siz) (blk Fd 0))
               (and (=1 I) (setq Lck Fd))
               (for Blk (dec Cnt)
                  (mapc markExt
                     (fish ext? (ext E (blk Fd Blk Siz Lck))) ) )
               (close Fd) ) ) ) )
   (finally (mark 0)
      (for (F . @) (or *Dbs (2))
         (for (S (seq F)  S  (seq S))
            (unless (mark S)
               (inc 'Cnt)
               (and (isa '+Entity S) (zap> S))
               (zap S) ) ) ) )
   (when *Blob
      (use (@S @R F S)
         (let Pat (conc (chop *Blob) '(@S "." @R))
            (in (list 'find *Blob "-type" "f")
               (while (setq F (line))
                  (when (match Pat F)
                     (unless
                        (and
                           (setq S (extern (pack (delete "/" @S T))))
                           (get S (intern @R)) )
                        (inc 'Cnt)
                        (%@ "unlink" NIL (pack F)) )
                     (wipe S) ) ) ) ) ) )
   (commit)
   (gt0 Cnt) )


================================================
FILE: lib/debug.l
================================================
# 05nov25 Software Lab. Alexander Burger

# Prompt
(de *Prompt
   (casq (car (symbols)) (pico) (T @)) )

(private) (_who _match nest nst1 nst2 C D E M S X Y Z Fun Prg Who dep1 dep2)

# Edit history
(de h ()
   (let F (tmp "history")
      (out F
         (mapc prinl (history)) )
      (and
         (vi (cons T F))
         (history
            (in F
               (make (while (line T) (link @))) ) )
         T ) ) )

# Browsing
(de help (Sym Ex)
   (when (; Sym doc)
      (prinl "========================================")
      (in @
         (from
            (pack
               "
" "%3E"
                  "\^" "%5E"
                  "|" "%7C")
               "\">" ) )
         (out '("w3m" "-T" "text/html" "-dump")
            (prin "
")
            (echo "")
            (echo "
")
            (prinl "
")
            (echo "\n
")
            (ifn Ex
               (prinl "

")
               (prin "
")
               (prinl (echo "\n
")) ) ) ) )
   Sym )

(de docs (Dir)
   (when (=T (car (info Dir)))
      (let All (all)
         (for F (dir Dir)
            (when (match '("r" "e" "f" @ "." "h" "t" "m" "l") (chop F))
               (let P (pack Dir F)
                  (in P
                     (while (from "
" "%3E"
                     "\^" "%5E"
                     "|" "%7C" ) )
               "@doc/ref.html" ) ) ) ) )

(de more (M Fun)
   (let *Dbg NIL
      (if (pair M)
         ((default Fun println) (++ M))
         (println (type M))
         (setq
            Fun (list '(X) (list 'pp 'X (lit M)))
            M (mapcar car (filter pair (val M))) ) )
      (loop
         (T (atom M))
         (T (= "\e" (key)) T)
         (Fun (++ M)) ) ) )

(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))) ) )

(and noLint (@ 'who 'Prg))

(de _who (Y)
   (unless (or (ext? Y T) (memq Y Who))
      (push 'Who Y)
      (ifn (= `(char "+") (char Y))
         (and (pair (val Y)) (nest @) (link Y))
         (for Z (pair (val Y))
            (if (atom Z)
               (and (_match Z) (link Y))
               (when (nest (cdr Z))
                  (link (cons (car Z) Y)) ) ) )
         (maps
            '((Z)
               (if (atom Z)
                  (and (_match Z) (link Y))
                  (when (nest (car Z))
                     (link (cons (cdr Z) Y)) ) ) )
            Y ) ) ) )

(de nest (Y)
   (nst1 Y)
   (nst2 Y) )

(de nst1 (Y)
   (let Z (setq Y (strip Y))
      (loop
         (T (atom Y) (and (sym? Y) (_who Y)))
         (and (sym? (car Y)) (_who (car Y)))
         (and (pair (car Y)) (nst1 @))
         (T (== Z (setq Y (cdr Y)))) ) ) )

(de nst2 (Y)
   (let Z (setq Y (strip Y))
      (loop
         (T (atom Y) (_match Y))
         (T (or (_match (car Y)) (nst2 (car Y)))
            T )
         (T (== Z (setq Y (cdr Y)))) ) ) )

(de _match (D)
   (and
      (cond
         ((str? X) (and (str? D) (= X D)))
         ((sym? X) (== X D))
         (T (match X D)) )
      (or
         (not Prg)
         (let *Dbg (up 2 *Dbg) (run Prg)) ) ) )

(de has (X)
   (let *Dbg NIL
      (filter
         '((S) (= X (val S)))
         (all) ) ) )

(de can (X)
   (let *Dbg NIL
      (extract
         '((Y)
            (and
               (= `(char "+") (char Y))
               (asoq X (val Y))
               (cons X Y) ) )
         (all) ) ) )

(private) (Flg Nsp Lst Sym N L S)

# Namespaces nested in current search order
(de namespaces (Flg)
   (let N 3
      (make
         (for Nsp (symbols)
            (recur (Nsp N)
               (link Nsp)
               (when Flg
                  (space N)
                  (println Nsp) )
               (for S (all Nsp)
                  (and
                     (pair (val S))
                     (== '\~ (car @))
                     (not (memq S (made)))
                     (recurse S (+ N 3)) ) ) ) ) ) ) )

# Namespace shadowing
(de shadows (Flg)
   (let Lst (mapcan all (symbols))
      (make
         (while (cdr Lst)
            (let Sym (++ Lst)
               (unless (member Sym (made))
                  (let? L
                     (filter
                        '((S)
                           (and
                              (= S Sym)
                              (n== S Sym)
                              (val S) ) )
                        Lst )
                     (when Flg
                        (space 3)
                        (apply println L Sym) )
                     (link Sym) ) ) ) ) ) ) )

# Class dependencies
(de dep (C)
   (let *Dbg NIL
      (dep1 0 C)
      (dep2 3 C)
      C ) )

(de dep1 (N C)
   (for X (type C)
      (dep1 (+ 3 N) X) )
   (space N)
   (println C) )

(de dep2 (N C)
   (for X (all)
      (when
         (and
            (= `(char "+") (char X))
            (memq C (type X)) )
         (space N)
         (println X)
         (dep2 (+ 3 N) X) ) ) )

# Inherited methods
(de methods (Obj)
   (make
      (let Mark NIL
         (recur (Obj)
            (for X (val Obj)
               (nond
                  ((pair X) (recurse X))
                  ((memq (car X) Mark)
                     (link (cons (car X) Obj))
                     (push 'Mark (car X)) ) ) ) ) ) ) )

(private) (_dbg _dbg2 dbg ubg traced? U)

# Single-Stepping
(de _dbg (Lst)
   (or
      (atom (car Lst))
      (num? (caar Lst))
      (flg? (caar Lst))
      (== '! (caar Lst))
      (set Lst (cons '! (car Lst))) ) )

(de _dbg2 (Lst)
   (map
      '((L)
         (if (and (pair (car L)) (flg? (caar L)))
            (map _dbg (cdar L))
            (_dbg L) ) )
      Lst ) )

(de dbg (Lst)
   (when (pair Lst)
      (casq (++ Lst)
         ((case casq state)
            (_dbg Lst)
            (for L (cdr Lst)
               (map _dbg (cdr L)) ) )
         ((cond nond)
            (for L Lst
               (map _dbg L) ) )
         (quote
            (when (fun? Lst)
               (map _dbg (cdr Lst)) ) )
         ((job use let let? recur)
            (map _dbg (cdr Lst)) )
         (loop
            (_dbg2 Lst) )
         ((bind do)
            (_dbg Lst)
            (_dbg2 (cdr Lst)) )
         (for
            (and (pair (car Lst)) (map _dbg (cdar Lst)))
            (_dbg2 (cdr Lst)) )
         (T (map _dbg Lst)) )
      T ) )

(de d ()
   (let *Dbg NIL
      (dbg ^) ) )

(de -debug ()
   (debug (intern (opt))) )

(de debug (X C)
   (ifn (traced? X C)
      (let *Dbg NIL
         (when (pair X)
            (setq C (cdr X)  X (car X)) )
         (or
            (dbg (if C (method X C) (getd X)))
            (quit "Can't debug" X) ) )
      (untrace X C)
      (debug X C)
      (trace X C) ) )

(de ubg (Lst)
   (when (pair Lst)
      (map
         '((L)
            (when (pair (car L))
               (when (== '! (caar L))
                  (set L (cdar L)) )
               (ubg (car L)) ) )
         Lst )
      T ) )

(de u ()
   (let *Dbg NIL
      (ubg ^) ) )

(de unbug (X C)
   (let *Dbg NIL
      (when (pair X)
         (setq C (cdr X)  X (car X)) )
      (or
         (ubg (if C (method X C) (getd X)))
         (quit "Can't unbug" X) ) ) )

# Tracing
(de traced? (X C)
   (setq X
      (if C
         (method X C)
         (getd X) ) )
   (and
      (pair X)
      (pair (cadr X))
      (== '$ (caadr X)) ) )

# Convert ((X Y) A B) --> ((X Y) ($ foo (X Y) A B))
(de -trace ()
   (trace (intern (opt))) )

(de trace (X C)
   (let *Dbg NIL
      (when (pair X)
         (setq C (cdr X)  X (car X)) )
      (if C
         (unless (traced? X C)
            (or (method X C) (quit "Can't trace" X))
            (con @
               (cons
                  (conc
                     (list '$ (cons X C) (car @))
                     (cdr @) ) ) ) )
         (unless (traced? X)
            (and (sym? (getd X)) (quit "Can't trace" X))
            (and (num? (getd X)) (expr X))
            (set X
               (list
                  (car (getd X))
                  (conc (list '$ X) (getd X)) ) ) ) )
      X ) )

# Convert ((X Y) ($ foo (X Y) A B)) --> ((X Y) A B)
(de untrace (X C)
   (let *Dbg NIL
      (when (pair X)
         (setq C (cdr X)  X (car X)) )
      (if C
         (when (traced? X C)
            (con
               (method X C)
               (cdddr (cadr (method X C))) ) )
         (when (traced? X)
            (let Y (set X (cddadr (getd X)))
               (and
                  (== '@ (++ Y))
                  (=1 (length Y))
                  (= 2 (length (car Y)))
                  (== 'pass (caar Y))
                  (sym? (cdadr Y))
                  (subr X) ) ) ) )
      X ) )

(de *NoTrace
   @ @@ @@@
   pp show more led
   what who can dep d e debug u unbug trace untrace )

(de traceAll (Excl)
   (let *Dbg NIL
      (for X (all)
         (or
            (memq X Excl)
            (memq X *NoTrace)
            (= `(char "*") (char X))
            (cond
               ((= `(char "+") (char X))
                  (mapc trace
                     (extract
                        '((Y)
                           (and
                              (pair Y)
                              (fun? (cdr Y))
                              (cons (car Y) X) ) )
                        (val X) ) ) )
               ((pair (getd X))
                  (trace X) ) ) ) ) ) )

# Process Listing
(when (member *OS '("Android" "Linux"))
   (de proc @
      (apply call
         (make (while (args) (link "-C" (next))))
         "ps" "-H" "-o" "pid,ppid,start,size,pcpu,stat,cmd" ) ) )

# Benchmarking
(de bench Prg
   (let U (usec)
      (prog1
         (run Prg 1)
         (out 2
            (when (>= (setq U (- (usec) U)) 60000000)
               (prin "[" (tim$ (/ U 1000000)) "] ") )
            (prinl (format (/ U 1000) 3) " sec") ) ) ) )

# Backtrace
(de bt (Flg)
   (let (S NIL  *Dbg)
      (for (L (trail T) L)
         (if (pair (car L))
            (let E (++ L)
               (push 'S
                  (list
                     (if (getd (box? (car E)))
                        (cons @ (cdr E))
                        E ) ) ) )
            (conc
               (car (default S (cons (cons))))
               (cons (cons (++ L) (++ L))) ) )
         (T (== '^ (car L)))
         (T
            (and
               (pair (car L))
               (== 'bt (caar L)) ) ) )
      (for L S
         (let? X (++ L)
            (pretty
               (cons
                  (or
                     (and (sym? (car X)) (car X))
                     (find
                        '((S) (== (car X) (val S)))
                        (all) )
                     (car X) )
                  (less (cdr X)) ) ) )
         (prinl)
         (while L
            (space 3)
            (println (caar L) (less (cdr (++ L)))) )
         (NIL (or Flg (<> "\e" (key))) T) ) ) )

# Source code
`(info "@lib/map")

(symbols 'llvm 'pico)

(in "@lib/map"
   (while (read)
      (let Sym @
         (if (get Sym '*Dbg)
            (set @ (read))
            (put Sym '*Dbg (cons (read))) ) ) ) )


================================================
FILE: lib/form.js
================================================
/* 13mar25 Software Lab. Alexander Burger */

var Btn = [];
var SesId, Key, InBtn, Auto, Chg, Post, Drop, Hint, Hints, Item, Beg, End;

function inBtn(btn,flg) {InBtn = flg;}

function formKey(event) {
   Key = event.key;
   if (Hint  &&  Hint.style.visibility == "visible") {
      if ((Item >= 0  &&  Key == "Enter")  ||  Key == "ArrowUp"  ||  Key == "ArrowDown")
         return false;
      if (Key == "Enter") {
         Hint.style.visibility = "hidden";
         return true;
      }
      if (Key == "Escape") {
         Hint.style.visibility = "hidden";
         return false;
      }
   }
   if (Key == "Backspace")
      Chg = true;
   return true;
}

function fldChg(field) {
   Chg = true;
   if (!InBtn  &&  (Key != "Enter" || field.type == "textarea")) {
      post(field.form, false, null, null);
      Key = 0;
   }
   return true;
}

function doBtn(btn) {
   Btn.push(btn);
   return true;
}

function doDrag(event) {
   event.stopPropagation();
   event.preventDefault();
}

function doDrop(btn, event) {
   doDrag(event);
   if (event.dataTransfer.files.length != 0) {
      Btn.push(Drop = btn);
      btn.value = "0 %";
      post(btn.form, false, null, event.dataTransfer.files[0]);
   }
}

function dropProgress(event) {
   if (Drop)
      Drop.value = event.lengthComputable?
         Math.round((event.loaded * 100) / event.total) + " %" : "(?) %";
}

function dropLoad(event) {
   Drop = null;
}

function hasElement(form, name) {
   for (var i = 0; i < form.elements.length; ++i)
      if (form.elements[i].name == name)
         return true;
   return false;
}

function setHref(fld, url) {
   var i = url.indexOf("~");

   if (url.charAt(i = i>=0? i+1 : 0) == "+")  {
      url = url.substr(0,i) + url.substr(i+1);
      fld.target = "_blank";
   }
   fld.href = decodeURIComponent(url);
}

function idFocus(fld) {
   try {
      document.createEvent("TouchEvent");
      return true;
   } catch (e) {}
   setTimeout(function() {document.getElementById(fld).focus()}, 420);
}

function setCheck(fld, val) {
   var lst = document.getElementsByName(fld.name);

   for (var i = 1;  i < lst.length; ++i)
      if (lst[i] == fld)
         return lst[i - 1] = val;
}

/*** Form submit ***/
function doPost(form) {
   for (var i = 0; ; ++i) {
      if (i == Btn.length)
         return true;
      if (Btn[i].form == form)
         return post(form, false, null, null);
   }
}

function post(form, auto, exe, file) {
   var i, data;
   var req = new XMLHttpRequest();

   if (!hasElement(form,"*Form") || (i = form.action.indexOf("~")) <= 0)
      return true;
   form.style.cursor = "wait";
   try {req.open("POST", SesId + "!jsForm?" + form.action.substr(i+1));}
   catch (e) {return true;}
   req.onload = function() {
      if (req.status != 200)
         req.abort();
      else if (req.responseText == "T")
         form.submit();
      else if (req.responseText) {
         var txt = req.responseText.split("&");

         form.elements["*Evt"].value = txt[0];
         if (txt[1]) {
            var r = txt[1].split(":");

            if (Auto)
               clearTimeout(Auto);
            if (!r[1])
               Auto = null;
            else {
               Auto = setTimeout(function() {
                  if (Chg)
                     Auto = setTimeout(arguments.callee, r[1]);
                  else {
                     Btn.push(document.getElementById(r[0]));
                     post(form, true, null, null);
                  }
               }, r[1] );
            }
         }
         if (!auto || !Chg) {
            var i, j;

            for (i = 2; i < txt.length;) {
               var fld = txt[i++];
               var val = decodeURIComponent(txt[i++]);

               if (!fld) {
                  window[txt[i++]](val);
                  continue;
               }
               if (!(fld = document.getElementById(fld)))
                  continue;
               if (fld.tagName == "SPAN") {
                  if (i != txt.length && txt[i].charAt(0) == "=")
                     ++i;
                  if (i == txt.length || txt[i].charAt(0) != "+") {
                     if (fld.firstChild.tagName != "A")
                        fld.firstChild.data = val? val : "\u00A0";
                     else
                        fld.replaceChild(document.createTextNode(val? val : "\u00A0"), fld.firstChild);
                  }
                  else {
                     var a = document.createElement("A");

                     setHref(a, txt[i++].substr(1));
                     a.appendChild(document.createTextNode(val));
                     fld.replaceChild(a, fld.firstChild);
                  }
               }
               else if (fld.tagName == "A") {
                  if (i != txt.length && txt[i].charAt(0) == "=")
                     ++i;
                  if (i == txt.length || txt[i].charAt(0) != "+") {
                     fld.replaceChild(document.createTextNode(val? val : "\u00A0"), fld.firstChild);
                     fld.removeAttribute("href");
                  }
                  else {
                     fld.firstChild.data = val;
                     setHref(fld, txt[i++].substr(1));
                  }
               }
               else if (fld.tagName == "IMG") {
                  var parent = fld.parentNode;

                  fld.src = val;
                  fld.alt = txt[i++];
                  if (parent.tagName == "A") {
                     if (txt[i])
                        setHref(parent, txt[i]);
                     else {
                        var grand = parent.parentNode;

                        grand.removeChild(parent);
                        grand.appendChild(fld);
                     }
                  }
                  else if (txt[i]) {
                     var a = document.createElement("A");

                     parent.removeChild(fld);
                     parent.appendChild(a);
                     a.appendChild(fld);
                     setHref(a, txt[i]);
                  }
                  ++i;
               }
               else {
                  if (fld.type == "checkbox") {
                     fld.checked = val != "";
                     setCheck(fld, "");
                  }
                  else if (fld.type == "select-one") {
                     for (j = 0; j < fld.options.length; ++j) {
                        if (fld.options[j].text == val)
                           fld.selectedIndex = j;
                        fld.options[j].disabled = false;
                     }
                  }
                  else if (fld.type == "radio") {
                     fld.value = val;
                     fld.checked = txt[i++].charAt(0) != "";
                  }
                  else if (fld.type == "image")
                     fld.src = val;
                  else if (fld.value != val) {
                     fld.value = val;
                     if (fld.pilSetValue)
                        fld.pilSetValue(val);
                     fld.scrollTop = fld.scrollHeight;
                  }
                  fld.disabled = false;
                  if (i < txt.length && txt[i].charAt(0) == "=") {
                     if (fld.type == "select-one") {
                        for (j = 0; j < fld.options.length; ++j)
                           if (fld.options[j].text != val)
                              fld.options[j].disabled = true;
                     }
                     fld.disabled = true;
                     InBtn = 0;  // 'onblur' on won't come when disabled
                     if (fld.type == "checkbox"  &&  fld.checked)
                        setCheck(fld, "T");
                     ++i;
                  }
                  if (fld.pilDisable)
                     fld.pilDisable(fld.disabled);
               }
               while (i < txt.length && (j = "#*?".indexOf(txt[i].charAt(0))) >= 0) {
                  switch (j) {

                  case 0:  // '#'
                     var cls;

                     val = txt[i++].substr(1);
                     if ((cls = fld.getAttribute("class")) != null  &&  (j = cls.indexOf("  ")) >= 0)
                        val += cls.substr(j);
                     fld.setAttribute("class", val);
                     break;

                  case 1:  // '*'
                     var node = fld.parentNode.parentNode.lastChild;
                     var img = document.createElement("IMG");

                     if (!node.firstChild)
                        node = fld.parentNode.parentNode.parentNode.lastChild;
                     node.removeChild(node.firstChild);
                     img.src = txt[i++].substr(1);
                     if (!txt[i])
                        node.appendChild(img);
                     else {
                        var a = document.createElement("A");

                        setHref(a, txt[i]);
                        a.appendChild(img);
                        node.appendChild(a);
                     }
                     ++i;
                     break;

                  case 2:  // '?'
                     fld.title = decodeURIComponent(txt[i++].substr(1));
                     break;
                  }
               }
            }
            if (Post)
               Post();
            Chg = false;
         }
      }
      form.style.cursor = "";
   };
   if (!exe)
      data = "";
   else {
      data = "*Gui:0=" + exe[0];
      for (var i = 1; i < exe.length; ++i)
         data += "&*JsArgs:" + i + "=" + exe[i];
   }
   for (i = 0; i < Btn.length;)
      if (Btn[i].form != form)
         ++i;
      else {
         data += "&" + Btn[i].name + "=" + encodeURIComponent(Btn[i].type == "submit"? Btn[i].value : Btn[i].src);
         Btn.splice(i,1);
      }
   for (i = 0; i < form.elements.length; ++i) {
      var fld = form.elements[i];

      if (fld.name  &&  fld.type != "submit") {   // "image" won't come :-(
         var val;

         if (fld.type == "checkbox")
            val = fld.checked? "T" : "";
         else if (fld.type == "select-one")
            val = fld.options[fld.selectedIndex].text;
         else if (fld.type == "radio" && !fld.checked)
            continue;
         else
            val = fld.value;
         data += "&" + fld.name + "=" + encodeURIComponent(val.replace(/ +$/,""));
      }
   }
   try {
      if (!file)
         req.send(data);
      else {
         var rd = new FileReader();

         req.upload.addEventListener("progress", dropProgress, false);
         req.upload.addEventListener("load", dropLoad, false);
         rd.readAsBinaryString(file);
         rd.onload = function() {
            req.setRequestHeader("X-Pil", "*ContL=T");
            req.sendAsBinary(data + "&*Drop=" +
               encodeURIComponent(file.name) + "=" +
               file.size + "\n" + rd.result );
         }
      }
   }
   catch (e) {
      req.abort();
      return true;
   }
   return false;
}

/*** Hints ***/
function doHint(field) {
   if (!Hint) {
      Hint = document.createElement("div");
      Hint.setAttribute("class", "hint");
      Hint.style.visibility = "hidden";
      Hint.style.position = "absolute";
      Hint.style.zIndex = 9999;
      Hint.style.textAlign = "left";
      Hints = document.createElement("div");
      Hints.setAttribute("class", "hints");
      Hints.style.position = "relative";
      Hints.style.top = "-2px";
      Hints.style.left = "-3px";
      Hint.appendChild(Hints);
   }
   field.parentNode.appendChild(Hint);
   field.onblur = function() {
      Hint.style.visibility = "hidden";
   }
   var top = field.offsetHeight;
   var left = 0;
   for (var obj = field;  obj && obj.style.position != "absolute";  obj = obj.offsetParent) {
      top += obj.offsetTop;
      left += obj.offsetLeft;
   }
   Hint.style.top = top + "px";
   Hint.style.left = left + "px";
}

function hintKey(field, event, tok, coy) {
   var i, data;

   if (event.key == "Tab"  ||  event.key == "Escape")
      return false;
   if (Hint.style.visibility == "visible") {
      if (Item >= 0  &&  event.key == "Enter") {
         setHint(field, Hints.childNodes[Item]);
         return false;
      }
      if (event.key == "ArrowUp") {
         if (Item > 0) {
            hintOff(Item);
            hintOn(--Item);
         }
         return false;
      }
      if (event.key == "ArrowDown") {
         if (Item < (lst = Hints.childNodes).length-1) {
            if (Item >= 0)
               hintOff(Item);
            hintOn(++Item);
         }
         return false;
      }
   }
   if (event.key == "Enter")
      return true;
   var req = new XMLHttpRequest();
   if (tok) {
      for (Beg = field.selectionStart;  Beg > 0 && !field.value.charAt(Beg-1).match(/\s/);  --Beg);
      End = field.selectionEnd;
   }
   else {
      Beg = 0;
      End = field.value.length;
   }
   if (event.key != "Insert") {
      if (Beg == End) {
         Hint.style.visibility = "hidden";
         return false;
      }
      if (coy && Hint.style.visibility == "hidden")
         return false;
   }
   try {
      req.open("POST", (SesId? SesId : "") +
         ((i = field.id.lastIndexOf("-")) < 0?
            "!jsHint?$" + field.id : "!jsHint?+" + field.id.substr(i+1) ) );
   }
   catch (e) {return true;}
   req.onload = function() {
      var i, n, lst, str;

      if ((str = req.responseText).length == 0)
         Hint.style.visibility = "hidden";
      else {
         lst = str.split("&");
         while (Hints.hasChildNodes())
            Hints.removeChild(Hints.firstChild);
         for (i = 0, n = 7; i < lst.length; ++i) {
            addHint(i, field, str = decodeURIComponent(lst[i]));
            if (str.length > n)
               n = str.length;
         }
         Hints.style.width = n + 3 + "ex";
         Hint.style.width = n + 4 + "ex";
         Hint.style.visibility = "visible";
         Item = -1;
      }
   }
   var data = "*JsHint=" + encodeURIComponent(field.value.substring(Beg,End));
   for (i = 0; i < field.form.elements.length; ++i) {
      var fld = field.form.elements[i];

      if (fld.name == "*Get")
         data += "&*Get=" + fld.value;
      else if (fld.name == "*Form")
         data += "&*Form=" + fld.value;
   }
   try {req.send(data);}
   catch (e) {
      req.abort();
      return true;
   }
   return (event.key != "Insert");
}

function addHint(i, field, str) {
   var item = document.createElement("div");
   item.appendChild(document.createTextNode(str));
   item.onmouseover = function() {
      if (Item >= 0)
         hintOff(Item);
      hintOn(i);
      field.onblur = false;
      field.onchange = false;
      Item = i;
   }
   item.onmouseout = function() {
      hintOff(Item);
      field.onblur = function() {
         Hint.style.visibility = "hidden";
      }
      field.onchange = function() {
         return fldChg(field);
      };
      Item = -1;
   }
   item.onclick = function() {
      setHint(field, item);
   }
   Hints.appendChild(item);
}

function setHint(field, item) {
   Hint.style.visibility = "hidden";
   field.value = field.value.substr(0,Beg) + item.firstChild.nodeValue + field.value.substr(End);
   Chg = true;
   post(field.form, false, null, null);
   field.setSelectionRange(Beg + item.firstChild.nodeValue.length, field.value.length);
   field.focus();
   field.onchange = function() {
      return fldChg(field)
   };
}

function hintOn(i) {
   var s = Hints.childNodes[i].style;
   s.background = "black";
   s.color= "white";
}

function hintOff(i) {
   var s = Hints.childNodes[i].style;
   s.background = "white";
   s.color= "black";
}

/*** Scroll/touch ***/
var TblX, TblY;

function tblTouch(event) {
   if (event.touches.length == 1) {
      TblX = event.touches[0].pageX;
      TblY = event.touches[0].pageY;
   }
   return true;
}

function tblMove(table, event) {
   if (event.touches.length == 1) {
      var dx = event.touches[0].pageX - TblX;
      var dy = event.touches[0].pageY - TblY;

      TblX = event.touches[0].pageX;
      if (Math.abs(dx) > Math.abs(dy))
         return true;
      if (Math.abs(dy) > 12) {
         TblY = event.touches[0].pageY;
         for (var obj = table.parentNode;  obj;  obj = obj.parentNode)
            if (obj.tagName == "FORM")
               return post(obj, false,
                  [dy > 6? "jsUp" : "jsDn", "+" + table.getAttribute("chart")],
                  null );
      }
      return false;
   }
   return true;
}

/*** Lisp calls ***/
function lisp(form, fun) {
   if (form) {
      var exe = [fun];

      for (var i = 2; i < arguments.length; ++i)
         if (typeof arguments[i] === "number")
            exe[i-1] = "+" + arguments[i];
         else
            exe[i-1] = "." + encodeURIComponent(arguments[i]);
      return post(form, false, exe, null);
   }
   if (arguments.length > 2) {
      fun += "?" + lispVal(arguments[2]);
      for (var i = 3; i < arguments.length; ++i)
         fun += "&" + lispVal(arguments[i]);
   }
   var req = new XMLHttpRequest();
   try {req.open("GET", SesId + "!" + fun);}
   catch (e) {return true;}
   req.onload = function() {
      if (req.responseText)
         eval(req.responseText);
   }
   try {req.send(null);}
   catch (e) {
      req.abort();
      return true;
   }
   return false;
}

function lispVal(x) {
   if (typeof x === "number")
      return "+" + x;
   if (x.charAt(0) == "-")
      return "%2D" + encodeURIComponent(x.substr(1));
   return encodeURIComponent(x);
}

function ping(min) {
   if (SesId)
      setTimeout(function() {ping1(min)}, 20000);
}

function ping1(min) {
   lisp(null, "ping", min);
   setTimeout(function() {ping1(min)}, 20000);
}


================================================
FILE: lib/form.l
================================================
# 20feb26 Software Lab. Alexander Burger

# *PRG *Top *Gui *Btn *Get *Got *Form *FormIx *FormLst *Evt
# *Lock *Spans *AlwaysAsk

(private) (*Chart *App *Ix *Err *Foc *Post2 *Stat *Cho *TZO)

(allow "@img/" T)
(push1 '*JS (allow "@lib/form.js"))  #! @lib
(mapc allow
   (quote
      *Gui *Get *Got *Form "!jsForm" *Evt *Drop
      *JsHint "!jsHint" jsUp jsDn *JsArgs "!tzOffs" ) )

(default *FormIx 1)

(de *Go.png . "@img/go.png")
(de *No.png . "@img/no.png")

(de *Throbber
   ("+---" "-+--" "--+-" "---+" "--+-" "-+--" .) )

(de tzOffs (Min)
   (setq *TZO (* Min 60))
   (respond) )

(private) (Attr Prg App Lst F L)

# Define GUI form
(de form (Attr . Prg)
   (when (=1 *Form)
      ( "window.addEventListener('pagehide', function(event) {document.forms[0].reset()});") )
   (inc '*Form)
   (let App
      (if *PRG
         (get *FormLst (- *FormIx *Get) *Form)
         (prog1
            (setq *Top (new NIL NIL 'able T 'evt 0))
            ~(as *Dbg
               (when (file)
                  (put *Top '*Dbg
                     (list (cons (cddr @) (pack (car @) (cadr @)))) ) ) )
            (put *Top 'home *Top)
            (and (nth *FormLst (- *FormIx *Get)) (queue @ *Top)) ) )
      (let Lst (get *FormLst (- *FormIx *Get) 1)
         (for (F . L) Lst
            (let *Form (- F (length Lst))
               (cond
                  ((and (== *PRG (car L)) (memq App (; *PRG top)))
                     (apply "form" L) )
                  ((or (== *PRG App) (memq App (; *PRG top)))
                     (if (; L 1 top)
                        (apply "form" L)
                        (put L 1 'top (cons *PRG (; *PRG top)))
                        (let *PRG NIL (apply "form" L)) ) ) ) ) ) )
      ("form" App Attr Prg) ) )

(de "form" (*App Attr Prg)
   (with *App
      (job (: env)
         ( Attr (urlMT *Url *Menu *Tab *ID)
            ( '*Get *Get)
            ( '*Form *Form)
            ( '*Evt (: evt))
            (zero *Ix)
            (if *PRG
               (let gui
                  '(()
                     (with (get *App 'gui (inc '*Ix))
                        (for E *Err
                           (when (== This (car E))
                              (
 'error
                                 (if (atom (cdr E))
                                    (ht:Prin (eval (cdr E) 1))
                                    (eval (cdr E) 1) ) ) ) )
                        (if (: id)
                           (let *Gui (val *App)
                              (show> This (cons '*Gui @)) )
                           (setq *Chart This) )
                        This ) )
                  (and (== *PRG *App) (setq *Top *App))
                  (htPrin Prg) )
               (set *App)
               (let gui
                  '((X . @)
                     (inc '*Ix)
                     (with
                        (cond
                           ((pair X) (pass new X))
                           ((not X) (pass new))
                           ((num? X)
                              (ifn *Chart
                                 (quit "no chart" (rest))
                                 (with *Chart
                                    (let L (last (: gui))
                                       (when (get L X)
                                          (inc (:: rows))
                                          (queue (:: gui) (setq L (need (: cols)))) )
                                       (let Fld (pass new)
                                          (set (nth L X) Fld)
                                          (put Fld 'chart (list This (: rows) X))
                                          (and (; Fld chg) (; Fld able) (=: lock))
                                          (set> Fld
                                             (get
                                                ((: put)
                                                   (get (nth (: data) (: ofs)) (: rows))
                                                   (+ (: ofs) (: rows) -1) )
                                                X )
                                             T )
                                          Fld ) ) ) ) )
                           ((get *App X) (quit "gui conflict" X))
                           (T (put *App X (pass new))) )
                        (queue (:: home gui) This)
                        (unless (: chart) (init> This))
                        (when (: id)
                           (let *Gui (val *App)
                              (show> This (cons '*Gui (: id))) ) )
                        This ) )
                  (htPrin Prg) ) ) )
         (off *Chart)
         (--)
         (and
            (: show)
            (info @)
            (in (: show) (echo)) ) ) ) )

# Disable form
(de disable (Flg)
   (and Flg (=: able)) )

(private) Prg

# Handle form actions
(de action Prg
   (off *Chart *Foc)
   (or *PRG *Post2 (off *Err))
   (catch 'stop
      (nond
         (*Post
            (unless (and *PRG (= *Form (car *Got)) (= *Get (cadr *Got)))
               (pushForm (cons)) )
            (if *Port%
               (let *JS NIL (_doForm))
               (_doForm) )
            (off *PRG *Got) )
         (*PRG
            (with (postForm)
               (ifn (= *Evt (: evt))
                  (noContent)
                  (postGui)
                  (redirect
                     (baseHRef)
                     *SesId
                     (urlMT *Url *Menu *Tab *ID)
                     "&*Evt=+" (inc (:: evt))
                     "&*Got=_+" *Form "_+" *Get ) ) ) )
         (NIL
            (off *PRG)
            (pushForm (cons))
            (_doForm) ) ) ) )

(de pushForm (L)
   (push '*FormLst L)
   (and (nth *FormLst 99) (con @))
   (setq *Get *FormIx)
   (inc '*FormIx) )

(de _doForm ()
   (one *Form)
   (run Prg)
   (setq *Stat
      (cons
         (pair *Err)
         (copy (get *FormLst (- *FormIx *Get))) ) ) )

(de jsForm (Url)
   (if (or *PRG (not *Post))
      (noContent)
      (setq *Url Url  Url (chop Url))
      (let action
         '(Prg
            (off *Err)
            (with (postForm)
               (ifn (= *Evt (: evt))
                  (respond)
                  (catch 'stop
                     (postGui)
                     (httpHead "text/plain; charset=utf-8")
                     (if
                        (and
                           (= (car *Stat) *Err)
                           (= (cdr *Stat) (get *FormLst (- *FormIx *Get))) )
                        (ht:Out *Chunked
                           (prin (setq *Evt (inc (:: evt))) "&")
                           (when (: auto)
                              (prin "i" *Form "-" (: auto 1 id) ":" (: auto -1))
                              (=: auto) )
                           (for S *Spans
                              (prin "&" (car S) "&" (run (cdr S))) )
                           (for This (: gui)
                              (if (: id)
                                 (prin "&i" *Form "-" @ "&" (js> This))
                                 (setq *Chart This) ) ) )
                        (setq *Post2 (cons *Get *Form *PRG))
                        (ht:Out *Chunked (prin T)) ) ) ) )
            (off *PRG) )
         (use @X
            (cond
               ((match '("-" @X "." "h" "t" "m" "l") Url)
                  (try 'html> (extern (ht:Pack @X T))) )
               ((disallowed)
                  (notAllowed *Url)
                  (http404) )
               ((= "!" (car Url))
                  ((intern (cdr Url))) )
               ((tail '("." "l") Url)
                  (load *Url) ) ) ) ) ) )

(de postForm ()
   (when (num? (format *Get))
      (let? Lst (get *FormLst (- *FormIx (setq *Get @)))
         (and
            (setq *Form (format *Form))
            (setq *Evt (format *Evt))
            (setq *PRG
               (cond
                  ((and
                        (= *Get (car *Post2))
                        (= *Form (cadr *Post2)) )
                     (cddr *Post2) )
                  ((off *Post2))
                  ((gt0 *Form) (get Lst *Form))
                  (T (get Lst 1 (+ (length (car Lst)) *Form) 1)) ) )
            (val *PRG)
            *PRG ) ) ) )

(de postGui ()
   (if *Post2
      (off *Gui *Post2)
      (let (*Btn NIL  "Fun")
         (for G *Gui
            (if (=0 (car G))
               (setq "Fun" (cdr G))
               (and (lt0 (car G)) (setq *Btn (cdr G)))
               (con (assoc (car G) (val *PRG)) (cdr G)) ) )
         (off *Gui)
         (and (: lock) (n== @ *Lock) (=: able))
         (job (: env)
            (for This (: gui)
               (cond
                  ((not (: id)) (setq *Chart This))
                  ((chk> This) (error @))
                  ((or (: rid) (: home able))
                     (set> This (val> This) T) ) ) )
            (unless *Err
               (for This (: gui)
                  (cond
                     ((: id))
                     ((chk> (setq *Chart This)) (error @))
                     ((or (: rid) (: home able))
                        (set> This (val> This)) ) ) ) )
            (if (pair *Err)
               (when *Lock
                  (=: lock (with (caar *Err) (tryLock *Lock))) )
               (finally
                  (when *Lock
                     (if (lock @)
                        (=: able (=: lock (off *Lock)))
                        (let *Run NIL
                           (sync)
                           (tell) ) ) )
                  (when "Fun"
                     (when (and *Allow (not (idx *Allow "Fun")))
                        (notAllowed "Fun")
                        (throw 'stop) )
                     (apply (intern "Fun")
                        (mapcar
                           '((X)
                              ((if (= "+" (car (setq X (chop (cdr X))))) format pack)
                                 (cdr X) ) )
                           *JsArgs ) ) )
                  (for This (: gui)
                     (nond
                        ((: id) (setq *Chart This))
                        ((ge0 (: id))
                           (let? A (assoc (: id) (val *PRG))
                              (when (cdr A)
                                 (con A)
                                 (act> This) ) ) ) ) ) )
               (for This (: gui)
                  (or (: id) (setq *Chart This))
                  (upd> This) ) ) ) ) ) )

(de error (Exe)
   (cond
      ((=T Exe) (on *Err))
      ((nT *Err) (queue '*Err (cons This Exe))) ) )

(de url (Url . @)
   (when Url
      (off *PRG)
      (when *Timeout
         (timeout `(* 3600 1000)) )
      (redirect (baseHRef) *SesId Url
         (and (args) "?")
         (pack
            (make
               (loop
                  (let A (next)
                     (and
                        (sym? A)
                        (= `(char '*) (char A))
                        (link A "=")
                        (setq A (next)) )
                     (link (ht:Fmt A)) )
                  (NIL (args))
                  (link "&") ) ) ) )
      (throw 'stop) ) )

(de post Prg
   (run Prg)
   (url *Uri) )

# Active  elements
(de span Args
   (def (car Args)
      (list NIL
         (list '
            (lit (cons 'id (car Args)))
            (cons 'ht:Prin (cdr Args)) ) ) )
   (push '*Spans Args) )

(span expires
   (pack
      `(char 8230)  # Ellipsis
      (let Tim (+ (time T) (/ (cadr (assoc -1 *Run)) 1000))
         (if *TZO
            (tim$ (% (- Tim -86400 @) 86400))
            (
               "lisp(null, 'tzOffs', (new Date()).getTimezoneOffset())" )
            (pack (tim$ (% Tim 86400)) " UTC") ) ) ) )

# Return chart property
(de chart @
   (pass get *Chart) )

# Table extension
(daemon '







































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































   (with *Chart
      (setq ATTR
         (make
            (link
               (cons "chart" (index This (: home chart)))
               '("ontouchstart" . "return tblTouch(event)")
               '("ontouchmove" . "return tblMove(this,event)")
               (and ATTR (link @)) ) ) ) ) )

# REPL form
(private) Str

(de repl (Attr DX DY)
   (default DX 80  DY 25)
   (form Attr
      (=: repl (tmp "repl"))
      (gui 'view '(+Able +FileField)
         '(<> (: file) (: home repl))
         (: repl)
         DX DY )
      (--)
      (gui '(+View +SymField) '(car (symbols)))
      ()
      (gui 'line '(+Focus +Able +Hint1 +TextField)
         '(= (: home view file) (: home repl))
         '*ReplH
         (*/ DX 4 5) )
      (----)
      (gui '(+JS +Able +Button) '(= (: home view file) (: home repl)) "Eval"
         '(let Str (val> (: home line))
            (out (pack "+" (: home repl))
               (if (= `(char "!") (char Str))
                  (err NIL
                     (prinl Str)
                     (flush)
                     (in (list "sh" "-c" (cdr (chop Str)))
                        (echo) ) )
                  (err NIL
                     (prinl (car (symbols)) ": " Str)
                     (flush)
                     (catch '(NIL)
                        (in "/dev/null"
                           (up 99 @@@ "@3")
                           (up 99 @@ "@2")
                           (up 99 @ "@1")
                           (setq  "@3" "@2"  "@2" "@1"  "@1" (run (str Str) 99)) )
                        (println '-> "@1") ) )
                  (when @@
                     (prin "!? ")
                     (println ^)
                     (prinl *Msg) ) ) )
            (push1 '*ReplH Str)
            (clr> (: home line)) ) )
      (gui '(+JS +Button)
         '(if (= (: home view file) (: home repl)) ,"Edit" ,"Done")
         '(file> (: home view)
            (if (= (: home view file) (: home repl))
               (if (val> (: home line))
                  (setq *ReplF (push1 '*ReplH @))
                  (set> (: home line) *ReplF)
                  *ReplF )
               (clr> (: home line))
               (: home repl) ) ) ) ) )

(private) (dlg Attr Env Lst Prg)

# Dialogs
(de dlg (Attr Env Prg)
   (let? L (get *FormLst (- *FormIx *Get))
      (while (and (car L) (n== *PRG (caar @)))
         (pop L) )
      (push L
         (list
            (new NIL NIL  'btn This  'able T  'evt 0  'env Env)
            Attr
            Prg ) )
      (pushForm L) ) )

(de dialog (Env . Prg)
   (dlg 'dialog Env Prg) )

(de alert (Env . Prg)
   (dlg 'alert Env Prg) )

(de note (Str Lst)
   (alert (env '(Str Lst))
      ( 'note Str)
      (--)
      (for S Lst (
 S))
      (okButton) ) )

(de ask (Str . Prg)
   (alert (env '(Str Prg))
      ( 'ask Str)
      (--)
      (yesButton (cons 'prog Prg))
      (noButton) ) )

(de diaform (Lst . Prg)
   (cond
      ((num? (caar Lst))  # Dst
         (gui (gt0 (caar Lst)) '(+ChoButton)
            (cons 'diaform
               (list 'cons
                  (list 'cons (lit (car Lst)) '(field 1))
                  (lit (env (cdr Lst))) )
               Prg ) ) )
      ((and *PRG (not (: diaform)))
         (dlg 'dialog (env Lst) Prg) )
      (T
         (=: env (env Lst))
         (=: diaform T)
         (run Prg 1) ) ) )

(de saveButton (Exe)
   (gui '(+Button) ,"Save" Exe) )

(de closeButton (Lbl Exe)
   (when (; *App top)
      (gui '(+Rid +Close +Button) Lbl Exe) ) )

(de okButton (Exe)
   (when (; *App top)
      (if (=T Exe)
         (gui '(+Force +Close +Button) T "OK")
         (gui '(+Close +Button) "OK" Exe) ) ) )

(de cancelButton ()
   (when (; *App top)
      (gui '(+Force +Close +Button) T ',"Cancel") ) )

(de yesButton (Exe)
   (gui '(+Close +Button) ',"Yes" Exe) )

(de noButton (Exe)
   (gui '(+Close +Button) ',"No" Exe) )

(de choButton (Exe)
   (gui '(+Rid +Tip +Button)
      ,"Find or create an object of the same type"
      ',"Select" Exe ) )


(class +Force)
# force

(dm T (Exe . @)
   (=: force Exe)
   (pass extra) )

(dm chk> ()
   (when
      (and
         (cdr (assoc (: id) (val *PRG)))
         (eval (: force)) )
      (for A (val *PRG)
         (and
            (lt0 (car A))
            (<> (: id) (car A))
            (con A) ) )
      T ) )


(class +Close)

(dm act> ()
   (when (able)
      (and
         (get *FormLst (- *FormIx *Get))
         (pushForm
            (cons
               (filter
                  '((L) (memq (car L) (: home top)))
                  (car @) )
               (cdr @) ) ) )
      (extra)
      (for This (: home top)
         (for This (: gui)
            (or (: id) (setq *Chart This))
            (upd> This) ) ) ) )


# Choose a value
(class +ChoButton +Tiny +Tip +Button)

(dm T (Exe)
   (super  ,"Choose a suitable value" "+" Exe)
   (=: chg T) )


(class +PickButton +Tiny +Tip +Button)

(dm T (Exe)
   (super ,"Adopt this value" "@" Exe) )


(class +DstButton +Set +Able +Close +PickButton)
# msg obj

(dm T (Dst Msg)
   (=: msg (or Msg 'url>))
   (super
      '((Obj) (=: obj Obj))
      '(: obj)
      (when Dst
         (or
            (pair Dst)
            (list 'chgDst (lit Dst) '(: obj)) ) ) ) )

(de chgDst (This Val)
   (set> This (if (: new) (@ Val) Val)) )

(dm js> ()
   (cond
      ((: act) (super))
      ((try (: msg) (: obj) 1 This)
         (pack "@&+" (ht:Fmt (sesId (mkUrl @)))) )
      (T "@") ) )

(dm show> (Var)
   (if (: act)
      (super Var)
      (") )

(de  (X Y . Prg)
   (prin "")
   (htPrin Prg 2)
   (prinl "") )

(de font (X . Prg)
   (ifn Prg
      (cond
         ((num? X) (setq *FontSize X))
         ((sym? X) (setq *FontFamily X))
         (T (setq *FontSize (car X)  *FontFamily (fin X))) )
      (cond
         ((num? X)
            (let *FontSize X
               (run Prg 1) ) )
         ((sym? X)
            (let *FontFamily X
               (run Prg 1) ) )
         (T
            (let (*FontSize (car X)  *FontFamily (fin X))
               (run Prg 1) ) ) ) ) )

(de width (N . Prg)
   (ifn Prg
      (setq *StrokeWidth N)
      (let *StrokeWidth N
         (run Prg 1) ) ) )

(de italic Prg
   (let *FontStyle 'italic
      (run Prg) ) )

(de bold Prg
   (let *FontWeight 'bold
      (run Prg) ) )

(de indent (X . Prg)
   (prinl "")
   (dec '*DX X)
   (prog1
      (run Prg)
      (prinl "") ) )

(de rotate (A . Prg)
   (prinl "")
   (prog1
      (run Prg)
      (prinl "") ) )

(de scale (X Y . Prg)
   (prinl "")
   (prog1
      (run Prg)
      (prinl "") ) )

(de window (X Y *DX *DY . Prg)
   (prinl "")
   (let *Pos 0
      (prog1
         (run Prg)
         (prinl "") ) ) )

(de ps @
   (let A (arg 1)
      (if (memq A (0 NIL T))
         (next)
         (off A) )
      (prin
         "")
   (let H NIL
      (while (args)
         (let X (next)
            (cond
               ((pair X)
                  (casq (++ X)
                     (B  # Bold
                        (prin (if X "" "")) )
                     (I  # Italic
                        (prin (if X "" "")) )
                     (S  # Superscript
                        (prin (if X "" "")) )
                     (U  # Underline
                        (prin (if X "" "")) )
                     (L  # Line through
                        (prin (if X "" "")) )
                     (C  # Color
                        (if X
                           (prin "")
                           (prin "") ) ) ) )
               ((=0 X)  # Newline
                  (prin
                     "\8203\" ) )  # ZERO WIDTH SPACE
               ((=T X)  # Horizontal line
                  (push 'H (- *Pos (/ *FontSize 2)))
                  (prin
                     "\8203\" ) )  # ZERO WIDTH SPACE
               (T (ht:Prin X)) ) ) )
      (prinl "")
      (for Y H
         (polyline "black" 0 Y *DX Y) ) ) )

(de height @
   (let H *FontSize
      (while (args)
         (let X (next)
            (cond
               ((=0 X) (inc 'H *FontSize))  # Newline
               ((=T X) (inc 'H (*/ *FontSize 2 3))) ) ) )  # Horizontal line
      H ) )

(local) (down table hline vline)
(private) (Fmt Prg)

(de down (N)
   (inc '*Pos (or N *FontSize)) )

(de table (Fmt . Prg)
   (let (PosX 0  Max *FontSize)
      (ifn (=T Fmt)
         (mapc
            '((N Exe)
               (when
                  (or
                     (nT (car (pair Exe)))
                     (setq Exe (run (cdr Exe) 2)) )
                  (window PosX *Pos N Max
                     (if (atom Exe)
                        (ps NIL (eval Exe 3))
                        (eval Exe 3) )
                     (inc 'PosX N)
                     (setq Max (max *Pos Max)) ) ) )
            Fmt
            Prg )
         (for
            (N (co 'table (run Prg) (yield))
               N
               (window PosX *Pos N Max
                  (prog1
                     (co 'table T)
                     (inc 'PosX N)
                     (setq Max (max *Pos Max)) ) ) ) )
         (co 'table) )
      (inc '*Pos Max) ) )

(de hline (Y X2 X1)
   (inc 'Y *Pos)
   (polyline "black" (or X2 *DX) Y (or X1 0) Y) )

(de vline (X Y2 Y1)
   (polyline "black" X (or Y2 *DY) X (or Y1 0)) )

(local) brief
(private) (Flg Font Abs Prg)

(de brief (Flg Font Abs . Prg)
   (when Flg
      (polyline "black" 10 265  19 265)         # Faltmarken
      (polyline "black" 10 421  19 421) )
   (polyline "black" 50 106  50 103  53 103)    # Fenstermarken
   (polyline "black" 50 222  50 225  53 225)
   (polyline "black" 288 103  291 103  291 106)
   (polyline "black" 288 225  291 225  291 222)
   (polyline "black" 50 114  291 114)           # Absender
   (window 60 102 220 10
      (font Font (ps 0 Abs)) )
   (window 65 125 210 90
      (run Prg 2) ) )

(local) (svgOut svgPages page page.svg svgPdf pdf)
(private) (Src Dst Prg Prg2)

# Direct SVG display
(de svgOut Prg
   (httpHead "image/svg+xml" 0)
   (ht:Out *Chunked (run Prg)) )

# Multipage SVG
(de svgPages (*DX *DY Dst . Prg)
   (zero *Page)
   (out Dst
      (let page
         '(Prg2
            (prin "<" (inc '*Page) ">")
            ( *DX *DY "pt"
               (run Prg2) ) )
         (run Prg) ) )
   (allow Dst) )

(de page.svg (File N)
   (in File
      (from (pack "<" N ">"))
      (echo (pack "<" (inc N) ">")) ) )

# Convert to PDF
(de svgPdf (Dst . Prg)
   (let Src (tmp "pdf.svg")
      (out Src (run Prg))
      (call "rsvg-convert" "-f" "pdf" "-o" Dst Src) )
   (allow Dst) )

# Multipage PDF
# (pdf "src" "dst")
# (pdf 'dx 'dy "dst" . prg)
(de pdf (*DX *DY Dst . Prg)
   (if Dst
      (let page  # Generate SVG files
         '(Prg2
            (out (tmp "page" (inc '*Page) ".svg")
               ( *DX *DY "pt"
                  (run Prg2) ) ) )
         (zero *Page)
         (run Prg) )
      (in *DX  # Multipage SVG file
         (when (echo (pack "<" (one *Page) ">"))
            (while
               (out (tmp "page" *Page ".svg")
                  (when (echo (pack "<" (inc *Page) ">"))
                     (inc '*Page) ) ) ) ) )
      (setq Dst *DY) )
   (apply call
      (make
         (for I *Page
            (link (tmp "page" I ".svg")) ) )
      "rsvg-convert"
      "--dpi-x" 72
      "--dpi-y" 72
      "-f" "pdf"
      "-o" Dst )
   (allow Dst) )

### Debug ###
`*Dbg

(noLint 'page)


================================================
FILE: lib/term.l
================================================
# 29aug23 Software Lab. Alexander Burger

(sysdefs "terminal")

(local) (ULINE U-OFF REVERS)

(de ULINE . "4")
(de U-OFF . "24")
(de REVERS . "7")

(local) (RED GREEN BROWN BLUE PURPLE CYAN YELLOW)

(de RED . "0;31")
(de GREEN . "0;32")
(de BROWN . "0;33")
(de BLUE . "0;34")
(de PURPLE . "0;35")
(de CYAN . "0;36")
(de YELLOW . "1;33")

(local) (*AttrA *AttrU)

(off *AttrA *AttrU)

(local) (*Lines *Columns xterm getTerm setTerm getSize)

(de xterm ()
   (member (sys "TERM") '("xterm" "screen")) )

(de getTerm ()
   (use Lst
      (and
         (=0
            (%@ "ioctl" 'I 1 TIOCGWINSZ
               '(Lst (`winsize W W W W)) ) )
         Lst ) ) )

(de setTerm (Term Rows Cols DX DY)
   (sys "TERM" Term)
   (sys "LINES" Rows)
   (sys "COLUMNS" Cols)
   (%@ "ioctl" 'I 1 TIOCSWINSZ
      (cons NIL (`winsize)
         (cons Rows 2)  # ws_row
         (cons Cols 2)  # ws_col
         (cons DX 2)  # ws_xpixel
         (cons DY 2) ) )  # ws_ypixel
   (%@ "rl_reset_terminal" 'I 0) )

(de getSize ()
   (if (getTerm)
      (setq *Lines (car @)  *Columns (cadr @))
      (quit "Can't get terminal size") ) )

(local) (attr cup clreol hideCsr showCsr screen1 screen2)

(de attr (A U)
   (if2 (<> A *AttrA) (<> U *AttrU)
      (prin "\e["
         (or (setq *AttrA A) 0)
         ";"
         (if (setq *AttrU U) ULINE U-OFF)
         "m" )
      (prin "\e[" (or (setq *AttrA A) 0) "m")
      (prin "\e[" (if (setq *AttrU U) ULINE U-OFF) "m") ) )

(de cup (Y X)
   (prin "\e[" Y ";" X "H") )

(de clreol ()
   (prin "\e[0K") )

(de clear ()
   (prin "\e[H\e[J") )

(de hideCsr ()
   (prin "\e[?25l") )

(de showCsr ()
   (prin "\e[?25h") )

(de screen1 ()
   (if (xterm)
      (prin "\e[?1049l")
      (cup *Lines 1) )
   (flush) )

(de screen2 ()
   (and (xterm) (prin "\e[?1049h")) )

### Debug ###
`*Dbg

(noLint 'RED)


================================================
FILE: lib/test.l
================================================
# 04jul21 Software Lab. Alexander Burger

### Unit Tests ###
# Local usage:
# ./pil lib/test.l -bye +

# Global usage:
# pil @lib/test.l -bye +

(unless *Dbg
   (quit "Needs debug mode '+'") )

(setq
   *CMD (cmd)
   *PWD (in '(pwd) (line T)) )

(load
   "@test/src/main.l"
   "@test/src/apply.l"
   "@test/src/flow.l"
   "@test/src/sym.l"
   "@test/src/subr.l"
   "@test/src/big.l"
   "@test/src/io.l"
   "@test/src/db.l"
   "@test/src/net.l"
   "@test/src/ext.l"
   "@test/src/ht.l" )

(load "@test/lib.l")
(load "@test/lib/db.l")
(load "@test/lib/misc.l")

(load "@test/lib/lint.l")

(load "@test/lib/math.l")

(msg 'OK)


================================================
FILE: lib/too.l
================================================
# 27oct23 Software Lab. Alexander Burger

(private) (Prg C Q X Y Cls Name)

(de admin Prg
   (out 2
      (prinl *Pid " + Admin " (stamp))
      (tell 'bye)
      (for (F . @) (or *Dbs (2))
         (when (dbck F)
            (quit "DB Check" (cons F @)) ) )
      (run Prg)
      (when (load "@lib/dbgc.l")
         (prinl "dbgc " @) )
      (prinl *Pid " - Admin " (stamp)) ) )

### Local Backup ###
(de snapshot (Dst . @)
   (when (info (pack Dst "/1"))
      (for (L (flip (sort (extract format (dir Dst))))  L)
         (let N (++ L)
            (call "mv" (pack Dst '/ N) (pack Dst '/ (inc N)))
            (when (> (car L) (*/ N 59 60))
               (call "rm" "-rf" (pack Dst '/ (++ L))) ) ) ) )
   (when (call "mkdir" (pack Dst "/1"))
      (let Ign NIL
         (while (args)
            (let A (next)
               (if (pre? "-" A)
                  (push 'Ign (pack (cdr (chop A))))
                  (let
                     (Lst (filter bool (split (chop A) '/))
                        Src (car Lst)
                        Old (pack Dst "/2/" Src)
                        New (pack Dst "/1/" Src) )
                     (recur (Lst Src Old New)
                        (ifn (cdr Lst)
                           (recur (Src Old New)
                              (unless (member Src Ign)
                                 (cond
                                    ((=T (car (info Src T)))  # Directory
                                       (call "mkdir" "-p" New)
                                       (for F (dir Src T)
                                          (unless (member F '("." ".."))
                                             (recurse
                                                (pack Src '/ F)
                                                (pack Old '/ F)
                                                (pack New '/ F) ) ) )
                                       (call "touch" "-r" Src New) )
                                    ((= (info Src T) (info Old T))  # Same
                                       (%@ "link" 'I Old New) )
                                    (T (call "cp" "-a" Src New)) ) ) )  # Changed or new
                           (call "mkdir" "-p" New)
                           (recurse
                              (cdr Lst)
                              (pack Src '/ (cadr Lst))
                              (pack Old '/ (cadr Lst))
                              (pack New '/ (cadr Lst)) )
                           (call "touch" "-r" Src New) ) ) ) ) ) ) ) ) )

(de purge (Dst N)
   (for D (dir Dst)
      (when (>= (format D) N)
         (call "rm" "-rf" (pack Dst '/ D)) ) ) )

### DB Garbage Collection ###
(de dbgc ()
   (load "@lib/dbgc.l") )

### DB Mapping ###
(private) (ObjFun TreeFun Hook Base)

(de dbMap (ObjFun TreeFun)
   (default ObjFun quote TreeFun quote)
   (finally (mark 0)
      (_dbMap *DB)
      (dbMapT *DB) ) )

(de _dbMap (Hook)
   (unless (mark Hook T)
      (ObjFun Hook)
      (for X (getl Hook)
         (when (pair X)
            (if
               (and
                  (ext? (car X))
                  (not (isa '+Entity (car X)))
                  (sym? (cdr X))
                  (find
                     '((X) (isa '+relation (car X)))
                     (getl (cdr X)) ) )
               (let (Base (car X)  Cls (cdr X))
                  (dbMapT Base)
                  (for X (getl Base)
                     (when
                        (and
                           (pair X)
                           (sym? (cdr X))
                           (pair (car X))
                           (num? (caar X))
                           (ext? (cdar X)) )
                        (TreeFun Base (car X) (cdr X) Cls Hook)
                        (iter (tree (cdr X) Cls Hook) _dbMap) ) )
                  (wipe Base) )
               (dbMapV (car X)) ) ) )
      (wipe Hook) ) )

(de dbMapT (Base)
   (let X (val Base)
      (when
         (and
            (pair X)
            (num? (car X))
            (ext? (cdr X)) )
         (TreeFun Base X)
         (iter Base dbMapV) ) ) )

(de dbMapV (X)
   (while (pair X)
      (dbMapV (++ X)) )
   (and (ext? X) (_dbMap X)) )

(de refObj (Obj Flg)
   (make
      (recur (Obj)
         (for (F . @) (or *Dbs (2))
            (for (This (seq F) This (seq This))
               (when
                  (or
                     (fish == (val This) NIL Obj)
                     (fish == (getl This) NIL Obj) )
                  (if (and Flg (: T))
                     (recurse This)
                     (link This) ) ) ) ) )
      (for L *ExtDBs  # ("path/"  )
         (let ((P N E) L  Lck)
            (for I N
               (let (Fd (open (pack P (hax (dec I))))  (Cnt . Siz) (blk Fd 0))
                  (and (=1 I) (setq Lck Fd))
                  (for Blk (dec Cnt)
                     (let B (ext E (blk Fd Blk Siz Lck))
                        (when (fish == B NIL Obj)
                           (link (cons P (id I Blk))) ) ) )
                  (close Fd) ) ) ) ) ) )

### DB Check ###
(de dbCheck ()
   (for (F . N) (or *Dbs (2))  # Low-level integrity check
      (unless (pair (println F N (dbck F T)))
         (quit 'dbck @) ) )
   (dbSync)
   (dbMap  # Check tree structures
      NIL
      '((Base Root Var Cls Hook)
         (println Base Root Var Cls Hook)
         (unless (= (car Root) (chkTree (cdr Root)))
            (quit "Tree size mismatch") )
         (when Var
            (scan (tree Var Cls Hook)
               '((K V)
                  (or
                     (isa Cls V)
                     (isa '+Alt (meta V Var))
                     (quit "Bad Type" V) )
                  (unless (has> V Var (if (pair K) (car K) K))
                     (quit "Bad Value" K) ) )
               NIL T T ) ) ) )
   (and *Dbs (dbfCheck))  # Check DB file assignments
   (and (dangling) (println 'dangling @))  # Show dangling index references
   (and (badECnt) (println 'badECnt @))  # Show entity count mismatches
   (rollback) )

# Check Index References
(de dangling ()
   (make
      (for (F . @) (or *Dbs (2))
         (for (Obj (seq F) Obj (seq Obj))
            (and
               (isa '+Entity Obj)
               (dangle Obj)
               (link @) )
            (wipe Obj) ) ) ) )

(de dangle (This)
   (unless (: T)
      (and
         (make
            (for X (getl This)
               (let V (or (atom X) (++ X))
                  (unless (rel?> This X V)
                     (link X) ) ) ) )
         (cons This @) ) ) )

# Entity Counts
(de badECnt ()
   (let Cnt NIL
      (for (F . @) (or *Dbs (2))
         (for (This (seq F) This (seq This))
            (and
               (isa '+Entity This)
               (not (: T))
               (for Cls (type This)
                  (recur (Cls)
                     (or
                        (== '+Entity Cls)
                        (when (isa '+Entity Cls)
                           (for C (type Cls)
                              (recurse C) )
                           (accu 'Cnt Cls 1) ) ) ) ) ) ) )
      (filter
         '((X)
            (<> (cdr X) (get *DB (car X) 0)) )
         Cnt ) ) )

(de fixECnt ()
   (for X (getl *DB)
      (and (pair X) (set (car X) 0)) )
   (for (F . @) (or *Dbs (2))
      (for (This (seq F) This (seq This))
         (and
            (isa '+Entity This)
            (not (: T))
            (incECnt This) )
         (at (0 . 10000) (commit)) ) )
   (commit) )

(de badDep (X Var)
   (let Lst (get (fin X) Var 'dep)
      (make
         (forall X
            (unless (get This Var)
               (when
                  (extract
                     '((S) (and (get This S) S))
                     Lst )
                  (link (cons This @)) ) ) ) ) ) )

### Rebuild tree ###
(de rebuild (X Var Cls Hook)
   (let Lst NIL
      (let? Base (get (or Hook *DB) Cls)
         (unless X
            (setq Lst
               (if (; (treeRel Var Cls) hook)
                  (collect Var Cls Hook)
                  (collect Var Cls) ) ) )
         (zapTree (get Base Var -1))
         (put Base Var NIL)
         (commit) )
      (nond
         (X
            (let Len (length Lst)
               (recur (Lst Len)
                  (unless (=0 Len)
                     (let (N (>> 1 (inc Len))  L (nth Lst N))
                        (re-index (car L) Var Hook)
                        (recurse Lst (dec N))
                        (recurse (cdr L) (- Len N)) ) ) ) ) )
         ((atom X)
            (for Obj X
               (re-index Obj Var Hook) ) )
         (NIL
            (for (Obj (seq X) Obj (seq Obj))
               (and (isa Cls Obj) (re-index Obj Var Hook)) ) ) )
      (commit) ) )

(de re-index (Obj Var Hook)
   (unless (get Obj T)
      (when (get Obj Var)
         (rel> (meta Obj Var) Obj NIL
            (put> (meta Obj Var) Obj NIL @)
            Hook )
         (at (0 . 10000) (commit)) ) ) )

### Database file management ###
(de dbfCheck ()
   (for Cls (all)
      (when
         (and
            (= `(char "+") (char Cls))
            (isa '+Entity Cls)
            (not (isa '+Remote Cls)) )
         (or
            (; Cls Dbf)
            (meta Cls 'Dbf)
            (println 'dbfCheck Cls) )
         (for Rel (getl Cls)
            (and
               (pair Rel)
               (isa '+relation (car Rel))
               (or
                  (isa '+index (car Rel))
                  (isa '+Swap (car Rel))
                  (find
                     '((B)
                        (or
                           (isa '+index B)
                           (isa '+Swap B) ) )
                     (; Rel 1 bag) ) )
               (not (; @ dbf))
               (println 'dbfCheck (cdr Rel) Cls) ) ) ) ) )

(de displaced ()
   (make
      (for (F . @) *Dbs
         (for (Obj (seq F) Obj (seq Obj))
            (when
               (or
                  (isa '+Remote Obj)
                  (and
                     (isa '+Entity Obj)
                     (<>
                        (meta Obj 'Dbf 1)
                        (car (id Obj T)) ) ) )
               (link Obj) )
            (wipe Obj) ) ) ) )

### Relocate Object ###
(dm (move!> . +Entity) (Dbf)
   (for L *ExtDBs  # ("path/"  )
      (let ((P N E) L  Lck)
         (for I N
            (let (Fd (open (pack P (hax (dec I))))  (Cnt . Siz) (blk Fd 0))
               (finally (close Fd)
                  (and (=1 I) (setq Lck Fd))
                  (for Blk (dec Cnt)
                     (let B (ext E (blk Fd Blk Siz Lck))
                        (when (fish == B NIL This)
                           (quit "Can't move" (cons P (id I Blk))) ) ) ) ) ) ) ) )
   (dbSync)
   (let New
      (new
         (or Dbf (meta This 'Dbf 1))
         (val This) )
      (for X (getl This)
         (if (atom X)
            (ifn (meta This X)
               (put New X T)
               (let Rel @
                  (if (isa '+Blob Rel)
                     (let F (blob This X)
                        (put> New X F)
                        (blob+ New X)
                        (%@ "unlink" NIL F) )
                     (lose> Rel This T)
                     (put> New X T) ) ) )
            (ifn (meta This (cdr X))
               (put New (cdr X) (car X))
               (lose> @ This (car X))
               (put> New (cdr X) (car X)) ) ) )
      (decECnt This)
      (=: T T)
      (for (F . @) *Dbs
         (for (Obj (seq F) Obj (seq Obj))
            (let L (getl Obj)
               (when (fish == L This)
                  (for X L
                     (let? Rel (and (pair X) (meta Obj (cdr X)))
                        (put> Obj (cdr X)
                           (fill
                              (if (isa '+Swap Rel)
                                 (val (car X))
                                 (car X) )
                              This
                              New ) ) ) ) ) ) ) )
      (commit 'upd)
      New ) )

### Dump Objects ###
(zero *DumpBlob)

(dm (dumpKey> . +Entity) ()
   (unless (: T)
      (pick
         '((X)
            (when (isa '+Key (meta This (fin X)))
               (if (meta This (fin X) 'hook)
                  (cons (fin X) (get This @) X)
                  (cons (fin X) X) ) ) )
         (getl This) ) ) )

(dm (dumpType> . +Entity) ()
   (type This) )

(dm (dumpValue> . +Entity) (X)
   X )

(de dump @
   (let C (cons 0 10000)
      (for (Q (pass search) (search Q))
         (let (Obj @  K (fin (dumpExt Obj)))
            (for X (getl Obj)
               (unless (or (= K (fin X)) (= `(char "+") (char (fin X))))
                  (let? Y (dumpValue> Obj X)
                     (cond
                        ((pair Y)
                           (prinl)
                           (space 3)
                           (if (atom (cdr Y))
                              (printsp (cdr Y))
                              (printsp (cadr Y))
                              (prin "`") )
                           (dumpVal (car Y)) )
                        ((isa '+Blob (meta Obj X))
                           (let F (blob Obj X)
                              (ifn (info F)
                                 (msg F " no blob")
                                 (prinl)
                                 (space 3)
                                 (prin Y " `(tmp " (inc '*DumpBlob) ")")
                                 (call "cp" "-a" F (tmp *DumpBlob)) ) ) )
                        (T
                           (prinl)
                           (space 3)
                           (print Y T) ) ) ) ) )
            (prinl " )") )
         (at C (println '(commit))) )
      (println '(commit)) ) )

(de dumpExt (Obj)
   (prin "(obj ")
   (let K (dumpKey> Obj)
      (ifn (last K)
         (print (dumpType> Obj) (id Obj T))
         (prin "(")
         (printsp (dumpType> Obj) (car K))
         (dumpVal (cadr K))
         (when (pair (cddr K))
            (space)
            (dumpVal (car @)) )
         (prin ")") )
      K ) )

(de dumpVal (X)
   (nond
      ((atom X)
         (prin "(")
         (dumpVal (++ X))
         (while (pair X)
            (space)
            (dumpVal (++ X)) )
         (when X (prin " . ") (dumpVal X))
         (prin ")") )
      ((ext? X) (print X))
      ((type X) (print (val X)))
      (NIL (prin "`") (dumpExt X) (prin ")")) ) )

# Dump/load data and blobs
(de dumpDB (Name . Prg)
   (out (pack Name ".l") (run Prg))
   (when (dir (tmp))
      (out (pack Name ".tgz")
         (chdir (tmp)
            (in (append '("tar" "cfz" "-") (filter format @))
               (echo) ) ) ) ) )

(de loadDB (Name)
   (let Tgz (pack Name ".tgz")
      (when (and (info Tgz) (n0 (car @)))
         (in Tgz
            (chdir (tmp)
               (out '("tar" "xfz" "-") (echo)) ) ) ) )
   (load (pack Name ".l") ) )


================================================
FILE: lib/ulimit.l
================================================
# 27aug25 Software Lab. Alexander Burger

(symbols 'ulimit 'pico)

(local) (RLIMIT_STACK RLIMIT_NOFILE RLIMIT_NPROC stack files nproc)
(private) (error rlimit)

(sysdefs "ulimit")

(de error ()
   (quit (%@ "strErrno" 'S) 'ulimit) )

(de rlimit (Res Val U)
   (use Lim
      (nond
         ((=0
               (%@ "getrlimit" 'I Res '(Lim (16 P P))) )
            (error) )
         (Val
            (cons
               (*/ (car Lim) U)
               (*/ (cadr Lim) U) ) )
         ((=0
               (%@ "setrlimit" 'I Res
                  (list NIL (16)
                     (cons (* Val U) 8)
                     (cons (cadr Lim) 8) ) ) )
            (error) )
         (NIL Val) ) ) )

# (ulimit~stack ['cnt))
(de stack (KiB)
   (prog1
      (rlimit RLIMIT_STACK KiB 1024)
      (%@ "ulimStk") ) )

# (ulimit~files ['cnt))
(de files (N)
   (rlimit RLIMIT_NOFILE N 1) )

# (ulimit~nproc ['cnt))
(de nproc (N)
   (rlimit RLIMIT_NPROC N 1) )


================================================
FILE: lib/user.l
================================================
# 18oct21 Software Lab. Alexander Burger

(must "User Administration" UserAdmin (== *Login *ID))

(menu ,"User Administration"
   (idForm ,"User" '(choUser) 'nm '+User
      '(or (may UserAdmin) (== *Login (: home obj)))
      '(or (may Delete) (== *Login (: home obj)))
      '((: nm) )
      ( 2
         ,"Login Name" (gui '(+E/R +Cue +TextField) '(nm : home obj) ,"User" 30)
         ,"Password"
         (gui '(+Able +PasswdField)
            '(or (may Password) (== *Login (: home obj)))
            30 )
         ,"Role"
         (gui '(+Able +E/R +Obj +TextField)
            '(may RoleAdmin)
            '(role : home obj)
            '(nm +Role)
            T ) )
      (--)
      (gui> (: obj) This) ) )


================================================
FILE: lib/vip/cal.rc.l
================================================
# 26mar26 Software Lab. Alexander Burger

(symbols '(pico)
   (load "@lib/misc.l") )

(private) (*Cal *Pat slot entry calFile patFile findCal drawCal loadCal)

(de *Cal . "~/.pil/cal/")

(cmd "cal" (L Lst Cnt)
   (let
      (D (date (date))
         M (car (setq L (str L)))
         Y (cadr L) )
      (drawCal
         (or (index M *Mon) M (cadr D))
         (ifn Y
            (car D)
            (if
               (and
                  (>= 99 Y)
                  (>= (inc 'Y 2000) (+ 9 (car D))) )
               (- Y 100)
               Y ) ) ) )
   (setq *Search
      '((L C)
         (or
            (head '("·" "=") L)
            (and (sp? C) (= "=" (car L))) ) ) )
   (=: buffer keys
      (quote
         ("K"  # Edit
            (if (get (: buffer text) (: posY) (: posX) 'cal)
               (loadCal @)
               (beep) ) )
         ("w" (move 'goForward 'slot *Cnt))  # Slot forward
         ("b" (move 'goBackward 'slot *Cnt))  # Slot backward
         ("W" (move 'goForward 'entry *Cnt))  # Entry forward
         ("B" (move 'goBackward 'entry *Cnt))  # Entry backward
         ("\e[A"  # UP
            (findCal flip
               (P) (and (=0 (dec P)) (set P 12)) ) )
         ("\e[B"  # DOWN
            (findCal prog
               (P) (and (== 13 (inc P)) (set P 1)) ) )
         ("\e[C"  # RIGHT
            (if (== 12 (: buffer mon))
               (drawCal 1 (inc (: buffer year)))
               (drawCal (inc (: buffer mon)) (: buffer year)) ) )
         ("\e[D"  # LEFT
            (if (=1 (: buffer mon))
               (drawCal 12 (dec (: buffer year)))
               (drawCal (dec (: buffer mon)) (: buffer year)) ) ) ) )
   (let *Class (: buffer)
      (dm search> (Win Pat)
         (setq *Pat (append '(@) Pat '(@)))
         '((L)
            (and
               (= "·" (car L))
               (; L 1 cal)
               (info (calFile @))
               (patFile @@) ) ) ) )
   (let *Class This
      (dm status> (A F Z)
         (let? Dat
            (get
               (: buffer text)
               (: posY)
               (: posX)
               'cal )
            (when (and (: buffer mon) (member NIL (: buffer text)))
               (con @
                  (make
                     (for I 7
                        (let D (+ Dat I -1)
                           (link
                              (conc
                                 (chop (day D *Day))
                                 (list " ")
                                 (chop (datSym D)) ) )
                           (when (info (calFile D))
                              (for L (in @@ (rdLines))
                                 (link (append '(" " " " " ") L)) ) )
                           (link NIL) ) ) ) )
               (drawin)
               (setq F (day Dat)  Z (dat$ Dat "-")) ) )
         (super A F Z) ) ) )

(de slot (L C)
   (and (sp? C) (; L 1 cal)) )

(de entry (L)
   (= "·" (car L)) )

(de calFile (Dat)
   (pack *Cal (glue "/" (date Dat))) )

(de patFile (F)
   (find
      '((L) (match *Pat L))
      (in F (rdLines)) ) )

(de findCal (Fun1 . Fun2)
   (let
      (Y
         (member
            (format (: buffer year))
            (Fun1 (sort (dir *Cal))) )
         M (: buffer mon) )
      (loop
         (T (and (Fun2 'M) (not (shift 'Y)))
            (beep) )
         (T
            (and
               (info (pack *Cal (car Y) "/" M))
               (find
                  '((F)
                     (patFile (pack *Cal (car Y) "/" M "/" F)) )
                  (dir @@) ) )
            (goto 4 3)
            (keys '("n"))
            (drawCal M (format (car Y))) ) ) ) )

(de drawCal (Mon Year)
   (with
      (scratch (tmp "cal")
         (let
            (Dat (date Year Mon 1)
               Skip (% (inc Dat) 7)
               Day 1 )
            (make
               (link
                  (chop (pack "              " (get *Mon Mon) " " Year))
                  (chop "    Mon Tue Wed Thu Fri Sat Sun") )
               (loop
                  (link
                     (make
                        (chain (chop (align 2 (week Dat))))
                        (link (name " "))
                        (do 7
                           (NIL
                              (if (ge0 (dec 'Skip))
                                 (chain (chop "    "))
                                 (link (name " "))
                                 (let L
                                    (chop
                                       (pack
                                          (and (info (calFile Dat)) "·")
                                          (if (= (date) Dat) "==" Day) ) )
                                    (or (cdr L) (link (name " ")))
                                    (or (cddr L) (link (name " ")))
                                    (mapc put (chain L) 'cal Dat) )
                                 (setq Dat (date Year Mon (inc 'Day)))) ) ) ) )
                  (NIL Dat) )
               (link NIL) ) )
         3 )
      (=: mon Mon)
      (=: year Year) ) )

(de loadCal (Dat)
   (reload (calFile Dat))
   (evCmd (day (=: buffer cal Dat) *Day))
   (=: buffer keys
      (quote
         ("\e[C"  # RIGHT
            (let B (: buffer)
               (loadCal (+ (: buffer cal) *Cnt))
               (delBuf B)
               (repaint) ) )
         ("\e[D"  # LEFT
            (let B (: buffer)
               (loadCal (- (: buffer cal) *Cnt))
               (delBuf B)
               (repaint) ) ) ) )
   (let *Class (: buffer)
      (dm save> (Win)
         (call "mkdir" "-p" (dirname (: file)))
         (super Win)
         (unless (: text)
            (call "rm" (: file)) )
         (let ((Y M) (date (: cal)))
            (with Win (drawCal M Y)) ) ) ) )

NIL

The above code implements a ":cal" (calendar) command for Vip.

To enable it, include the line

   (load "@lib/vip/cal.rc.l")

in your "~/.pil/viprc" (or in a local ".viprc") file.


The calendar opens in a new buffer with

   :cal

to display the current month. You can pass a month name (starting with
an uppercase letter) or a number to display another month of the current
year:

   :cal Nov
   :cal 11

You can also specify a year:

   :cal Jan 2026
   :cal 1 2026

If you enter only two digits for the year, the corresponding year within
the range −90 .. +10 years from the current year is chosen:

   :cal Jan 26


Use the RIGHT and LEFT arrow keys to skip to the next or previous month.

"Today" is indicated by "==". The editor's search pattern is initialized
to this marker, so pressing "n" (the Vip command for “search next”)
jumps to today’s date.

The editor commands "w" (move word forward) and "b" (move word backward)
are redefined for this buffer to move to the next or previous day,
respectively.

Pressing "K" on a day opens a new buffer for that date’s file in the
"~/.pil/cal/" directory tree. The file is automatically created when you
add text and save it (e.g. with ":w" or ":x"), and it is deleted if the
text is empty. While editing a day, the RIGHT and LEFT arrow keys move
directly to the next or previous day.

In the calendar window, days that have an associated file (i.e. contain
text) are marked with a "·" character. The "W" (move long word forward)
and "B" (move long word backward) commands move to the next or previous
non-empty day.

When you move the cursor to a day, the text contents of the following
week are displayed below the calendar.

If you enter a new search pattern using the "/" or "?" command, the
initial search for "today" is replaced by a search through the daily
text files of that month. Using the DOWN and UP arrow keys then
continues the search in the next or previous months, jumping directly to
matching days.


================================================
FILE: lib/vip/draw.l
================================================
# 19oct23 Software Lab. Alexander Burger

(symbols 'vip~draw 'vip 'pico)

(local) (*DX *DY *PX *PY *Draw *Boxes)

(zero *DX *DY)

# Drawing primitives
(local) (point hline vline go up down left right rect label)

(de point (X Y C)
   (inc 'X *DX)
   (inc 'Y *DY)
   (let P
      (or
         (nth *Draw Y)
         (nth (setq *Draw (need (- Y) *Draw)) Y) )
      (set
         (or
            (nth (car P) X)
            (nth
               (set P (need (- X) (car P) (name " ")))
               X ) )
         (name C) ) ) )

(de hline (C X Y X2 A)
   (point X Y C)
   (if (> X2 X)
      (do (- X2 X)
         (point (inc 'X) Y "-") )
      (do (- X X2)
         (point (dec 'X) Y "-") ) )
   (and A (point X Y A)) )

(de vline (C X Y Y2 A)
   (point X Y C)
   (if (> Y2 Y)
      (do (- Y2 Y)
         (point X (inc 'Y) "|") )
      (do (- Y Y2)
         (point X (dec 'Y) "|") ) )
   (and A (point X Y A)) )

(de go (X Y C)
   (point (setq *PX X) (setq *PY Y) C) )

(de up (N C)
   (vline "|" *PX (dec *PY) (dec '*PY N) C) )

(de down (N C)
   (vline "|" *PX (inc *PY) (inc '*PY N) C) )

(de left (N C)
   (hline "-" (dec *PX) *PY (dec '*PX N) C) )

(de right (N C)
   (hline "-" (inc *PX) *PY (inc '*PX N) C) )

(de rect (X Y X2 Y2)
   (hline "+" X Y (dec X2))
   (vline "+" X2 Y (dec Y2))
   (hline "+" X2 Y2 (inc X))
   (vline "+" X Y2 (inc Y)) )

(de label (X Y Txt)
   (for C (chop Txt)
      (point X Y C)
      (inc 'X) ) )

# Box
(local) (+Box mx> my> hv>)

(class +Box)
# id x y x2 y2 dx dy h v

(dm mx> ()
   (*/ (+ (: x) (: x2)) 2) )

(dm my> ()
   (*/ (+ (: y) (: y2)) 2) )

(dm hv> ()
   (for L (: h)
      (loop
         (apply hline (++ L))
         (NIL L)
         (apply vline (++ L))
         (NIL L) ) )
   (for L (: v)
      (loop
         (apply vline (++ L))
         (NIL L)
         (apply hline (++ L))
         (NIL L) ) ) )


# Draw box
(local) (block box)
(private) (X Y DX DY Txt Prg)

(de block (X Y . Prg)
   (let (*DX (dec X)  *DY (dec Y))
      (run Prg) ) )

(de box (X Y DX DY Txt . Prg)
   (with
      (new '(+Box)
         'id (if (atom Txt) Txt (car Txt))
         'x (inc 'X *DX)
         'y (inc 'Y *DY)
         'x2 (+ X DX)
         'y2 (+ Y DY)
         'dx DX
         'dy DY )
      (queue '*Boxes This)
      (let (*DX 0  *DY 0)
         (rect (: x) (: y) (: x2) (: y2))
         (when (fin Txt)
            (label
               (+ (: x) (*/ (- (: dx) (length @)) 2))
               (+ (: y) (*/ (: dy) 2))
               @ ) ) )
      (let (*DX X  *DY Y)
         (run Prg) ) ) )

# Draw arrow
(local) arrow

(de arrow (Id1 Id2)
   (with
      (if (num? Id1)
         (get *Boxes Id1)
         (find '((This) (= Id1 (: id))) *Boxes) )
      (let? B
         (if (num? Id2)
            (get *Boxes Id2)
            (find '((This) (= Id2 (: id))) *Boxes) )
         (let (X (mx> This)  Y (my> This)  X2 (mx> B)  Y2 (my> B))
            (cond
               ((> (; B y) (: y2))  # Above
                  (cond
                     ((or
                           (>= 3 (- (; B y) (: y2)))
                           (>= (inc X2) X (dec X2)) )
                        (push (:: v)
                           (list
                              (list "+" X (: y2) (dec (; B y)) "v") ) ) )
                     ((> (; B y) (+ 4 (: y2)))
                        (push (:: v)
                           (let M (/ (+ (: y2) (; B y)) 2)
                              (list
                                 (list "+" X (: y2) (dec M))
                                 (list "+" X M X2)
                                 (list "+" X2 M (dec (; B y)) "v") ) ) ) )
                     ((> (; B x) (+ 2 X))  # Left
                        (push (:: v)
                           (list
                              (list "+" X (: y2) (dec Y2))
                              (list "+" X Y2 (dec (; B x)) ">") ) ) )
                     ((> X (+ 2 (; B x2)))  # Right
                        (push (:: v)
                           (list
                              (list "+" X (: y2) (dec Y2))
                              (list "+" X Y2 (inc (; B x2)) "<") ) ) ) ) )
               ((> (: y) (; B y2))  # Below
                  (cond
                     ((or
                           (>= 3 (- (: y) (; B y2)))
                           (>= (inc X2) X (dec X2)) )
                        (push (:: v)
                           (list
                              (list "+" X (: y) (inc (; B y2)) "\^") ) ) )
                     ((> (: y) (+ 4 (; B y2)))
                        (push (:: v)
                           (let M (*/ (+ (: y) (; B y2)) 2)
                              (list
                                 (list "+" X (: y) (inc M))
                                 (list "+" X M X2)
                                 (list "+" X2 M (inc (; B y2)) "\^") ) ) ) )
                     ((> (; B x) (+ 2 X))  # Left
                        (push (:: v)
                           (list
                              (list "+" X (: y) (inc Y2))
                              (list "+" X Y2 (dec (; B x)) ">") ) ) )
                     ((> X (+ 2 (; B x2)))  # Right
                        (push (:: v)
                           (list
                              (list "+" X (: y) (inc Y2))
                              (list "+" X Y2 (inc (; B x2)) "<") ) ) ) ) )
               (T  # Besides
                  (cond
                     ((> (; B x) (: x2))  # Left
                        (push (:: h)
                           (if (= Y Y2)
                              (list
                                 (list "+" (: x2) Y (dec (; B x)) ">") )
                              (let M (*/ (+ (: x2) (; B x)) 2)
                                 (list
                                    (list "+" (: x2) Y (dec M))
                                    (list "+" M Y Y2)
                                    (list "+" M Y2 (dec (; B x)) ">") ) ) ) ) )
                     ((> (: x) (; B x2))  # Right
                        (push (:: h)
                           (if (= Y Y2)
                              (list
                                 (list "+" (: x) Y (inc (; B x2)) "<") )
                              (let M (*/ (+ (: x) (; B x2)) 2)
                                 (list
                                    (list "+" (: x) Y (inc M))
                                    (list "+" M Y Y2)
                                    (list "+" M Y2 (inc (; B x2)) "<") ) ) ) ) ]

# Draw cell structures
(local) (cell cells)

(de cell (X Y Car Cdr)
   (let A (max 6 (+ 3 (length (setq Car (sym Car)))))
      (box X Y A 2
         (cons
            (pack (+ X *DX) "/" (+ Y *DY))
            Car )
         (let B 6
            (setq Cdr
               (cond
                  ((pair Cdr) "  ---")
                  (Cdr
                     (prog1
                        (sym @)
                        (setq B (max 6 (+ 3 (length @)))) ) )
                  (T "/") ) )
            (box A 0 B 2
               (cons (pack X "/" Y "+") Cdr) )
            (+ A B) ) ) ) )

(de cells (X Y Any)
   (let Pos (list X)
      (recur (Any Y Pos)
         (let (Y2 (+ Y *DY)  Last)
            (while (pair Any)
               (use D
                  (if (atom (car Any))
                     (setq D (cell (car Pos) Y (++ Any) Any))
                     (ifn (cdr Pos)
                        (con Pos (list (car Pos)))
                        (let (P @  M (car Pos))
                           (for (A (car Any) (pair A) (car A))
                              (setq M (max M (++ P))) )
                           (map
                              '((L) (set L (max M (car L))))
                              Pos ) ) )
                     (setq D
                        (cell (car Pos) Y '| (cdr Any)) )
                     (recurse (++ Any) (+ Y 5) (cdr Pos))
                     (let X2 (+ (car Pos) *DX)
                        (arrow
                           (pack X2 "/" Y2)
                           (pack X2 "/" (+ Y2 5)) ) ) )
                  (let X2 (+ (car Pos) *DX)
                     (when Last
                        (arrow @ (pack X2 "/" Y2)) )
                     (setq Last (pack X2 "/" Y2 "+")) )
                  (inc Pos (+ 6 D)) ) ) ) ) ) )

# Override +Buffer methods in object
(let? *Class (isa '+Buffer This)
   (dm view> (Win)
      (=: view T)
      (off *Draw *Boxes)
      (symbols '(vip~draw vip pico)
         (evCmd (load (fName (: file)))) )
      (mapc 'hv> *Boxes)
      (with Win
         (scratch (tmp "draw") *Draw) ) )
   (dm save> (Win)
      (super Win)
      (when (: view)
         (view> This Win) ) ) )

### Debug ###
`*Dbg

(de pico~cells @
   (off *Draw *Boxes)
   (let Y 1
      (while (args)
         (let V (next)
            (cond
               ((pair V)
                  (cells 1 Y V)
                  (setq Y (+ 3 (length *Draw))) )
               (V
                  (label 1 Y V)
                  (inc 'Y) ) ) ) ) )
   (mapc 'hv> *Boxes)
   (out (tmp "cells") (mapc prinl *Draw))
   (pico~vi (tmp "cells")) )


================================================
FILE: lib/vip/html.l
================================================
# 29oct23 Software Lab. Alexander Burger

# View HTML buffers
(let? *Class (isa '+Buffer This)
   (dm view> (Win)
      (=: view T)
      (with Win
         (let
            (Y (- (: posY) 13)
               N (- (length (: buffer text)) 15) )
            (scratch (tmp "html")
               (in (list "w3m" "-cols" *Columns (: buffer file))
                  (rdLines) ) )
            (unless (: buffer view)
               (goto 1 (*/ Y (length (: buffer text)) N)) ) ) ) )
   (dm save> (Win)
      (super Win)
      (when (: view)
         (view> This Win) ) ) )


================================================
FILE: lib/vip/load.l
================================================
# 10dec24 Software Lab. Alexander Burger

# View output of 'load'ing the file
(let? *Class (isa '+Buffer This)
   (dm view> (Win)
      (=: view T)
      (with Win
         (scratch (tmp "xml")
            (pipe (load (: buffer file))
               (rdLines) ) ) ) )
   (dm save> (Win)
      (super Win)
      (when (: view)
         (view> This Win) ) ) )


================================================
FILE: lib/vip.l
================================================
# 11dec25 Software Lab. Alexander Burger

(symbols 'vip 'pico)

(sysdefs "unistd")

(load "@lib/term.l")

(local) (*Ns *Shell *CmdWin *StatNm *Chr *Complete *Repeat *Change
*Count *Cnt *Search *Clip *TagStack *Spell *CmdMap *Keys *KeyMap
*KeyMap-g *KeyMap-q *F7 *F8 *F9 *F10 *F11 *F12 *@ *@@)

(def '*Shell (or (sys "SHELL") "sh"))

### VIP Editor ###
(local) (*Buffers +Buffer mkLoc fName prName rplFile fileBuffer rdLines
delim delimNs markup min1 undo redo evCmd dirty> load> save> syms>
search> view> status> status delwin cursor addLine chgLine drawin redraw
repaint scLeft scRight goto chgwin eqwin getch getch2 reload scratch
syms pushTag tag done change jmp@@ cnt@@ goCol goLeft goRight goUp
goDown goAbs goFind word lword tword end lend getWord _forward goForward
_backward goBackward goPFore goPBack shiftN shiftY indent cutX cutN paste
join tglCase insChar incNum overwrite _bs insMode cmdMode cmdPipe evRpt
move chgRight jmpMark wordFun moveSearch patMatch parMatch braces spell
pipeN nextBuf delBuf shell shFile prCmd cmd keys _map map+ map+g map+q
reset posChar getText s-expr command vipA vipZ vi)


(class +Buffer)
# text file cmd symbols key undo redo dirt cmds keys
# posX posY lastX lastY subd flat fmt syms 

(dm T (File Y)
   (and (=: file File) (queue '*Buffers This))
   (=: symbols (symbols))
   (=: posX 1)
   (=: posY (or Y 1))
   (=: lastX (=: lastY 1))
   (=: fmt 72) )

(de mkLoc (File)
   (let P (conc (chop (pwd)) '("/"))
      (when (head P File)
         (setq File (cdr (nth File (length P)))) ) )
   (if (pat? (car File))
      (cons (name ".") (name "/") File)
      File ) )

(de fName (File)
   (let? F (chop (setq File (path File)))
      (use R
         (pack
            (mkLoc
               (if (info File)
                  (if (=0 (%@ "realpath" 'N File '(R (`PATH_MAX C . `PATH_MAX))))
                     F R )
                  (let L (rot (split F "/"))
                     (if
                        (and
                           (cdr L)
                           (n0 (%@ "realpath" 'N (glue "/" @) '(R (`PATH_MAX C . `PATH_MAX)))) )
                        (conc R (list "/") (car L))
                        F ) ) ) ) ) ) ) )

(de prName (File)
   (if (pre? (sys "HOME") File)
      (pack "~/" (cddr (nth (chop File) (length (sys "HOME")))))
      File ) )

(de rplFile (File)
   (pack
      (replace (chop File) "%"
         (if (== This *CmdWin)
            (: next buffer file)
            (: buffer file) ) ) ) )

(de fileBuffer (File Y)
   (let F (fName File)
      (prog1
         (or
            (find '((This) (= F (: file))) *Buffers)
            (new '(+Buffer) F Y) )
         (put @ 'subd (<> "/" (last (chop File)))) ) ) )

(de rdLines ()
   (make (until (eof) (link (line)))) )

(de delim (C)
   (member C
      '`(cons NIL (chop " \t\n\r\"'(),[]`")) ) )

(de delimNs (C)
   (or (delim C) (= "~" C)) )

(de markup (Lst)
   (let (S 'text  N 1)
      (for L Lst
         (let P NIL
            (while L
               (let? C (++ L)
                  (state 'S
                     (text (and (= "\"" C) 'string)
                        (set C 0) )
                     (text
                        (and
                           (= "#" C)
                           (delim P)
                           (if L 'comment 'text) )
                        (set C N)
                        (when (= "{" (car L))
                           (set (++ L) (inc 'N)) ) )
                     (text 'text
                        (or
                           (set (setq P C)
                              (and (sp? C) (not L)) )
                           (when (= "\\" C)
                              (let? C (++ L)
                                 (set C (and (sp? C) (not L))) ) ) ) )
                     (string (and (= "\"" C) 'text)
                        (set (setq P C) 0) )
                     (string (and (= "\\" C) (not L) 'skip)
                        (set C T) )
                     (string 'string
                        (set C T)
                        (and (= "\\" C) L (++ L) (set @ T)) )
                     (skip (and (sp? C) 'skip)
                        (set C) )
                     (skip (and (= "\"" C) 'text)
                        (set (setq P C) 0) )
                     (skip 'string
                        (set C T) )
                     (comment
                        (cond
                           ((=1 (set (setq P C) N))
                              (if L
                                 'comment
                                 (and (sp? C) (not L) (set P T))
                                 'text ) )
                           ((and
                                 (= "}" C)
                                 (= "#" (car L))
                                 (=1 (set (++ L) (dec 'N))) )
                              'text )
                           (T
                              (and
                                 (= "#" C)
                                 (= "{" (car L))
                                 (set (++ L) (inc 'N)) )
                              'comment ) ) ) ) ) ) ) ) ) )

(de min1 (A B)
   (max 1 (min A B)) )

(dm dirty> (Win)
   (<> (: undo) (: dirt)) )

(dm load> (Win)
   (markup
      (=: text
         (let? File (: file)
            (let? I (info File)
               (if (=T (car I))
                  (mapcar
                     '((X)
                        (let (S (cdddr X)  F (caddr X))
                           (conc
                              (mkLoc F)
                              (cond
                                 ((=T S) (chop "/  "))
                                 ((not S)
                                    (conc
                                       (chop " -> ")
                                       (in (list "readlink" F) (line))
                                       (chop "  ") ) )
                                 (T
                                    (conc
                                       (chop " (")
                                       (chop (/ (+ S 1023) 1024))
                                       (chop ")  ") ) ) )
                              (chop (dat$ (- (car X)) "-"))
                              (chop " ")
                              (chop (tim$ (- (cadr X)) T)) ) ) )
                     (sort
                        (make
                           (unless (= "/" (last (setq File (chop File))))
                              (conc File (chop "/")) )
                           (recur (File)
                              (for F (dir File T)
                                 (unless (member F '("." ".."))
                                    (let? I (info (setq F (append File (chop F))) 0)
                                       (if (and (=T (car I)) (: subd))
                                          (recurse (conc F (chop "/")))
                                          (link
                                             (cons
                                                (- (cadr I))
                                                (- (cddr I))
                                                F
                                                (car I) ) ) ) ) ) ) ) ) ) )
                  (gc (+ 4 (*/ (car I) 32768)))  # 2 cells / char
                  (if (sys "CCRYPT" (: key))
                     (in (list "ccrypt" "-c" "-ECCRYPT" File)
                        (rdLines) )
                     (in File (rdLines)) ) ) ) ) ) )
   (=: symbols (symbols))
   (=: undo (=: redo (=: dirt)))
   (=: posX
      (min1
         (: posX)
         (length
            (get
               (: text)
               (=: posY (min1 (: posY) (length (: text)))) ) ) ) )
   (let? L
      (nth
         (find
            '((L) (head '`(chop "# VIP ") L))
            (head 3 (: text)) )
         7 )
      (evCmd
         (symbols '(vip pico)
            (case (car L)
               ("\"" (keys (chop (any L))))
               ("(" (run (str (pack L))))
               (T
                  (setq L (split L " "))
                  (apply script
                     (str (glue " " (cdr L)))
                     (path (car L)) ) ) ) ) ) ) )

(dm save> (Win)
   (when (: file)
      (unless (=T (car (info @)))
         (if (sys "CCRYPT" (: key))
            (pipe
               (out '("ccrypt" "-e" "-ECCRYPT")
                  (mapc prinl (: text)) )
               (out (: file) (echo)) )
            (out (: file) (mapc prinl (: text))) ) )
      (=: dirt (: undo))
      (for (This *CmdWin (this (: next)))
         (status) )
      (when (: syms)
         (and (find ext? @ T) (pico~dbSync))
         (in (: file)
            (while (and (setq "*X" (read)) (atom @))
               (unless (= (val "*X") (setq "*V" (read)))
                  (set "*X" "*V") )
               (until (= '(=======) (setq "*K" (read)))
                  (unless (= (get "*X" "*K") (setq "*V" (read)))
                     (put "*X" "*K" "*V") ) ) ) )
         (when (find ext? (: syms) T)
            (commit 'pico~upd)
            (syms> This (: syms)) ) ) )
   (on *StatNm) )

(dm syms> ("Lst")
   (out (: file)
      (for "S" (=: syms "Lst")
         (if
            (and
               (ext? "S" T)
               (not (rank (car (id "S" T)) *Ext))
               (lock "S") )
            (prinl "# " "S" " locked")
            (printsp "S")
            (fish
               '(("X")
                  (if (circ? "X")
                     "skip"
                     (and
                        (str? "X")
                        (or
                           (and (val "X") (n== @ "X"))
                           (getl "X") )
                        (intern "X" 'priv) )
                     NIL ) )
               (cons (val "S") (getl "S"))
               "skip" )
            (pretty (val "S"))
            (prinl)
            (for "X" (sort (getl "S"))
               (space 3)
               (if (atom "X")
                  (print "X" T)
                  (printsp (cdr "X"))
                  (pretty (setq "X" (car "X")) -3) )
               (remark "X")
               (prinl) ) )
         (prinl)
         (println '(=======))
         (prinl) ) ) )

(dm search> (Win @Pat)
   (ifn (= "\\" (car @Pat))
      (let @Lst 'L
         (when (= "~" (car @Pat))
            (setq
               @Pat (mapcar lowc (cdr @Pat))
               @Lst '(mapcar lowc L) ) )
         (if
            (nor
               (= "\^" (car @Pat))
               (= "$" (last @Pat))
               (find pat? @Pat) )
            (curry (@Pat @Lst) (L)
               (head '@Pat @Lst) )
            (setq @Pat
               (if (= "$" (last @Pat))
                  (head -1 @Pat)
                  (append @Pat '(@)) ) )
            (ifn (= "\^" (car @Pat))
               (curry (@Pat @Lst) (L)
                  (match '@Pat @Lst) )
               (++ @Pat)
               (curry (@Pat @Lst) (L C)
                  (unless C (match '@Pat @Lst)) ) ) ) )
      (++ @Pat)
      (curry (@Pat) (L)
         (head '@Pat L) ) ) )

(dm view> (Win)
   (beep) )


(local) (*Window +Window)

(class +Window)
# buffer top lines winX winY posX posY prev next last mark sc

(dm T (Buffer Top Lines WinX WinY PosX PosY Prev Mark)
   (=: buffer Buffer)
   (=: top Top)
   (=: lines Lines)
   (when (=: prev Prev)
      (when (=: next (: prev next))
         (=: next prev This) )
      (=: prev next This) )
   (=: winX WinX)
   (=: winY WinY)
   (=: posX PosX)
   (=: posY PosY)
   (=: mark Mark)
   (=: sc 0) )

(dm view> ()
   (view> (: buffer) This) )

(dm status> (A F Z)
   (cup (+ (: top) (: lines) 1) 1)
   (attr REVERS)
   (let N (- *Columns (length (prin A)))
      (cond
         ((ge0 (- N (length F) (length Z)))
            (prin F (need @ " ") Z) )
         ((onOff *StatNm) (prin (tail N (chop F))))
         (T (prin (need (- N (length Z)) " ") Z)) ) )
   (attr) )

(de delwin ()
   (when (=: prev next (: next))
      (=: next prev (: prev)) ) )

(de cursor ()
   (cup
      (+ (: top) (- (: posY) (: winY) -1))
      (- (: posX) (: winX) -1) ) )

(de addLine (Y L N)
   (cup (+ (: top) Y) 1)
   (clreol)
   (for C (nth L (: winX))
      (T (lt0 (dec 'N)))
      (cond
         ((: buffer flat))
         ((=T (val C))
            (cond
               ((= "^?" C)
                  (setq C "?")
                  (attr RED T) )
               ((>= "^_" C "^A")
                  (setq C (char (+ 64 (char C))))
                  (attr RED T) )
               (T (attr NIL T)) ) )
         ((= "^?" C)
            (setq C "?")
            (attr RED) )
         ((>= "^_" C "^A")
            (setq C (char (+ 64 (char C))))
            (attr RED) )
         ((gt0 (val C))
            (attr CYAN) )
         (T (attr)) )
      (prin C) )
   (attr) )

(de chgLine (L)
   (addLine (- (: posY) (: winY) -1) L *Columns)
   (cursor) )

(de status ()
   (unless (== This *CmdWin)
      (status> This
         (pack
            (index (: buffer) *Buffers)
            "/"
            (length *Buffers)
            (if (dirty> (: buffer) This) " * " " ") )
         (or (: buffer cmd) (prName (: buffer file)))
         (let N (length (: buffer text))
            (pack
               (and (: mark) (cons @ " "))
               (casq (: buffer symbols 1)
                  (pico)
                  (T (cons @ " ")) )
               (: posX) "," (: posY) "/" N " "
               (if (gt0 (dec N))
                  (*/ 100 (dec (: posY)) @)
                  0 )
               "%" ) ) )
      (flush) ) )

(de drawin ()
   (let L (nth (: buffer text) (: winY))
      (for Y (: lines)
         (addLine Y (++ L) *Columns) ) ) )

(de redraw ()
   (hideCsr)
   (drawin)
   (showCsr)
   (status) )

(de repaint ()
   (for (This *CmdWin This (: next))
      (redraw) ) )

(de scLeft ()
   (and
      (if (=1 (: winX))
         (> (: posX) 1)
         (>= (- (: posX) (dec (:: winX))) *Columns) )
      (dec (:: posX)) ) )

(de scRight ()
   (cond
      ((> (: posX) (: winX))
         (inc (:: winX)) )
      ((cdr (nth (: buffer text) (: posY) (: posX)))
         (inc (:: posX))
         (inc (:: winX)) )
      (T
         (for (Y . L) (cdr (nth (: buffer text) (: posY)))
            (T (cdr (nth L (: posX)))
               (inc (:: posY) Y) )
            (T (= Y (: lines))) ) ) ) )

(de goto (X Y F)
   (=: buffer posX (=: posX X))
   (setq X
      (cond
         ((and F
               (>= (inc (: posY)) Y (dec (: posY)))
               (>= (+ (: winX) *Columns -1) X (: winX)) )
            (: winX) )
         ((>= (*/ *Columns 3 4) X) 1)
         (T (- X (/ *Columns 2))) ) )
   (=: buffer posY (=: posY Y))
   (setq Y
      (min1
         (- Y (/ (: lines) 2))
         (- (length (: buffer text)) (: lines) -1) ) )
   (if (and F (= X (: winX)) (= Y (: winY)))
      (status)
      (=: winX X)
      (=: winY Y)
      (redraw) ) )

(de chgwin (Lines Top)
   (=: lines Lines)
   (and Top (=: top @))
   (=: winY
      (min1
         (- (: posY) (/ (: lines) 2))
         (- (length (: buffer text)) (: lines) -1) ) )
   (redraw) )

(de eqwin ()
   (let
      (H (dec *Lines)
         D (*/ H
            (let N 0
               (for (This *CmdWin (: next) @)
                  (inc 'N) ) ) ) )
      (with *CmdWin (chgwin 1 H))
      (when (>= D 3)
         (for (This *CmdWin (this (: next)))
            (if (: next)
               (chgwin (dec D) (dec 'H D))
               (chgwin (dec H) 0) ) ) )
      (cursor) ) )

(de getch ()
   (symbols *Ns
      (if (= "\e" (setq *Chr (or (++ *Keys) (key))))
         (when (or (++ *Keys) (key 120))
            (loop
               (setq *Chr (pack *Chr @))
               (T (member *Chr '("\e[A" "\e[B" "\e[C" "\e[D")) *Chr)
               (NIL (or (++ *Keys) (key 120)) *Chr) ) )
         *Chr ) ) )

(de getch2 (C)
   (if (= "^V" C)
      (or (++ *Keys) (symbols *Ns (key)))
      C ) )

(de reload (File Y X)
   (unless (== This *CmdWin)
      (when File
         (let B (fileBuffer File)
            (unless (== B (: buffer))
               (=: mark)
               (=: last (: buffer))
               (=: buffer B) ) ) )
      (load> (: buffer) This)
      (off *StatNm)
      (goto
         (or X (: buffer posX))
         (or Y (: buffer posY)) )
      (repaint) ) )

(de scratch (File Lst Y)
   (out (setq File (fName File))
      (mapc prinl Lst) )
   (prog1
      (if (find '((This) (= File (: file))) *Buffers)
         (with @
            (markup
               (=: text Lst)
               (=: undo (=: redo (=: dirt))) )
            This )
         (=: mark)
         (=: last (: buffer))
         (prog1
            (=: buffer (new '(+Buffer) File Y))
            (put @ 'text Lst)
            (markup (: buffer text))
            (goto 1 (: buffer posY)) ) )
      (repaint) ) )

(de pushTag (File)
   (push '*TagStack (: posX) (: posY) File (symbols)) )

(de tag (S C)
   (ifn
      (if C
         (or
            (get C '*Dbg -1 S)
            (meta C '*Dbg -1 S) )
         (get S '*Dbg 1) )
      (beep)
      (pushTag (: buffer file))
      (symbols (cddr @))
      (reload (cadr @) (car @) 1) ) )

(de done (Flg)
   (and Flg
      (dirty> (: buffer) This)
      (save> (: buffer) This) )
   (=: mark)
   (nond
      ((; *CmdWin next next)
         (throw 'done Flg) )
      ((n== This *CmdWin))
      ((== This (; *CmdWin next))
         (delwin)
         (let (N (: lines)  Top (: top))
            (with (setq *Window (: prev))
               (chgwin (+ 1 N (: lines)) Top) ) ) )
      (NIL
         (delwin)
         (let N (: lines)
            (with (setq *Window (: next))
               (chgwin (+ 1 N (: lines))) ) ) ) ) )

(de change Prg
   (let
      (Pos (nth (: buffer text) (: posY))
         Env
         (env
            'PosX1 (: posX)  'PosY1 (: posY)
            'OldA (car Pos)  'OldD (cdr Pos)
            'NewD (: buffer text)
            '(Pos PosX2 PosY2 NewA) ) )
      (let? Res
         (job Env
            (prog1
               (run Prg)
               (setq
                  PosX2 (: posX)  PosY2 (: posY)
                  NewA (if Pos (car @) (: buffer text)) )
               (and Pos (setq NewD (cdr @))) ) )
         (=: buffer redo NIL)
         (push (:: buffer undo)
            (cons Env
               '(ifn Pos
                  (=: buffer text NewD)
                  (set Pos OldA)
                  (con Pos OldD) )
               '(ifn Pos
                  (=: buffer text NewA)
                  (set Pos NewA)
                  (con Pos NewD) ) ) )
         (markup (: buffer text))
         (goto (: posX) (: posY))
         (repaint)
         Res ) ) )

(de undo ()
   (ifn (pop (:: buffer undo))
      (beep)
      (let U @
         (push (:: buffer redo) U)
         (bind (car U)
            (eval (cadr U))
            (markup (: buffer text))
            (goto PosX1 PosY1)
            (repaint) ) ) ) )

(de redo ()
   (ifn (pop (:: buffer redo))
      (beep)
      (let R @
         (push (:: buffer undo) R)
         (bind (car R)
            (eval (cddr R))
            (markup (: buffer text))
            (goto PosX2 PosY2)
            (repaint) ) ) ) )

(de jmp@@ (Y)
   (=: buffer lastX (: posX))
   (=: buffer lastY (: posY))
   (setq *@@ Y) )

(de cnt@@ ()
   (- *@@ (: posY) -1) )

(de goCol (N)
   (setq *@@ (: posY))
   N )

(de goLeft (N)
   (goCol (max 1 (- (: posX) N))) )

(de goRight (N I)
   (goCol
      (min1
         (or (=T N) (+ (: posX) N))
         (+
            (or I 0)
            (length (get (: buffer text) (: posY))) ) ) ) )

(de goUp (N)
   (setq *@@ (max 1 (- (: posY) N)))
   (min1 (: posX) (length (get (: buffer text) *@@))) )

(de goDown (N I)
   (setq *@@
      (min1
         (or (=T N) (+ (: posY) N))
         (+ (or I 0) (length (: buffer text))) ) )
   (min1 (: posX) (length (get (: buffer text) *@@))) )

(de goAbs (X Y I)
   (jmp@@
      (min1 Y
         (+ (or I 0) (length (: buffer text))) ) )
   (min1 X (length (get (: buffer text) *@@))) )

(de goFind (C D N I)
   (setq *@@ (: posY))
   (let (Lst (get (: buffer text) (: posY))  L (nth Lst (: posX)))
      (do N (setq L (member C (cdr L))))
      (if L
         (+ D (or I 0) (offset L Lst))
         (beep) ) ) )

(de word (L C)
   (and
      (delim C)
      (or
         (sub? (car L) "\"()[]")
         (not (delim (car L))) ) ) )

(de lword (L C)
   (and (sp? C) (not (sp? (car L))) ) )

(de tword (L)
   (and
      (sp? (car L))
      (not (sp? (cadr L))) ) )

(de end (L)
   (and (not (delim (car L))) (delim (cadr L))) )

(de lend (L)
   (and (not (sp? (car L))) (sp? (cadr L))) )

(de getWord (Flg)
   (make
      (let Lst (get (: buffer text) (: posY))
         (unless Flg
            (for C (nth Lst (: posX))
               (T (delim C))
               (link C) ) )
         (for
            (L (nth Lst (dec (: posX)))
               (not (delim (car L)))
               (prior L Lst) )
            (yoke (car L)) ) ) ) )

(de _forward (Lst C)
   (for ((X . L) Lst  L  (cdr L))
      (T (and (Fun L C) (=0 (dec 'N)))
         (jmp@@ Y)
         (+ (or I 0) X) )
      (setq C (car L))
      NIL ) )

(de goForward (Fun N I)
   (let (Y (: posY)  Pos (nth (: buffer text) Y)  L (nth (++ Pos) (: posX)))
      (if (_forward (cdr L) (car L))
         (+ (: posX) @)
         (loop
            (NIL Pos (beep))
            (inc 'Y)
            (T (_forward (++ Pos)) @) ) ) ) )

(de _backward (Lst L)
   (use P
      (loop
         (NIL L)
         (setq P (prior L Lst))
         (T (and (Fun L (car P)) (=0 (dec 'N)))
            (jmp@@ Y)
            (offset L Lst) )
         (setq L P)
         NIL ) ) )

(de goBackward (Fun N)
   (let (Y (: posY)  Pos (nth (: buffer text) Y))
      (or
         (_backward
            (car Pos)
            (nth (car Pos) (dec (: posX))) )
         (loop
            (NIL (setq Pos (prior Pos (: buffer text)))
               (beep) )
            (dec 'Y)
            (T (_backward (car Pos) (tail 1 (car Pos))) @ ) ) ) ) )

(de goPFore (Cnt D I)
   (let (Y (: posY)  Pos (nth (: buffer text) Y))
      (loop
         (NIL (cdr Pos)
            (jmp@@ Y)
            (max 1 (+ (or I 0) (length (car Pos)))) )
         (inc 'Y)
         (T
            (and
               (car Pos)
               (not (cadr Pos))
               (=0 (dec 'Cnt)) )
            (jmp@@ (+ Y D))
            1 )
         (++ Pos) ) ) )

(de goPBack (Cnt)
   (let (Y (: posY)  Pos (nth (: buffer text) Y))
      (loop
         (NIL (setq Pos (prior Pos (: buffer text))))
         (dec 'Y)
         (T
            (and
               (not (car Pos))
               (cadr Pos)
               (=0 (dec 'Cnt)) ) ) )
      (jmp@@ Y)
      1 ) )

(de shiftN (Cnt Flg)
   (change
      (let? P Pos
         (do Cnt
            (when (car P)
               (if Flg
                  (do 3 (push P (name " ")))
                  (do 3
                     (NIL (sp? (caar P)))
                     (pop P) ) ) )
            (NIL (cdr P))
            (setq P (con P (cons (car @) (cdr @)))) )
         (=: posX 1) ) ) )

(de shiftY (X Flg)
   (shiftN (cnt@@) Flg) )

(de indent ()
   (change
      (let? P Pos
         (when (clip (car P))
            (let (N (*/ (offset @ (trim (car P))) 3)  Sup N)
               (set P @)
               (loop
                  (do (* N 3) (push P (name " ")))
                  (for C (car P)
                     (unless (val C)
                        (case C
                           ("(" (inc 'N))
                           (")" (dec 'N))
                           ("[" (push 'Sup N) (inc 'N))
                           ("]" (setq N (++ Sup))) ) ) )
                  (while (val (caadr P))
                     (++ P) )
                  (NIL (clip (cadr P)) T)
                  (setq P (con P (cons @ (cddr P)))) ) ) ) ) ) )

(de cutX (X Flg)
   (when X
      (let Y *@@
         (unless (> (list Y X) (list (: posY) (: posX)))
            (xchg 'X (:: posX)  'Y (:: posY)) )
         (change
            (when Pos
               (let (L (car Pos)  DX (: posX))
                  (and
                     (set *Clip
                        (make
                           (if Flg
                              (set Pos (cut (dec DX) 'L))
                              (setq L (nth L DX)) )
                           (while (>= (dec 'Y) (: posY))
                              (link L)
                              (setq L (cadr Pos))
                              (if Flg
                                 (con Pos (cddr Pos))
                                 (++ Pos) )
                              (one DX) )
                           (link (cut (- X DX) 'L))
                           (when Flg
                              (set Pos (conc (car Pos) L))
                              (=: posX (min1 (: posX) (length (car Pos)))) )
                           (setq *@@ (unless L 1)) ) )
                     Flg ) ) ) ) ) ) )

(de cutN (N)
   (change
      (when Pos
         (off *@@)
         (set *Clip
            (cons T
               (if (setq Pos (prior Pos (: buffer text)))
                  (make
                     (setq OldA (car @)  OldD (cdr @))
                     (do N
                        (link (cadr Pos))
                        (NIL (con Pos (cddr Pos))
                           (one *@@)
                           (dec (:: posY)) ) )
                     (=: posX 1) )
                  (cut N (:: buffer text)) ) ) ) ) ) )

(de paste (Lst Flg)
   (change
      (let P (or Pos (=: buffer text (cons)))
         (ifn (=T (car Lst))
            (let L (car P)
               (cond
                  ((=0 Flg) (setq PosX1 (=: posX 1)))
                  ((=1 Flg)
                     (and
                        (get (: buffer text) (: posY) 1)
                        (get (: buffer text) (: posY) (inc (:: posX)))
                        (inc 'PosX1) ) )
                  (Flg
                     (=: posX
                        (max 1
                           (inc (length (get (: buffer text) (: posY)))) ) ) ) )
               (set P
                  (conc (cut (dec (: posX)) 'L) (mapcar name (++ Lst))) )
               (for S Lst
                  (setq P (con P (cons (mapcar name S) (cdr P))))
                  (inc (:: posY)) )
               (=: posX (max 1 (length (car P))))
               (set P (append (car P) L)) )
            (=: posX 1)
            (ifn Flg
               (for L (cdr Lst)
                  (con P (cons (car P) (cdr P)))
                  (set P (mapcar name L))
                  (setq P (cdr P)) )
               (inc (:: posY))
               (for L (cdr Lst)
                  (setq P (con P (cons (mapcar name L) (cdr P)))) ) ) )
         T ) ) )

(de join (Cnt)
   (change
      (do Cnt
         (NIL (cdr Pos))
         (set Pos
            (append
               (car Pos)
               (cons (name " ") (clip (cadr Pos))) ) )
         (con Pos (cddr Pos)) )
      T ) )

(de tglCase (Cnt)
   (change
      (let? C (get Pos 1 (: posX))
         (do Cnt
            (set Pos
               (place (: posX) (car Pos)
                  ((if (upp? C) lowc uppc) C) ) )
            (NIL (setq C (get Pos 1 (inc (: posX)))))
            (inc (:: posX)) )
         T ) ) )

(de insChar (C Cnt)
   (change
      (when (car Pos)
         (do Cnt
            (set Pos (place (: posX) (car Pos) (name C)))
            (NIL (get Pos 1 (inc (:: posX)))) )
         (dec (:: posX)) ) ) )

(de incNum (Cnt)
   (change
      (let (I (: posX)  L (car Pos)  S (get L I))
         (ifn (format S)
            (set Pos
               (place (: posX) L (char (+ Cnt (char S)))) )
            (while
               (and
                  (gt0 (dec 'I))
                  (format (get L @)) )
               (setq S (pack @ S)) )
            (inc (:: posX)
               (-
                  (length
                     (set Pos
                        (conc
                           (head I L)
                           (need
                              (if (= `(char "0") (char S)) (length S) 1)
                              (chop (max 0 (+ Cnt (format S))))
                              (name "0") )
                           (tail (- (: posX)) L) ) ) )
                  (length L) ) ) ) ) ) )

(de overwrite (Lst)
   (change
      (let
         (P (or Pos (=: buffer text (cons)))
            L (conc (cut (dec (: posX)) P) (car Lst)) )
         (set P
            (append L
               (cdr (nth (car P) (length (++ Lst)))) ) )
         (=: posX (max 1 (length L))) ) ) )

(de _bs ()
   (++ Chg)
   (dec (:: posX))
   (unless Rpl
      (set P (remove (: posX) (car P))) ) )

(de insMode (Flg Win Rpl . @)
   (change
      (let (P (or Pos (=: buffer text (cons)))  Chg)
         (cond
            ((=0 Flg)
               (con P (cons (car P) (cdr P)))
               (set P)
               (goto 1 (: posY)) )
            ((=1 Flg))
            (Flg
               (setq P (con P (cons NIL (cdr P))))
               (goto 1 (inc (: posY)))
               (setq Chg (0)) ) )
         (cursor)
         (off *Complete)
         (while
            (case (or (next) (getch))
               (NIL)
               (("\n" "\r")
                  (cond
                     (Rpl (beep) T)
                     ((== This *CmdWin)
                        (nil (command (or Win This) (car P))) )
                     (T
                        (push 'Chg 0)
                        (con P
                           (cons (nth (car P) (: posX)) (cdr P)) )
                        (set P (head (dec (: posX)) (car P)))
                        (setq P (cdr P))
                        (goto 1 (inc (: posY)))
                        (cursor)
                        T ) ) )
               (("\b" "^?")  # [BACKSPACE]
                  (when (and Chg (n0 (car Chg)))
                     (_bs)
                     (chgLine (car P))
                     (off *Complete) )
                  T )
               (T
                  (let (S (list @)  L (get (: buffer text) (: posY)))
                     (cond
                        ((<> @ "\t") (off *Complete))
                        ((and
                              (== This *CmdWin)
                              (member L '(("/") ("?") ("&") (":") (":" " "))) )
                           (setq S
                              (chop
                                 (car
                                    (rot
                                       (setq *Complete
                                          (conc
                                             (and (cdr L) (history))
                                             (extract
                                                '((B)
                                                   (and
                                                      (head L B)
                                                      (cddddr B)
                                                      (pack ((if (cdr L) cddr cdr) B)) ) )
                                                (: buffer text) ) ) ) ) ) ) ) )
                        ((or Rpl (nor *Complete (setq S (pack (getWord T)))))
                           (setq S
                              (make
                                 (do (- 3 (% (dec (: posX)) 3))
                                    (link (name " ")) ) ) ) )
                        (T
                           (default *Complete
                              (cons S
                                 (if
                                    (or
                                       (n== This *CmdWin)
                                       (<> ":" (car L))
                                       (find sp? L) )
                                    (flip
                                       (all* S
                                          (when (== This *CmdWin)
                                             (pick
                                                '((P F) (and (head P L) F))
                                                '`(mapcar chop '(":tag " ":v " ":e " ":E " ":r " ":w "))
                                                '(T T 0 0 0 0) ) ) ) )
                                    (extract
                                       '((Cmd)
                                          (when (head (cdr L) (setq Cmd (chop Cmd)))
                                             (if (pre? ":" S)
                                                (cons (name ":") Cmd)
                                                Cmd ) ) )
                                       (conc
                                          (mapcar car *CmdMap)
                                          '("cp" "bak" "kab" "ls" "key" "tag" "bx" "bd" "map") ) ) ) ) )
                           (do (length (car *Complete)) (_bs))
                           (setq S (chop (car (rot *Complete)))) ) )
                     (when (= "^V" (car S))
                        (set S (or (next) (getch2 "^V"))) )
                     (for C S
                        (push 'Chg C)
                        (set P
                           ((if (and Rpl (car P)) place insert)
                              (: posX)
                              (car P)
                              C ) )
                        (inc (:: posX)) )
                     (goto (: posX) (: posY) T) )
                  (chgLine (car P))
                  T ) ) )
         (=: posX (max 1 (dec (: posX))))
         (cond
            ((=0 Flg) (push 'Chg 0))
            ((=1 Flg) (and (> PosX1 1) (dec 'PosX1))) )
         (split (reverse Chg) 0) ) ) )

(de cmdMode @
   (let Win (if (== This *CmdWin) (: next) This)
      (with *CmdWin
         (pass insMode (: buffer text) Win NIL) ) ) )

(de cmdPipe (N)
   (apply cmdMode (chop (pack ":" N "!"))) )

(de evRpt (Exe)
   (eval (setq *Repeat Exe) 1) )

(de move @
   (let M (conc (rest) (1))
      (case *Change
         (NIL
            (when (eval (rest))
               (goto @ *@@ T)
               (when (: mark)
                  (out @ (println (: posX) (: posY))) ) ) )
         ("!" (eval (rest)) (cmdPipe (cnt@@)))  # External filter
         (">" (evRpt (list 'shiftY M T)))  # Shift right
         ("<" (evRpt (list 'shiftY M)))  # Shift left
         ("c"  # Change
            (when (cutX (eval M) T)
               (and *@@
                  (get (: buffer text) (: posY) 1)
                  (inc (:: posX)) )
               (let L (insMode *@@)
                  (setq *Repeat
                     (list 'prog
                        (list 'cutX M T)
                        (list 'paste (lit L) '*@@)) ) ) ) )
         ("d" (evRpt (list 'cutX M T)))  # Delete
         ("y" (cutX (eval M)))  # Yank
         (T (beep)) ) ) )

(de chgRight (X)
   (setq *Change "c")
   (move 'goRight X) )

(de jmpMark (C D X)
   (cond
      ((= C D)
         (move 'goAbs
            (or X (: buffer lastX))
            (: buffer lastY) ) )
      ((get (: buffer) (intern C 'vip))
         (move 'goAbs (default X (car @)) (cdr @)) ) ) )

(de wordFun (@W)
   (setq *Search
      (let @N (inc (length @W))
         (curry (@W @N) (L C)
            (and
               (delimNs C)
               (head '@W L)
               (delimNs (get L @N)) ) ) ) ) )

(de moveSearch (Fun1 Fun2)
   (move Fun1 (lit Fun2) *Cnt) )

(de patMatch (Fun Pat)
   (moveSearch Fun (setq *Search (search> (: buffer) This Pat))) )

(de parMatch (Fun1 @Par1 @Sup1 @ParO @ParC @SupO @SupC)
   (moveSearch Fun1
      (let (Par @Par1  Sup @Sup1)
         (curry (Par Sup @Par1 @Sup1 @ParO @ParC @SupO @SupC) (L C)
            (unless (caar L)
               (and
                  (case (car L)
                     (@ParO (nil (inc 'Par)))
                     (@ParC (or (not C) (= (dec 'Par) 0 Sup)))
                     (@SupO (nil (push 'Sup Par) (zero Par)))
                     (@SupC
                        (or
                           (not C)
                           (= (setq Par (++ Sup)) 0 Sup) ) ) )
                  (setq Par @Par1  Sup @Sup1) ) ) ) ) ) )

(de braces (Fun1 @ParO @ParC)
   (moveSearch Fun1
      (let Par 1
         (curry (Par @ParO @ParC) (L C)
            (case (car L)
               (@ParO (nil (inc 'Par)))
               (@ParC (or (not C) (=0 (dec 'Par)))) ) ) ) ) )

(de *Spell
   "hunspell" "-l" "-d" "en_US,de_DE" )

(de spell ()
   (let? @W
      (pipe
         (out *Spell
            (let Pos (nth (: buffer text) (: posY))
               (prinl
                  (seek
                     '((L) (not (fold (car L))))
                     (nth (++ Pos) (: posX)) ) )
               (mapc prinl Pos) ) )
         (line) )
      (let @N (inc (length @W))
         (moveSearch 'goForward
            (setq *Search
               (curry (@W @N) (L C)
                  (and
                     (not (fold C))
                     (head '@W L)
                     (not (fold (get L @N))) ) ) ) ) ) ) )

(de pipeN (Cnt Line)
   (evRpt
      (fill
         '(when (cdr (cutN Cnt))
            (pipe (out (list *Shell "-c" Line) (mapc prinl @))
               (paste (cons T (rdLines)) *@@) ) )
         '(Line Cnt) ) ) )

(de nextBuf (B)
   (let? M (member (: buffer) *Buffers)
      (when (flg? B)
         (setq B
            (car
               (if B
                  (or (prior M *Buffers) (tail 1 *Buffers))
                  (or (cdr M) *Buffers) ) ) ) )
      (=: mark)
      (unless (== B (: buffer))
         (=: last (: buffer))
         (=: buffer B)
         (unless (: buffer text)
            (load> (: buffer) This) ) )
      (off *StatNm)
      (goto (: buffer posX) (: buffer posY)) ) )

(de delBuf (Buf)
   (for (This *CmdWin (this (: next)))
      (cond
         ((== Buf (: last))
            (=: last) )
         ((== Buf (: buffer))
            (nextBuf (: last))
            (=: last) ) ) )
   (del Buf '*Buffers)
   (=: last) )

(de shell (S)
   (vipZ)
   (do *Columns (prin "#"))
   (call *Shell "-c" S)
   (prin "[====] ")
   (flush)
   (getch)
   (prinl)
   (vipA)
   (repaint) )

(de shFile (S)
   (when (: buffer file)
      (shell (text S @ *Cnt)) ) )

(de prCmd (L)
   (with *CmdWin
      (paste (cons T L) (: buffer text))
      (inc (:: posY) (dec (length L))) ) )

(de evCmd Prg
   (out (tmp "repl")
      (err NIL
         (catch '(NIL)
            (setq *@ (run Prg 1)  *Msg)
            (print '-> *@)
            (remark *@)
            (prinl) ) )
      (when @@
         (prin "!? ")
         (println ^)
         (prinl *Msg) ) )
   (in (tmp "repl")
      (prCmd (rdLines)) ) )

(de cmd (Cmd . Fun)
   (if (assoc Cmd *CmdMap)
      (con @ Fun)
      (push '*CmdMap (cons Cmd Fun)) ) )

(de keys (Lst)
   (setq *Keys Lst) )

(de _map (@Map @C @S)
   (macro
      (push1 '@Map '(@C (keys (chop @S)))) ) )

(de map+ (C . X)
   (if (str? (car X))
      (_map '*KeyMap C @)
      (push1 '*KeyMap (cons C X)) ) )

(de map+g (C . X)
   (if (str? (car X))
      (_map '*KeyMap-g C @)
      (push1 '*KeyMap-g (cons C X)) ) )

(de map+q (C . X)
   (if (str? (car X))
      (_map '*KeyMap-q C @)
      (push1 '*KeyMap-q (cons C X)) ) )

(de posChar ()
   (get (: buffer text) (: posY) (: posX)) )

(de getText Prg
   (let (*Change "y"  *Clip (box))
      (run Prg 1)
      (glue "\n" (val *Clip)) ) )

(de s-expr ()
   (any
      (getText
         (case (posChar)
            ("\"" (move 'goFind "\"" 0 1))
            ("(" (parMatch 'goForward 1 0 "(" ")" "[" "]"))
            ("[" (parMatch 'goForward 0 (0 . 0) "(" ")" "[" "]"))
            (T (move 'goForward 'end 1)) ) ) ) )

(de reset ()
   (off *Count *Change)
   (setq *Clip '\"\") )

(private) (Lst Ns L C S X)

### Commands ###
(de command (This Line)
   (case (++ Line)
      ("/" (patMatch 'goForward Line))  # Search forward
      ("?" (patMatch 'goBackward Line))  # Search backward
      ("&" (moveSearch 'goForward (wordFun Line)))  # Search word
      (":"
         (let Cnt 0
            (while (format (car Line))
               (setq Cnt (+ @ (* 10 Cnt)))
               (++ Line) )
            (let C (++ Line)
               (when (>= "z" C "a")
                  (until (sp? (car Line))
                     (setq C (pack C (++ Line))) ) )
               (let L (pack (clip Line))
                  (if (or (assoc C (: buffer cmds)) (assoc C *CmdMap))
                     ((cdr @) L Line Cnt)
                     (case C
                        (" "  # Eval
                           (setq @ *@)
                           (evCmd (run (str L))) )
                        ("$"  # Shell command
                           (cond
                              (L
                                 (scratch (tmp "cmd" (inc (0)))
                                    (in (list *Shell "-c" (setq L (rplFile L)))
                                       (rdLines) ) )
                                 (=: buffer cmd L) )
                              ((: buffer cmd)
                                 (scratch (: buffer file)
                                    (in (list *Shell "-c" @)
                                       (rdLines) ) ) ) ) )
                        ("!"  # External filter
                           (when L
                              (if (=0 Cnt)
                                 (shell (rplFile L))
                                 (pipeN Cnt L) ) ) )
                        ("cp"  # Copy to system clipboard
                           (out '("copy")  # System dependent script
                              (let V (val *Clip)
                                 (if (=T (car V))
                                    (mapc prinl (cdr V))
                                    (map
                                       '(((S . L)) (prin S (and L "\n")))
                                       V ) ) ) ) )
                        ("bak" (shFile "mv @1 @1- && cp -p @1- @1"))  # Backup to -
                        ("kab"  # Restore from -
                           (shFile "mv @1- @1 && cp -p @1 @1-")
                           (reload) )
                        ("ls"  # List buffers
                           (prCmd
                              (make
                                 (for (I . This) *Buffers
                                    (link
                                       (chop (pack ":" I " " (prName (: file)))) ) ) ) ) )
                        ("key" (=: buffer key L) (reload))
                        ("m"
                           (if L
                              (when (info (=: mark (path (rplFile L))))
                                 (in (: mark) (move 'goAbs (read) (read))) )
                              (=: mark) ) )
                        ("n" (nextBuf))  # Next buffer
                        ("N" (nextBuf T))  # Previous buffer
                        ("tag" (apply tag (str L)))
                        ("v" (reload (syms (str L)) 1 1))
                        ("e" (reload (rplFile L)))  # (Edit) Reload buffer
                        ("E"  # (Edit) Toggle subdir recursion and reload buffer
                           (=: buffer subd (not (: buffer subd)))
                           (reload (rplFile L)) )
                        ("r"  # Read file contents
                           (let F (path (rplFile L))
                              (when (info F)
                                 (in F (paste (cons T (rdLines)) 1)) ) ) )
                        ("w"  # (Write) Save buffer
                           (if L
                              (out (path (rplFile @))
                                 (mapc prinl (: buffer text)) )
                              (save> (: buffer) This) ) )
                        ("l"  # (load) Save and load
                           (when (: buffer file)
                              (when (dirty> (: buffer) This)
                                 (save> (: buffer) This) )
                              (evCmd (load (: buffer file))) ) )
                        (("x" "wq") (done T))  # (Exit) Save buffer and close window
                        ("q" (done))  # (Quit) Close window
                        ("bx"  # Buffer exchange
                           (let X (memq (: buffer) *Buffers)
                              (if (cdr X)
                                 (xchg X @)
                                 (beep) ) ) )
                        ("bd"  # Buffer delete
                           (and
                              (cdr *Buffers)
                              (if (=0 Cnt) (: buffer) (get *Buffers Cnt))
                              (delBuf @) ) )
                        ("map"  # Add/remove key mappings
                           (++ Line)
                           (let C (++ Line)
                              (until (sp? (car Line))
                                 (setq C (pack C (++ Line))) )
                              (if Line
                                 (push '*KeyMap
                                    (list C
                                       (list 'keys
                                          (lit (mapcar name (cdr Line))) ) ) )
                                 (del (assoc C *KeyMap) '*KeyMap) ) ) )
                        (T
                           (if (get *Buffers Cnt)
                              (nextBuf @)
                              (beep) ) ) ) ) ) ) )
         (with *CmdWin
            (redraw) ) )
      (T (beep)) ) )

(de syms (Lst)
   (prog1
      (tmp "syms")
      (syms> (fileBuffer @) Lst) ) )

(de vipA ()
   (screen2)
   (raw T) )

(de vipZ ()
   (raw NIL)
   (screen1) )

### VIP Entry Point ###
(de vi (Lst Ns)  # (file (pat . file) (99 . file) (T . file) (sym [sym ..])
   (getSize)
   (and Lst (co 'vip))
   (co 'vip
      (setq *Ns (symbols))
      (and Ns (symbols @))
      (off *Buffers)
      (when (=0 (%@ "isatty" 'I 0))
         (with (fileBuffer (tmp "stdin"))
            (out (: file) (in 0 (echo))) )
         (ctty "/dev/tty") )
      (for X Lst
         (cond
            ((not X))
            ((atom X) (fileBuffer X))  # Path name
            ((pair (car X))  # Pattern
               (wordFun @)
               (fileBuffer (cdr X)) )
            ((or (num? (car X)) (=T (car X)))  # Line number
               (fileBuffer (cdr X) @) )
            (T (syms X)) ) )  # List of symbols
      (unless *Buffers
         (fileBuffer (tmp "empty")) )
      (vipA)
      (let
         (*Winch '((getSize) (eqwin) (flush))
            *TStp1 '((vipZ))
            *TStp2 '((vipA) (repaint) (cursor) (flush)) )
         (reset)
         (setq *CmdWin
            (new '(+Window) (new '(+Buffer)) (dec *Lines) 1 1 1 1 1) )
         (with (car *Buffers)
            (load> This)
            (setq *Window
               (new '(+Window) This
                  0 (- *Lines 2)
                  1
                  (min1
                     (- (: posY) (/ (- *Lines 2) 2))
                     (- (length (: text)) *Lines -3) )
                  1 (: posY)
                  *CmdWin ) ) )
         (with *Window (redraw))
         (finally (prog (rollback) (vipZ))
            (catch 'done
               (loop
                  (setq *Cnt (max 1 (format *Count)))
                  (with *Window
                     (=: posX
                        (min1 (: posX)
                           (length
                              (get (: buffer text)
                                 (=: posY
                                    (min1 (: posY) (length (: buffer text))) ) ) ) ) )
                     (symbols (: buffer symbols))
                     (when
                        (or
                           (> (: winX) (: posX))
                           (> (: winY) (: posY)) )
                        (=: winX (min1 (: posX) (: winX)))
                        (=: winY (min1 (: posY) (: winY)))
                        (redraw) )
                     (cursor)
                     (case (getch)
                        ("0"
                           (if *Count
                              (queue '*Count "0")
                              (move 'goAbs 1 (: posY))  # Go to beginning of line
                              (off *Change) ) )
                        (("1" "2" "3" "4" "5" "6" "7" "8" "9")  # ["Count" prefix]
                           (queue '*Count *Chr) )
                        ("\"" (setq *Clip (intern (pack '"\"" (getch)) 'vip)))  # "Register" prefix
                        (("!" "<" ">" "c" "d" "y")  # ["Change" prefix]
                           (cond
                              ((= *Chr *Change)
                                 (case *Chr
                                    ("!" (cmdPipe *Cnt))  # [!!] External filter
                                    (">" (evRpt (list 'shiftN *Cnt T)))  # [>>] Shift line(s) right
                                    ("<" (evRpt (list 'shiftN *Cnt)))  # [<<] Shift line(s) left
                                    ("c" (=: posX 1) (chgRight T))  # [cc] Change whole line
                                    ("d" (evRpt (list 'cutN *Cnt)))  # [dd] Delete line(s)
                                    ("y"  # [yy] Yank line(s)
                                       (set *Clip
                                          (cons T
                                             (head *Cnt (nth (: buffer text) (: posY))) ) ) ) )
                                 (reset) )
                              (*Change (off *Change))
                              (T (setq *Change *Chr)) ) )
                        (T
                           (if (or (assoc *Chr (: buffer keys)) (assoc *Chr *KeyMap))
                              (run (cdr @))
                              (case *Chr
                                 ("\e")
                                 (("\n" "\r")
                                    (if (== This *CmdWin)
                                       (command (: next) (get (: buffer text) (: posY)))
                                       (goto 1 (inc (: posY)) T)  # Go to next line
                                       (do (: sc) (scRight))
                                       (redraw) ) )
                                 ("." (if *Repeat (eval @) (beep)))  # Repeat last change
                                 (("j" "\e[B") (move 'goDown *Cnt))  # [DOWN] Move down
                                 (("^F" "\e[6~") (move 'goDown (: lines)))  # [PGDOWN] Page down
                                 (("k" "\e[A") (move 'goUp *Cnt))  # [UP] Move up
                                 (("^B" "\e[5~") (move 'goUp (: lines)))  # [PGUP] Page up
                                 ("h" (move 'goLeft *Cnt))  # Move left
                                 ("l" (move 'goRight *Cnt))  # Move right
                                 ("\e[D" (do 2 (scLeft)) (redraw))  # [LEFT] Scroll left
                                 ("\e[C" (do 2 (scRight)) (redraw))  # [RIGHT] Scroll right
                                 ("z" (do 3 (scRight)) (redraw))  # Scroll right 3 columns
                                 ("Z" (do 3 (scLeft)) (redraw))  # Scroll left 3 columns
                                 ("|" (move 'goCol *Cnt))  # Go to column
                                 ("$" (move 'goRight T))  # Go to end of line
                                 (("\e[1~" "\e[H") (move 'goAbs 1 1))  # [HOME] Go to beginning of text
                                 (("\e[4~" "\e[F") (move 'goAbs 1 T))  # [END] Go to end of text
                                 ("G" (move 'goAbs 1 (or (format *Count) T)))  # [G] Go to end of text or line number
                                 ("f" (and (getch2 (getch)) (move 'goFind @ 0 *Cnt)))  # Find character
                                 ("t" (and (getch2 (getch)) (move 'goFind @ -1 *Cnt)))  # Till character
                                 ("\t" (move 'goForward 'tword *Cnt))  # TAB word forward
                                 ("w" (move 'goForward 'word *Cnt))  # Word forward
                                 ("W" (move 'goForward 'lword *Cnt))  # Long word forward
                                 ("b" (move 'goBackward 'word *Cnt))  # Word backward
                                 ("B" (move 'goBackward 'lword *Cnt))  # Long word backward
                                 ("e" (move 'goForward 'end *Cnt))  # End of word
                                 ("E" (move 'goForward 'lend *Cnt))  # End of long word
                                 ("{" (move 'goPBack *Cnt))  # Paragraph(s) backward
                                 ("}" (move 'goPFore *Cnt 0))  # Paragraph(s) forward
                                 ("'" (jmpMark (getch) "'" 1))  # Jump to mark line
                                 ("`" (jmpMark (getch) "`")) # Jump to mark position
                                 ("~" (evRpt (list 'tglCase *Cnt)))  # Toggle case
                                 ((":" " ") (cmdMode (name ":")))  # Command
                                 ("/" (cmdMode (name "/")))  # Search forward
                                 ("?" (cmdMode (name "?")))  # Search backward
                                 ("&" (cmdMode (name "&")))  # Search word
                                 ("n"  # Search next
                                    (if *Search
                                       (move 'goForward (lit @) *Cnt)
                                       (beep) ) )
                                 ("N"  # Search previous
                                    (if *Search
                                       (move 'goBackward (lit @) *Cnt)
                                       (beep) ) )
                                 ("*"  # Search word under cursor
                                    (and (getWord) (moveSearch 'goForward (wordFun @))) )
                                 ("#"  # Search word under cursor backward
                                    (and (getWord) (moveSearch 'goBackward (wordFun @))) )
                                 ("%"  # Matching parenthesis
                                    (case (posChar)
                                       ("(" (parMatch 'goForward 1 0 "(" ")" "[" "]"))
                                       ("[" (parMatch 'goForward 0 (0 . 0) "(" ")" "[" "]"))
                                       ("{" (braces 'goForward "{" "}"))
                                       (")" (parMatch 'goBackward 1 0 ")" "(" "]" "["))
                                       ("]" (parMatch 'goBackward 0 (0 . 0) ")" "(" "]" "["))
                                       ("}" (braces 'goBackward "}" "{"))
                                       (T (beep)) ) )
                                 ("i"  # Insert
                                    (when (insMode)
                                       (setq *Repeat (list 'paste (lit @))) ) )
                                 ("I"  # Insert at beginning of line
                                    (goto 1 (: posY))
                                    (when (insMode)
                                       (setq *Repeat (list 'paste (lit @) 0)) ) )
                                 ("a"  # Append
                                    (when (get (: buffer text) (: posY) 1)
                                       (inc (:: posX)) )
                                    (when (insMode 1)
                                       (setq *Repeat (list 'paste (lit @) 1)) ) )
                                 ("A"  # Append to end of line
                                    (goto
                                       (inc (length (get (: buffer text) (: posY))))
                                       (: posY)
                                       T )
                                    (when (insMode 1)
                                       (setq *Repeat (list 'paste (lit @) T)) ) )
                                 ("o"  # Open new line below current line
                                    (setq *Repeat (list 'paste (lit (insMode T)) T)) )
                                 ("O"  # Open new line above current line
                                    (setq *Repeat (list 'paste (lit (insMode 0)) 0)) )
                                 ("x" (setq *Change "d") (move 'goRight *Cnt))  # Delete characters
                                 ("X" (setq *Change "d") (move 'goLeft *Cnt))  # Delete characters left
                                 ("D" (setq *Change "d") (move 'goRight T))  # Delete rest of line
                                 ("p" (evRpt (list 'paste (lit (val *Clip)) 1)))  # Paste after current position
                                 ("P" (evRpt (list 'paste (lit (val *Clip)))))  # Paste before current position
                                 ("J" (evRpt (list 'join *Cnt)))  # Join lines
                                 ("m"  # Set mark
                                    (put (: buffer) (intern (getch) 'vip)
                                       (cons (: posX) (: posY)) ) )
                                 ("M" (=: sc (dec (: winX))))  # Mark horizontal scroll position
                                 ("r"  # Replace character(s)
                                    (and (getch2 (getch)) (evRpt (list 'insChar @ *Cnt))) )
                                 ("R"  # Replace
                                    (when (insMode NIL NIL T)
                                       (setq *Repeat (list 'overwrite (lit @))) ) )
                                 ("s" (chgRight 1))  # Substitute character
                                 ("C" (chgRight T))  # Change rest of line
                                 ("S" (=: posX 1) (chgRight T))  # Change whole line
                                 ("," (evRpt '(indent)))  # Fix indentation
                                 ("^A" (evRpt (list 'incNum *Cnt)))
                                 ("^X" (evRpt (list 'incNum (- *Cnt))))
                                 ("u" (undo))  # Undo
                                 ("^R" (redo))  # Redo
                                 ("^E" (evCmd (eval (s-expr))))  # Evaluate expression
                                 ("g"  # ["Go" prefix]
                                    (if (assoc (getch) *KeyMap-g)
                                       (run (cdr @))
                                       (case *Chr
                                          ("f"  # [gf] Edit file under cursor
                                             (pushTag (: buffer file))
                                             (reload (pack (getWord))) )
                                          ("w"  # [gw] Web page
                                             (scratch (tmp "web" (inc (0)))
                                                (in (list "w3m" "-cols" *Columns (getWord))
                                                   (rdLines) ) ) )
                                          ("h"  # [gh] HTTP code
                                             (scratch (tmp "http" (inc (0)))
                                                (in (list "w3m" "-dump_both" (getWord))
                                                   (rdLines) ) ) )
                                          ("b"  # [gb] Browser
                                             (vipZ)
                                             (call (or (sys "BROWSER") "w3m") (getWord))
                                             (vipA)
                                             (repaint) )
                                          ("g" (move 'goAbs 1 (or (format *Count) 1)))  # [gg] Go to beginning of text
                                          ("s" (spell))
                                          (T (beep)) ) ) )
                                 ("+"  # Increase window size
                                    (loop
                                       (NIL (this (: prev))
                                          (for (This (; *Window next) This (: next))
                                             (T (> (: lines) 1)
                                                (with *Window
                                                   (chgwin (inc (: lines)) (dec (: top)))
                                                   (for (This (: next) (=1 (: lines)) (: next))
                                                      (chgwin 1 (dec (: top))) ) )
                                                (chgwin (dec (: lines))) ) ) )
                                       (T (> (: lines) 1)
                                          (with *Window
                                             (chgwin (inc (: lines)))
                                             (for (This (: prev) (=1 (: lines)) (: prev))
                                                (chgwin 1 (inc (: top))) ) )
                                          (chgwin (dec (: lines)) (inc (: top))) ) ) )
                                 ("-"  # Decrease window size
                                    (cond
                                       ((=1 ( : lines)))
                                       ((: prev)
                                          (chgwin (dec (: lines)))
                                          (with (: prev)
                                             (chgwin (inc (: lines)) (dec (: top))) ) )
                                       (T
                                          (chgwin (dec (: lines)) (inc (: top)))
                                          (with (: next)
                                             (chgwin (inc (: lines))) ) ) ) )
                                 ("=" (eqwin))  # Set all windows to equal size
                                 ("K"  # Edit symbol
                                    (let S (any (getWord))
                                       (ifn (: buffer syms)
                                          (tag S)
                                          (pushTag @)
                                          (syms> (: buffer) (cons S @))
                                          (reload (: buffer file) 1 1) ) ) )
                                 ("^]"  # Edit symbol definition
                                    (tag (any (getWord))) )
                                 (("Q" "^T")  # Pop tag stack
                                    (ifn *TagStack
                                       (beep)
                                       (symbols (++ *TagStack))
                                       (if (atom (car *TagStack))
                                          (reload (++ *TagStack) (++ *TagStack) (++ *TagStack))
                                          (syms> (: buffer) (++ *TagStack))
                                          (reload (: buffer file) (++ *TagStack) (++ *TagStack)) ) ) )
                                 (("\eOP" "\e[[A")  # [F1] Highlight on/off
                                    (=: buffer flat (not (: buffer flat)))
                                    (repaint) )
                                 (("\eOQ" "\e[[B")  # [F2] Show chages to -
                                    (shFile
                                       (if (sys "CCRYPT" (: buffer key))
                                          "diff -Bb <(ccrypt -c -ECCRYPT @1-) <(ccrypt -c -ECCRYPT @1)"
                                          "diff -Bb @1- @1" ) ) )
                                 (("\eOR" "\e[[C")  # [F3] Custom dif
                                    (shFile "dif @1 @2") )
                                 (("\eOS" "\e[[D")  # [F4] Format paragraph
                                    (and *Count (=: buffer fmt @))
                                    (goPFore 1 -1)
                                    (pipeN (cnt@@) (pack "fmt -" (: buffer fmt))) )
                                 (("\e[15~" "\e[[E")  # [F5] Previous buffer
                                    (nextBuf T) )
                                 ("\e[17~"  # [F6] Next buffer
                                    (nextBuf) )
                                 ("\e[18~" (run *F7))  # [F7] Custom key
                                 ("\e[19~" (run *F8))  # [F8] Custom key
                                 ("\e[20~" (run *F9))  # [F9] Custom key
                                 ("\e[21~" (run *F10))  # [F10] Custom key
                                 ("\e[23~" (run *F11))  # [F11] Custom key
                                 ("\e[24~" (run *F12))  # [F12] Custom key
                                 ("\\"  # Select or toggle buffer
                                    (nextBuf
                                       (if *Count
                                          (get *Buffers (format @))
                                          (or (: last) (car *Buffers)) ) ) )
                                 (("q" "^W")  # ["Window" prefix]
                                    (if (assoc (getch) *KeyMap-q)
                                       (run (cdr @))
                                       (case *Chr
                                          ("s"  # [qs] Split window
                                             (unless (== This *CmdWin)
                                                (let (Old (inc (: lines))  New (/ Old 2))
                                                   (with
                                                      (new (val This) (: buffer)
                                                         (+ (: top) New) (- Old New 1)
                                                         (: winX) (: winY)
                                                         (: posX) (: posY)
                                                         (: prev)
                                                         (: mark) )
                                                      (goto (: posX) (: posY)) )
                                                   (=: mark)
                                                   (chgwin (dec New)) ) ) )
                                          ("x"  # [qx] Exchange windows
                                             (and
                                                (; *CmdWin next next)
                                                (n== This *CmdWin)
                                                (let W (if (== (: prev) *CmdWin) (: next) (: prev))
                                                   (for P '(buffer winX winY posX posY last mark sc)
                                                      (xchg (prop This P) (prop W P)) )
                                                   (goto (: posX) (: posY))
                                                   (with W
                                                      (goto (: posX) (: posY)) ) ) ) )
                                          ("k" (and (: next) (setq *Window @)))  # [qk] Above window
                                          ("j" (and (: prev) (setq *Window @)))  # [qj] Below window
                                          ("q" (done))  # [qq] (Quit) Close window
                                          ("z" (run *TStp1) (yield) (run *TStp2))  # [qz] Suspend
                                          (T (beep)) ) ) )
                                 ("v" (view> This))  # View hook
                                 (T (beep)) ) )
                           (reset) ) ) ) ) ) ) ) ) )

(and (info "~/.pil/viprc") (load @@))

### Debug ###
`*Dbg

(de pico~vi (X C)
   (setq C
      (if C
         (or
            (get C '*Dbg -1 X)
            (meta C '*Dbg -1 X) )
         (get X '*Dbg 1) ) )
   (and
      (vi
         (list
            (cond
               ((pair X) @)
               (C (cons (car @) (cadr @)))
               (T X) ) )
         (cddr C) )
      X ) )

(de pico~v Lst
   (cond
      (Lst (vi (list @)))
      ((asoq 'vip (stack)) (vi)) ) )


================================================
FILE: lib/xhtml/area
================================================



================================================
FILE: lib/xhtml/field
================================================



================================================
FILE: lib/xhtml/grid
================================================

¦(run PRG)¦










================================================
FILE: lib/xhtml/html
================================================



   
   ¦(run PRG)¦

   ¦(run PRG)¦



================================================
FILE: lib/xhtml/input
================================================



================================================
FILE: lib/xhtml/layout
================================================


================================================
FILE: lib/xhtml/menu
================================================
<>

<>


================================================
FILE: lib/xhtml/select
================================================

¦(run (cdr PRG))¦




================================================
FILE: lib/xhtml/submit
================================================



================================================
FILE: lib/xhtml/tab
================================================


¦(run PRG)¦
¦(run PRG)¦




================================================
FILE: lib/xhtml/table
================================================

¦(run PRG)¦

¦(run PRG)¦


¦(run PRG)¦




================================================
FILE: lib/xhtml.l
================================================
# 11mar25 Software Lab. Alexander Burger

(de xhtml (Path)
   (for X
      (quote
         ("html" . *XhtmlHtml)
         ("table" . *XhtmlTable)
         ("grid" . *XhtmlGrid)
         ("layout" . *XhtmlLayout)
         ("menu" . *XhtmlMenu)
         ("tab" . *XhtmlTab)
         ("input" . *XhtmlInput)
         ("field" . *XhtmlField)
         ("area" . *XhtmlArea)
         ("select" . *XhtmlSelect)
         ("submit" . *XhtmlSubmit) )
      (when (info (pack Path (++ X)))
         (set X
            (in @@
               (make
                  (until (eof)
                     (let? L (clip (line))
                        (while (= " " (peek))
                           (conc L (list "\n") (clip (line))) )
                        (setq L (split (replace L "~" *SesId) "¦"))
                        (link
                           (unless (= L '(("<" ">")))
                              (make
                                 (loop
                                    (link (pack (++ L)))
                                    (NIL L)
                                    (link (any (++ L)))
                                    (NIL L) ) ) ) ) ) ) ) ) ) ) ) )

(private) Lst

(de micro (Lst . PRG)
   (when Lst
      (loop
         (prin (++ Lst))
         (NIL Lst)
         (if (atom (car Lst))
            (ht:Prin (eval (++ Lst)))
            (eval (++ Lst)) )
         (NIL Lst) )
      (prinl) ) )

(xhtml "@lib/xhtml/")

(mapc allow '(*JS *Menu *Tab *ID "!ping"))
(setq *Menu 0  *Tab 1)
(off "*JS")

(private) (Prg Ofs X Attr Cls Var Val Nm JS)

(de htPrin (Prg Ofs)
   (default Ofs 1)
   (for X Prg
      (if (atom X)
         (ht:Prin (eval X Ofs))
         (eval X Ofs) ) ) )

(de htJs ()
   (for X "*JS"
      (prin " " (car X) "=\"")
      (ht:Prin (cdr X))
      (prin "\"") ) )

(de htStyle (Attr)
   (cond
      ((atom Attr)
         (prin " class=\"")
         (ht:Prin Attr)
         (prin "\"") )
      ((and (atom (car Attr)) (atom (cdr Attr)))
         (prin " " (car Attr) "=\"")
         (ht:Prin (cdr Attr))
         (prin "\"") )
      (T (mapc htStyle Attr)) ) )

(de dfltCss (Cls)
   (htStyle
      (cond
         ((not *Style) Cls)
         ((atom *Style) (pack *Style " " Cls))
         ((and (atom (car *Style)) (atom (cdr *Style)))
            (list Cls *Style) )
         ((find atom *Style)
            (replace *Style @ (pack @ " " Cls)) )
         (T (cons Cls *Style)) ) ) )

(de tag (Nm Attr Ofs Prg)
   (prin "<" Nm)
   (and Attr (htStyle @))
   (prin ">")
   (if (atom Prg)
      (ht:Prin (eval Prg Ofs))
      (for X Prg
         (if (atom X)
            (ht:Prin (eval X Ofs))
            (eval X Ofs) ) ) )
   (prin "") )

(de  (Nm Attr . Prg)
   (tag Nm Attr 2 Prg) )

(de  (JS . Prg)
   (let "*JS" (append "*JS" JS)
      (run Prg) ) )

(de style (X S)
   (nond
      (X S)
      (S X)
      ((pair X)
         (cond
            ((atom S) (pack S " " X))
            ((and (atom (car S)) (atom (cdr S)))
               (list X S) )
            ((find atom S)
               (replace S @ (pack @ " " X)) )
            (T (cons X S)) ) )
      ((or (pair (car X)) (pair (cdr X)))
         (cond
            ((atom S) (list S X))
            ((and (atom (car S)) (atom (cdr S)))
               (if (= (car X) (car S))
                  X
                  (list S X) ) )
            (T
               (cons X (delete (assoc (car X) S) S)) ) ) )
      (NIL
         (for Y X
            (setq S (style Y S)) ) ) ) )

(de ") ) ) )
            (and *SesId ( "SesId='" @ "'"))
            (mapc javascript *JS) )
         (micro Body
            (htPrin Prg 3) )
         (micro End) ) ) )

(de css (Css)
   (prinl "") )

(de javascript (JS . @)
   (when JS
      (prinl "") )
   (and (rest) ( @)) )

(de serverSentEvent (Id Var . Prg)
   (allow "!ssEvt")
   (
      "(new EventSource(SesId+'!ssEvt?'+'"
      Id
      "')).onmessage = function(ev) {if (ev.data.charAt(0) == '&') document.title = ev.data.substr(1); else document.getElementById('"
      Id
      "')."
      (if (lst? (car Prg)) "innerHTML" (++ Prg))
      " = ev.data;}" )
   (if (assoc Id *SsEvts)
      (con @ (cons Var (unless (val Var) Prg)))
      (push '*SsEvts (cons Id Var Prg)) ) )

(de ssEvt (Id)
   (when (assoc Id *SsEvts)
      (let ((@Var . Prg) (cdr @))
         (task *HtSock)
         (macro
            (and @Var (task (close @Var)))
            (task (setq @Var *HtSock)
               (in @
                  (unless (char)
                     (task (close @Var))
                     (off @Var) ) ) ) )
         (httpHead "text/event-stream" 0)
         (run Prg) ) ) )

(private) Sock

(de serverSend (Sock . Prg)
   (when Sock
      (out @
         (ht:Out T
            (prin "data: ")
            (output
               (cond
                  ((<> "\n" @@) (prin @@))
                  (@@@ (prin "\ndata: ")) )
               (htPrin Prg 2) )
            (prinl "\n") ) ) ) )

(de ping (Min)
   (timeout (setq *Timeout (* Min `(* 60 1000))))
   (respond) )

(de  (Min)
   ( "onload=ping(" Min ")") )

(de  (Val Max)
   (ifn Val
      (
 '(id . "progress")
         ( "progress" '((value . 0) (max . 99)))
         (serverSentEvent "progress" '*Progress) )
      (wait 1)
      (serverSend *Progress
         (unless (=T Val)
            ( "progress"
               (list
                  (cons 'value Val)
                  (cons 'max Max) ) )
            ( "center"
               (prin  "
" (*/ Val 100 Max) " %") ) ) ) ) ) 

(de 
 (Attr . Prg)
   (tag "div" Attr 2 Prg)
   (prinl) )

(de  (Attr . Prg)
   (tag "span" Attr 2 Prg) )

(de 
 Prg
   (htPrin Prg 2)
   (prinl "
") )

(de -- ()
   (prinl "
") )

(de ---- ()
   (prinl "

") )

(de 
 ()
   (prinl "
") )

(de  (N)
   (do (or N 1) (prin " ")) )

(de  Prg
   (tag "small" NIL 2 Prg) )

(de  Prg
   (tag "big" NIL 2 Prg) )

(de  Prg
   (tag "em" NIL 2 Prg) )

(de  Prg
   (tag "strong" NIL 2 Prg) )

(de 
 (Attr . Prg)
   (tag "h1" Attr 2 Prg)
   (prinl) )

(de 
 (Attr . Prg)
   (tag "h2" Attr 2 Prg)
   (prinl) )

(de 
 (Attr . Prg)
   (tag "h3" Attr 2 Prg)
   (prinl) )

(de 
 (Attr . Prg)
   (tag "h4" Attr 2 Prg)
   (prinl) )

(de 
 (Attr . Prg)
   (tag "h5" Attr 2 Prg)
   (prinl) )

(de 
 (Attr . Prg)
   (tag "h6" Attr 2 Prg)
   (prinl) )

(de 
 (Attr . Prg)
   (tag "p" Attr 2 Prg)
   (prinl) )

(de 
 (Attr . Prg)
   (tag "pre" Attr 2 Prg)
   (prinl) )

(de 
     (Attr . Prg)
   (tag "ol" Attr 2 Prg)
   (prinl) )

(de 
       (Attr . Prg)
   (tag "ul" Attr 2 Prg)
   (prinl) )

(de 
    •  (Attr . Prg)
   (tag "li" Attr 2 Prg)
   (prinl) )

(de 
       (Attr . Prg)
   (tag "dl" Attr 2 Prg)
   (prinl) )

(de 
       (Attr . Prg)
   (tag "dt" Attr 2 Prg)
   (prinl) )

(de 
       (Attr . Prg)
   (tag "dd" Attr 2 Prg)
   (prinl) )

(de  (Nm . Prg)
   (prin "")
   (htPrin Prg 2)
   (prinl  "") )

(de  (Str Url Tar)
   (prin "")
   (ht:Prin Str)
   (prin "") )

(de  (Src Alt Url DX DY)
   (when Url
      (prin "" ) )
   (prin "")
   (and Url (prin "")) )

(de  (Var Val . Prg)
   (prin "")
   (htPrin Prg 2)
   (prin "") )

(private) (Attr Prg)

(de  (Attr . Prg)
   (tag "th" Attr 2 Prg) )

(de  (Attr . Prg)
   (tag "tr" Attr 2 Prg) )

(de  (Attr . Prg)
   (tag "td" Attr 2 Prg) )

(de  (Attr . Prg)
   (tag "thead" Attr 2 Prg) )

(de  (Attr . Prg)
   (tag "tbody" Attr 2 Prg) )

(private) (Attr Ttl Head Prg *RowF Beg BegR Row EndR End C H L Y A N)

(de  (ATTR Ttl Head . Prg)
   (on *RowF)
   (let ((Beg C BegR Row EndR NIL NIL NIL End) *XhtmlTable)
      (micro Beg)
      (when Ttl
         (micro C
            (ht:Prin (eval Ttl 2)) ) )
      (when (find cdr Head)
         (micro BegR)
         (for H Head
            (let ATTR (car H)
               (micro Row
                  (htPrin (cdr H) 3) ) ) )
         (micro EndR) )
      (htPrin Prg 3)
      (micro End) ) )

(de alternating ()
   (onOff *RowF) )

(de  (Attr . Prg)
   (let ((Beg C NIL NIL NIL BegR Row EndR End) *XhtmlTable  H Head)
      (micro BegR)
      (while Prg
         (let (Y (++ Prg)  A (car (++ H))  N 1)
            (while (== '- (car Prg))
               (inc 'N)
               (++ Prg)
               (++ H) )
            (let ATTR
               (style Attr
                  (style
                     (and (> N 1) (cons "colspan" N))
                     (if (== 'align A) '(align (align . right)) A) ) )
               (micro Row
                  (if (atom Y)
                     (ht:Prin (eval Y 2))
                     (eval Y 2) ) ) ) ) )
      (micro EndR) ) )

(private) (Y Lst L E N)

(de  (Y . Lst)
   (let ((Beg BegR Row EndR End) *XhtmlGrid)
      (micro Beg)
      (while Lst
         (micro BegR)
         (use Y
            (let L (and (sym? Y) (chop Y))
               (do (or (num? Y) (length Y))
                  (let
                     (ATTR
                        (cond
                           ((pair Y) (++ Y))
                           ((= "." (++ L)) "align") )
                        E (++ Lst) )
                     (unless (== '- E)
                        (when (== '- (car Lst))
                           (let N 1
                              (for (P Lst (and P (== '- (++ P))))
                                 (inc 'N) )
                              (push 'N "colspan")
                              (setq ATTR (if ATTR (list ATTR N) N)) ) )
                        (micro Row
                           (if (atom E)
                              (ht:Prin (eval E 2))
                              (eval E 2) ) ) ) ) ) ) )
         (micro EndR) )
      (micro End) ) )

(de  Lst
   (
       '(width . "100%") NIL NIL
      ( NIL
         (
       '((width . "33%") (align . left))
            (eval (car Lst) 1) )
         ( '((width . "34%") (align . center))
            (eval (cadr Lst) 1) )
         ( '((width . "33%") (align . right))
            (eval (caddr Lst) 1) ) ) ) )

(de  Lst
   ( '(width . "100%") NIL '((norm) (align))
      ( NIL
         (eval (car Lst) 5)
         (run (cdr Lst) 5) ) ) )

(private) (X Txt Prg)

(de tip (X Txt)
   ( (cons 'title (glue "\n" X)) Txt) )

(de  (X . Prg)
   (let *Style (style (cons 'title (glue "\n" X)) *Style)
      (run Prg) ) )

(private) (Lst P LayX LayY L Args DX DY Cls Style)

# Layout
(de  Lst
   (let
      (Lay *XhtmlLayout
         P (and (=T (car Lst)) (++ Lst))
         LayX 0
         LayY 0 )
      (ifn Lay
         (recur (Lst LayX)
            (use (LayX LayY)
               (for L Lst
                  (let
                     (Args (mapcar eval (cddar L))
                        DX (eval (caar L))
                        DY (eval (cadar L))
                        Cls (unless (sub? ":" (car Args)) (++ Args))
                        Style
                        (cons 'style
                           (glue "; "
                              (cons
                                 "position:absolute"
                                 (pack "top:" LayY (if P "%" "px"))
                                 (pack "left:" LayX (if P "%" "px"))
                                 (cond
                                    ((=0 DX) "min-width:100%")
                                    (DX (pack "width:" DX (if P "%" "px"))) )
                                 (cond
                                    ((=0 DY) "min-height:100%")
                                    (DY (pack "height:" DY (if P "%" "px"))) )
                                 Args ) ) ) )
                     (prog1
                        (if Cls (list Cls Style) Style)  # -> '@'
                        (eval (cadr L)) )
                     (recurse (cddr L) (+ LayX DX))
                     (inc 'LayY DY) ) ) ) )
         (recur (Lst)
            (for L Lst
               (micro (++ Lay)
                  (run (cddadr L)) )
               (recurse (cddr L)) ) ) ) ) )

(private) (Url Str)

(de