picolisp

Unnamed repository; edit this file to name it for gitweb.
git clone https://logand.com/git/picolisp.git/
Log | Files | Refs | README | LICENSE

commit 3291fb0890008ab8a3d26e1917b1449c21bb170e
parent 2804ee02f9ddb3c273360e2ff9bef0a774f09351
Author: Commit-Bot <unknown>
Date:   Thu, 22 Apr 2010 14:32:31 +0000

Automatic commit from picoLisp.tgz, From: Thu, 22 Apr 2010 11:32:31 GMT
Diffstat:
ACHANGES | 404+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
ACOPYING | 280+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
ACREDITS | 23+++++++++++++++++++++++
AINSTALL | 103+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
AREADME | 105+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
AReleaseNotes | 18++++++++++++++++++
Aapp/cusu.l | 43+++++++++++++++++++++++++++++++++++++++++++
Aapp/er.l | 167+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Aapp/gui.l | 243+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Aapp/init.l | 81+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Aapp/inventory.l | 55+++++++++++++++++++++++++++++++++++++++++++++++++++++++
Aapp/item.l | 40++++++++++++++++++++++++++++++++++++++++
Aapp/lib.l | 62++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Aapp/loc/ar | 5+++++
Aapp/loc/ch | 4++++
Aapp/loc/de | 86+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Aapp/loc/es | 86+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Aapp/loc/jp | 86+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Aapp/loc/no | 86+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Aapp/loc/ru | 86+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Aapp/main.l | 61+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Aapp/ord.l | 58++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Aapp/role.l | 33+++++++++++++++++++++++++++++++++
Aapp/sal.l | 21+++++++++++++++++++++
Aapp/sales.l | 56++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Aapp/user.l | 36++++++++++++++++++++++++++++++++++++
Abin/pil | 2++
Abin/psh | 14++++++++++++++
Abin/replica | 31+++++++++++++++++++++++++++++++
Abin/scrape | 11+++++++++++
Abin/watchdog | 68++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Acygwin/README | 170+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Acygwin/tcc.l | 22++++++++++++++++++++++
Adbg | 2++
Adbg.l | 16++++++++++++++++
Adoc/app.html | 2551+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Adoc/apply | 30++++++++++++++++++++++++++++++
Adoc/db | 91+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Adoc/doc.css | 12++++++++++++
Adoc/family.l | 242+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Adoc/family/1 | 0
Adoc/family/2 | 0
Adoc/family/3 | 0
Adoc/family/4 | 0
Adoc/faq.html | 664+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Adoc/fun.l | 9+++++++++
Adoc/hello.l | 5+++++
Adoc/index.html | 108+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Adoc/model | 57+++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Adoc/quine | 24++++++++++++++++++++++++
Adoc/ref.html | 2455+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Adoc/refA.html | 567+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Adoc/refB.html | 319+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Adoc/refC.html | 657+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Adoc/refD.html | 748+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Adoc/refE.html | 486+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Adoc/refF.html | 512+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Adoc/refG.html | 188+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Adoc/refH.html | 216+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Adoc/refI.html | 389+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Adoc/refJ.html | 81+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Adoc/refK.html | 58++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Adoc/refL.html | 531+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Adoc/refM.html | 621+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Adoc/refN.html | 399+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Adoc/refO.html | 262+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Adoc/refP.html | 816+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Adoc/refQ.html | 107+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Adoc/refR.html | 713+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Adoc/refS.html | 870+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Adoc/refT.html | 565+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Adoc/refU.html | 356+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Adoc/refV.html | 163+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Adoc/refW.html | 196+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Adoc/refX.html | 57+++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Adoc/refY.html | 30++++++++++++++++++++++++++++++
Adoc/refZ.html | 102+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Adoc/ref_.html | 546+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Adoc/rlook.html | 67+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Adoc/select.html | 490+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Adoc/shape.l | 59+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Adoc/structures | 90+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Adoc/toc.html | 41+++++++++++++++++++++++++++++++++++++++++
Adoc/travel | 24++++++++++++++++++++++++
Adoc/tut.html | 2402+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Adoc/utf8 | 39+++++++++++++++++++++++++++++++++++++++
Adoc64/README | 136+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Adoc64/asm | 194+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Adoc64/structures | 308+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Aext.l | 6++++++
Afavicon.ico | 0
Agames/README | 233+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Agames/chess.l | 566+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Agames/mine.l | 126+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Agames/nim.l | 27+++++++++++++++++++++++++++
Agames/sudoku.l | 73+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Agames/ttt.l | 72++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Agames/xchess | 49+++++++++++++++++++++++++++++++++++++++++++++++++
Aimg/7fach.eps | 474+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Aimg/7fach.gif | 0
Aimg/go.png | 0
Aimg/no.png | 0
Alib.css | 194+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Alib.l | 369+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Alib/adm.l | 71+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Alib/app.l | 34++++++++++++++++++++++++++++++++++
Alib/boss.l | 16++++++++++++++++
Alib/btree.l | 438+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Alib/cal.l | 79+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Alib/conDbgc.l | 69+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Alib/db.l | 1125++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Alib/db32-64.l | 73+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Alib/dbase.l | 59+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Alib/debug.l | 362+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Alib/ed.l | 47+++++++++++++++++++++++++++++++++++++++++++++++
Alib/edit.l | 66++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Alib/el/inferior-picolisp.el | 312+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Alib/el/paredit.el.diff | 89+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Alib/el/picolisp.el | 536+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Alib/el/tsm.el | 130+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Alib/form.js | 352+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Alib/form.l | 2069+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Alib/gcc.l | 40++++++++++++++++++++++++++++++++++++++++
Alib/glyphlist.txt | 4322+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Alib/head.ps | 28++++++++++++++++++++++++++++
Alib/heartbeat.l | 19+++++++++++++++++++
Alib/http.l | 440+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Alib/import.l | 30++++++++++++++++++++++++++++++
Alib/led.l | 431+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Alib/led.min.l | 23+++++++++++++++++++++++
Alib/lint.l | 257+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Alib/math.l | 11+++++++++++
Alib/math32.l | 22++++++++++++++++++++++
Alib/math64.l | 44++++++++++++++++++++++++++++++++++++++++++++
Alib/misc.l | 480+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Alib/native.l | 23+++++++++++++++++++++++
Alib/pilog.l | 550+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Alib/prof.l | 51+++++++++++++++++++++++++++++++++++++++++++++++++++
Alib/ps.l | 318+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Alib/readline.l | 28++++++++++++++++++++++++++++
Alib/rsa.l | 109+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Alib/scrape.l | 160+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Alib/simul.l | 154+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Alib/sq.l | 131+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Alib/tags | 346+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Alib/term.l | 47+++++++++++++++++++++++++++++++++++++++++++++++
Alib/test.l | 31+++++++++++++++++++++++++++++++
Alib/tex.l | 164+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Alib/too.l | 487+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Alib/xhtml.l | 669+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Alib/xm.l | 115+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Alib/xml.l | 286+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Alib/xmlrpc.l | 63+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Aloc/AR.l | 7+++++++
Aloc/CH.l | 7+++++++
Aloc/DE.l | 7+++++++
Aloc/ES.l | 7+++++++
Aloc/JP.l | 7+++++++
Aloc/NIL.l | 7+++++++
Aloc/NO.l | 7+++++++
Aloc/RU.l | 7+++++++
Aloc/UK.l | 7+++++++
Aloc/US.l | 7+++++++
Aloc/ar | 1+
Aloc/ch | 4++++
Aloc/de | 77+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Aloc/es | 52++++++++++++++++++++++++++++++++++++++++++++++++++++
Aloc/jp | 77+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Aloc/no | 77+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Aloc/ru | 77+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Amisc/bigtest | 103+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Amisc/calc | 12++++++++++++
Amisc/calc.l | 73+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Amisc/chat | 32++++++++++++++++++++++++++++++++
Amisc/crc.l | 23+++++++++++++++++++++++
Amisc/dining.l | 42++++++++++++++++++++++++++++++++++++++++++
Amisc/dirTree.l | 19+++++++++++++++++++
Amisc/fannkuch.l | 38++++++++++++++++++++++++++++++++++++++
Amisc/fibo.l | 50++++++++++++++++++++++++++++++++++++++++++++++++++
Amisc/hanoi.l | 24++++++++++++++++++++++++
Amisc/life.l | 54++++++++++++++++++++++++++++++++++++++++++++++++++++++
Amisc/mailing | 93+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Amisc/maze.l | 33+++++++++++++++++++++++++++++++++
Amisc/pi.l | 23+++++++++++++++++++++++
Amisc/pilog.l | 125+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Amisc/reverse.l | 16++++++++++++++++
Amisc/setf.l | 49+++++++++++++++++++++++++++++++++++++++++++++++++
Amisc/sieve.l | 14++++++++++++++
Amisc/stress.l | 68++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Amisc/travel.l | 51+++++++++++++++++++++++++++++++++++++++++++++++++++
Amisc/trip.l | 84+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Aopt/pilog.l | 15+++++++++++++++
Ap | 2++
Aplmod | 2++
Aplmod.l | 10++++++++++
Arcsim/README | 125+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Arcsim/env.l | 103+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Arcsim/fokker.l | 456+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Arcsim/lib.l | 255+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Arcsim/main.l | 124+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Arcsim/tone | 41+++++++++++++++++++++++++++++++++++++++++
Asimul/lib.l | 90+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Asimul/rgb.l | 29+++++++++++++++++++++++++++++
Asrc/Makefile | 145+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Asrc/apply.c | 676+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Asrc/balance.c | 94+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Asrc/big.c | 1137+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Asrc/ext.c | 182+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Asrc/flow.c | 1688+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Asrc/gc.c | 185+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Asrc/ht.c | 368+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Asrc/httpGate.c | 309+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Asrc/io.c | 3543+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Asrc/lat1.c | 75+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Asrc/main.c | 1140+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Asrc/net.c | 204+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Asrc/pico.h | 852+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Asrc/ssl.c | 241+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Asrc/start.c | 10++++++++++
Asrc/subr.c | 1686+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Asrc/sym.c | 1991+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Asrc/tab.c | 410+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Asrc/utf2.c | 68++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Asrc/z3d.c | 468+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Asrc/z3dClient.c | 532+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Asrc64/Makefile | 65+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Asrc64/apply.l | 1606+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Asrc64/arch/x86-64.l | 772+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Asrc64/big.l | 2673+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Asrc64/db.l | 2249+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Asrc64/defs.l | 65+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Asrc64/err.l | 726+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Asrc64/ext.l | 248+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Asrc64/flow.l | 3150+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Asrc64/gc.l | 1002+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Asrc64/glob.l | 1078+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Asrc64/ht.l | 727+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Asrc64/io.l | 5001+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Asrc64/lib/asm.l | 546+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Asrc64/main.l | 2605+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Asrc64/mkAsm | 14++++++++++++++
Asrc64/net.l | 336+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Asrc64/subr.l | 4013+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Asrc64/sym.l | 3417+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Asrc64/sys/linux.code.l | 39+++++++++++++++++++++++++++++++++++++++
Asrc64/sys/linux.defs.l | 145+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Asrc64/version.l | 6++++++
Atest/lib.l | 201+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Atest/lib/lint.l | 21+++++++++++++++++++++
Atest/lib/misc.l | 213+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Atest/src/apply.l | 107+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Atest/src/big.l | 159+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Atest/src/db.l | 43+++++++++++++++++++++++++++++++++++++++++++
Atest/src/ext.l | 22++++++++++++++++++++++
Atest/src/ext2.l | 31+++++++++++++++++++++++++++++++
Atest/src/flow.l | 434+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Atest/src/ht.l | 46++++++++++++++++++++++++++++++++++++++++++++++
Atest/src/io.l | 220+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Atest/src/main.l | 150+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Atest/src/net.l | 25+++++++++++++++++++++++++
Atest/src/subr.l | 477+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Atest/src/sym.l | 368+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
262 files changed, 93029 insertions(+), 0 deletions(-)

diff --git a/CHANGES b/CHANGES @@ -0,0 +1,404 @@ +* XXjun10 picoLisp-3.0.3 + +* 30mar10 picoLisp-3.0.2 + Simple incrementing form of 'for' + Changed 'scl' to set '*Scl' globally + 'acquire' and 'release' mutex functions + Changed 'state' syntax + 'version' function (64-bit) + C 'lisp()' callback function (64-bit) + Bug in 'member' for circular lists (64-bit) + "lib/tags" for 'vi' source access + Bug in 'next' and 'arg' (64-bit) + Bug in comma read macro (64-bit) + Bug in binary read functions (64-bit) + 'hax' function + Bug when deleting external symbols (64-bit) + Bug in external symbol names (64-bit) + Bug in '|' and 'x|' (32-bit) + +* 31dec09 picoLisp-3.0.1 + '*Tsm' transient symbol markup + 'range' function + 'gcc' for 64-bit in "lib/native.l" + 'flip' optional 'cnt' argument + Up to four letters in 'c[ad]*ar' and 'c[ad]*dr' + Fixed sporadic GUI errors + GUI 'onchange' handling + +* 07oct09 picoLisp-3.0 + 64-bit version for x86-64 + Allowed '.' in symbol names + Changed GUI to Post/Redirect/Get pattern + Changed event handling to non-blocking I/O + Extension ".l" on localization country files + Deprecated 'begin' and 'nagle' + +* 30jun09 picoLisp-2.3.7 + 'dbg' startup script + Removed 'stk' function + Bug in GUI history "back" handling + Multi-line (block) comments + Improved external hash table + Transient characters no longer interned + 'getd' loads shared library code + +* 31mar09 picoLisp-2.3.6 + 'lines' returns 'NIL' on failure + Only numeric argument to 'hear' + 'sort' optional 'fun' argument + Bugs in 'evList()' and 'date' + +* 31dec08 picoLisp-2.3.5 + Bug in 'pipe' + Bug in 'later' + Dialog and chart bugs in "lib/form.l" + HTTP protocol bug in "lib/http.l" + Bugs in 'inc' and 'bigCmp()' + 'abort' function + 'eval' and 'run' optional 'lst' argument + +* 30sep08 picoLisp-2.3.4 + 'once' function + 'hex' and 'oct' negative arguments + Bug in 'pool' + 'cmd' function + 'script' function + Bug in 'idx' + Bug in 'lit' + 'extract' function + +* 29jun08 picoLisp-2.3.3 + Removed '*Rst' global variable + Catch error messages + Remote Pilog queries + DB extension with '*Ext' and 'ext' + Extended 'put'-syntax to zero keys + Wrong '@@' result in 'load' + Handling of "#" in 'str' + +* 29mar08 picoLisp-2.3.2 + Ctrl-D termination + Improved termios restore + 'file' function + ';' function + Changed (time T) semantics + Bugs in 'idx' and 'lup' + DB synchronous transaction log + Handling of 'bind' in 'debug' + +* 30dec07 picoLisp-2.3.1 + 'str' extended to parse tokens + '*Hup' global variable + Changed/extended 'all' semantics + Replaced 'die' with 'alarm' + Bug in 'glue' + Improved '@' handling + Bug in 'bye()' + 'eol' end-of-line function + Escape delimiter characters in symbol names + 'lint' also file contents + 'noLint' function + +* 30sep07 picoLisp-2.3.0 + Extended "lib/test.l" unit tests + 'full' function + Bug in 'wipe' + Bug in 'digSub1()' + Changed internal symbol structure + 'pid' selector for 'tell' + 'vi' and 'ld' source code access + Restored 'in'/'out' negative channel offsets + Abandoned 'stdio' in I/O functions + Improved signal handling + 'leaf' function + Restored 'gc' unit to "megabytes" + Changed 'heap' return values + Bug in 'tell' + 'chess' XBoard interface + '*Sig1', '*Sig2' global variables + 'ipid' and 'opid' functions + Bug in writing blobs + Timeout bug in 'httpGate' + '*Zap' global variable + '*OS' global variable + +* 30jun07 picoLisp-2.2.7 + Extended "doc/ref.html" + 'cons' multiple arguments + 'yoke' function + 'up' optional 'cnt' argument + +* 01apr07 picoLisp-2.2.6 + 'app' reference application + Bug in 'text' + Family IPC redesign + Gave up 'in'/'out' negative channel offsets + Changed 'keep>' and 'lose>' methods + Gave up '*Tsm' transient symbol markup + 'sect' and 'diff' in C + 'gc' unit changed to "million cells" + +* 31dec06 picoLisp-2.2.5 + Persistent HTTP Connections + Extended 'tick' to count system time + Chunked HTTP transfers + Changed '*Key' to '*Run' + 'fifo' function + 'die' alarm function + 'line' carriage return handling + Pre- and post-arguments to 'commit' + 'text' function + 'glue' in C + Ajax GUI in "lib/form.l", "lib/form.js" + 'push1' function (deprecates '?push') + Bug in 'ht:Fmt' + +* 30sep06 picoLisp-2.2.4 + Cygwin/Win32 port (Doug Snead) + Changed 'bind' argument + 'fish' function + 'rd' optional 'sym' argument + Bug in 'lock' (unlock all) + 'free' function + Extended 'seq' to return first symbol + Simple 'udp' function + 'usec' function + Bug in 'isLife()' + '*PPid' global variable + 'nagle' network function + Extended 'get'-syntax to 'asoq' + +* 30jun06 picoLisp-2.2.3 + "redefined" messages go to stderr + Bug in 'argv' + Deprecated "lib/tree.l" + Restored '*Solo' global variable + '(get lst 0)' returns 'NIL' + Bug in 'extern' + 'nond' (negated 'cond') function + 'ge0' function + Bug in 'lose>' and 'keep>' for '+Joint' + '*Rst' global variable + Bug in 'next'/'arg' + Changed 'env' and 'job' + Bug in B-Tree 'step' + Changed 'mark' return value + Changed 'close' return value + +* 29mar06 picoLisp-2.2.2 + Mac OS X (Darwin) port (Rick Hanson) + 'pwd' function + 'if2' flow function + 'rpc' function + 'one' function + Changed 'space' return value + 'up' symbol binding lookup function + Bug in 'eval' and 'run' environment offset + 'onOff' function + 'path' substitution function + '*Tsm' transient symbol markup + Underlining transient symbols + +* 30dec05 picoLisp-2.2.1 + 'eof' end-of-file function + Changed 'line' EOF return value + Deprecated 'whilst' and 'until=T' + 'read' extended to parse tokens + 'raw' console mode function + 'later' multiprocessing function + Bug in nested 'fork' and 'pipe' + Extended 'gcc' arguments + Bug in 'boxWord2()' + 'id' external symbol function + Extended 'dm' syntax for object argument + 'size' changed to return bytes instead of blocks in DB + Executable renamed to "picolisp" + 'lieu' predicate function + Bug in 'compare()' + +* 29sep05 picoLisp-2.2.0 + FreeBSD port + B-Trees + Multi-file DB + Configurable DB block size + Generalized 'pipe' semantics + Changed 'rank' to sorted lists + Removed '*Solo' global variable + Relaxed 'wipe' "modified" error condition + DB-I/O changed to 'pread()' and 'pwrite()' + Extended 'get'-syntax to zero and negative keys + 'by' attribute map function + Swing GUI in "java2/" and "lib/gui2.l" + 'box?' predicate function + Bug in 'compare()' + 'balance' C-utility + +* 30jun05 picoLisp-2.1.2 + GC non-recursive + 'lup' lookup in 'idx' trees + Applet colors + 'try' to send messages + 'x|' function + Tooltips in applets + Binding environment offset for 'eval' and 'run' + XHTML/CSS support in "lib/xhtml.l" + Separated "lib/html.l" from "lib/http.l" + Removed "lib/http.l" from "ext.l" + Bug in 'isa' + Bug in 'lose>' and 'keep>' for '+Bag' + Security hole in 'http' + Bug in 'rel>' for '+Hook' + +* 30mar05 picoLisp-2.1.1 + 'protect' function + DB journaling + 'chess' demo + Predicates return their argument instead of 'T', if possible + Bug in 'fun?' + Improved 'lint' heuristics + I/O-Multiplexing also for plain stdin + 'dir' in C + Self-adjusting applet size + Bug in 'pack()' + +* 30dec04 picoLisp-2.1.0 + 'pipe' function + Bugs in bignum arithmetic + 'arg' optional 'cnt' argument + '+Aux' auxiliary index keys + '*Solo' global variable + 'flg?' predicate function + 'fin' access function + Bug in 'compare()' + 'cd' returns old directory + 'inc' and 'dec' numeric argument + Next 'opt' command line arg + 'finally' exception cleanup + Implied 'upd' argument in transactions 'put!>', 'del!>' etc. + Bug in 'idx' for empty trees + 'curry' function + Anonymous recursion with 'recur' and 'recurse' + Extended 'env' to return bindings + Second argument to 'fill' + Optional comment character argument for 'skip' + 'flip' destructive list reversal + +* 01oct04 picoLisp-2.0.14 + '<tree>' HTML function + Finite 'state' machine function + Extended 'for' functionality + 'rcsim' toy RC flight simulator + Bug in 'sym', 'str' and '*/' + Extended 'dbck' return value + +* 03aug04 picoLisp-2.0.13 + Changed rounding and argument policy of '*/' + Applet protocol revised + Extended 'head' and 'tail' to predicate functionality + Changed 'accu' default from 1 to 0 + Dialog handling revised + Multiple JAR files per applet + Fixed "Last-Modified:" format in 'httpEcho' + +* 29may04 picoLisp-2.0.12 + Fixed 'boss' mechanism + 'del' delete-and-set function + '*Fork' global variable + Changed URL encoding of Lisp objects + Removed traffic throttle from 'httpGate' + Synchronized ".picoHistory" in "lib/led.l" + Fixed exception handling in debug breakpoint + Revised subclass handling in 'db' and 'collect' + Applet font/size parameters + +* 07apr04 picoLisp-2.0.11 + Bug in 'append' + Modal dialogs revised + Bug in 'lose>' and 'keep>' for '+Bag' + 'poll' (no block-on-read-) check function + Inline 'gcc' C-function compilation + +* 01feb04 picoLisp-2.0.10 + 'wr' raw byte output function + Improved modal dialogs + Comma ',' read-macro, replacing the '_' function + 'let?' conditional flow/bind function + 'accept' non-blocking, with timeout + Optional method-defining arguments to '+Form's + '+Bool' relation class + '+Ref2' backing index prefix class + 'size' returns number of DB blocks for external symbols + '+ListTextField' split parameter + +* 06dec03 picoLisp-2.0.9 + 'Tele' java client + Closed leaking file descriptors in 'fork' + Changed applet protocol to individual server connections + Decoupled applet init from HTML page load + +* 14oct03 picoLisp-2.0.8b + Bug in 'put>', 'rel>', 'lose>' and 'keep>' for '+List' + Bug in 'lose>' and 'keep>' for '+Bag' + +* 01oct03 picoLisp-2.0.8 + '+Hook' handling in '+Bag' + Unicode case conversions + '+Hook' changed to prefix class + Telephone number locales + CR-LF in HTTP headers + 'date' and 'time' return UTC for 'T' argument + 'clk>' (doubleclick) for '+DrawField' + Improved Hook support in Pilog + Optional 'NIL' argument to 'html' for "no Cache-Control" + +* 03aug03 picoLisp-2.0.7 + Extended 'in' and 'out' for negative channel offset arguments + Changed internal database index tree function API + Changed 'info' to return 'T' for the directory size + Interrupt signal handling in 'ctty', 'psh' and "bin/psh" + Generic 'help>' method for '+Form' class in "lib/gui.l" + Fixed 'ht:Prin' bug (NULL-Bytes) + 'argv' optional symbolic arguments + Changed 'idx' return value + Better tracing and profiling of C-functions + +* 08jun03 picoLisp-2.0.6 + Allowed '#' in symbol names + Changed 'eps' in "lib/ps.l" + Interactive DB tools in "lib/sq.l" + 'revise' line editor function + 'circ' changed to individual arguments + Moved code-libraries to "lib/" + Moved *.jar-files to "java/" + +* 23apr03 picoLisp-2.0.5 + 'mail' changed to direct SMTP + 'sys' environment access function + Plain HTML-GUI "lib/htm.l" (experimental) + Semantics of 'do NIL' changed from enless- to zero-loop + +* 03mar03 picoLisp-2.0.4 + Changed and extended '+IndexChart' + '=0', 'lt0' and 'gt0' return numeric argument instead of 'T' + 'cut' changed to be non-desctructive + 'ssl' replication mechanism + 'ctl' file control primitives + 'ext?' and 'extern' check for physical existence of external symbol + +* 01feb03 picoLisp-2.0.3 + Extension and redesign of the HTML API + 'loop' function as a synonym for 'do NIL' + +* 17jan03 picoLisp-2.0.2 + The example files for the tutorial were in the wrong directory + Bind '*Key' in debug breakpoint + Localization bug in "misc/tax.l" + +* 27dec02 picoLisp-2.0.1 + Default locale 'NIL' + Pilog documentation + Example family database + +* 16dec02 picoLisp-2.0 + Initial release diff --git a/COPYING b/COPYING @@ -0,0 +1,280 @@ + GNU GENERAL PUBLIC LICENSE + Version 2, June 1991 + + Copyright (C) 1989, 1991 Free Software Foundation, Inc. + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + + Preamble + + The licenses for most software are designed to take away your +freedom to share and change it. By contrast, the GNU General Public +License is intended to guarantee your freedom to share and change free +software--to make sure the software is free for all its users. This +General Public License applies to most of the Free Software +Foundation's software and to any other program whose authors commit to +using it. (Some other Free Software Foundation software is covered by +the GNU Library General Public License instead.) You can apply it to +your programs, too. + + When we speak of free software, we are referring to freedom, not +price. Our General Public Licenses are designed to make sure that you +have the freedom to distribute copies of free software (and charge for +this service if you wish), that you receive source code or can get it +if you want it, that you can change the software or use pieces of it +in new free programs; and that you know you can do these things. + + To protect your rights, we need to make restrictions that forbid +anyone to deny you these rights or to ask you to surrender the rights. +These restrictions translate to certain responsibilities for you if you +distribute copies of the software, or if you modify it. + + For example, if you distribute copies of such a program, whether +gratis or for a fee, you must give the recipients all the rights that +you have. You must make sure that they, too, receive or can get the +source code. And you must show them these terms so they know their +rights. + + We protect your rights with two steps: (1) copyright the software, and +(2) offer you this license which gives you legal permission to copy, +distribute and/or modify the software. + + Also, for each author's protection and ours, we want to make certain +that everyone understands that there is no warranty for this free +software. If the software is modified by someone else and passed on, we +want its recipients to know that what they have is not the original, so +that any problems introduced by others will not reflect on the original +authors' reputations. + + Finally, any free program is threatened constantly by software +patents. We wish to avoid the danger that redistributors of a free +program will individually obtain patent licenses, in effect making the +program proprietary. To prevent this, we have made it clear that any +patent must be licensed for everyone's free use or not licensed at all. + + The precise terms and conditions for copying, distribution and +modification follow. + + GNU GENERAL PUBLIC LICENSE + TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION + + 0. This License applies to any program or other work which contains +a notice placed by the copyright holder saying it may be distributed +under the terms of this General Public License. The "Program", below, +refers to any such program or work, and a "work based on the Program" +means either the Program or any derivative work under copyright law: +that is to say, a work containing the Program or a portion of it, +either verbatim or with modifications and/or translated into another +language. (Hereinafter, translation is included without limitation in +the term "modification".) Each licensee is addressed as "you". + +Activities other than copying, distribution and modification are not +covered by this License; they are outside its scope. The act of +running the Program is not restricted, and the output from the Program +is covered only if its contents constitute a work based on the +Program (independent of having been made by running the Program). +Whether that is true depends on what the Program does. + + 1. You may copy and distribute verbatim copies of the Program's +source code as you receive it, in any medium, provided that you +conspicuously and appropriately publish on each copy an appropriate +copyright notice and disclaimer of warranty; keep intact all the +notices that refer to this License and to the absence of any warranty; +and give any other recipients of the Program a copy of this License +along with the Program. + +You may charge a fee for the physical act of transferring a copy, and +you may at your option offer warranty protection in exchange for a fee. + + 2. You may modify your copy or copies of the Program or any portion +of it, thus forming a work based on the Program, and copy and +distribute such modifications or work under the terms of Section 1 +above, provided that you also meet all of these conditions: + + a) You must cause the modified files to carry prominent notices + stating that you changed the files and the date of any change. + + b) You must cause any work that you distribute or publish, that in + whole or in part contains or is derived from the Program or any + part thereof, to be licensed as a whole at no charge to all third + parties under the terms of this License. + + c) If the modified program normally reads commands interactively + when run, you must cause it, when started running for such + interactive use in the most ordinary way, to print or display an + announcement including an appropriate copyright notice and a + notice that there is no warranty (or else, saying that you provide + a warranty) and that users may redistribute the program under + these conditions, and telling the user how to view a copy of this + License. (Exception: if the Program itself is interactive but + does not normally print such an announcement, your work based on + the Program is not required to print an announcement.) + +These requirements apply to the modified work as a whole. If +identifiable sections of that work are not derived from the Program, +and can be reasonably considered independent and separate works in +themselves, then this License, and its terms, do not apply to those +sections when you distribute them as separate works. But when you +distribute the same sections as part of a whole which is a work based +on the Program, the distribution of the whole must be on the terms of +this License, whose permissions for other licensees extend to the +entire whole, and thus to each and every part regardless of who wrote it. + +Thus, it is not the intent of this section to claim rights or contest +your rights to work written entirely by you; rather, the intent is to +exercise the right to control the distribution of derivative or +collective works based on the Program. + +In addition, mere aggregation of another work not based on the Program +with the Program (or with a work based on the Program) on a volume of +a storage or distribution medium does not bring the other work under +the scope of this License. + + 3. You may copy and distribute the Program (or a work based on it, +under Section 2) in object code or executable form under the terms of +Sections 1 and 2 above provided that you also do one of the following: + + a) Accompany it with the complete corresponding machine-readable + source code, which must be distributed under the terms of Sections + 1 and 2 above on a medium customarily used for software interchange; or, + + b) Accompany it with a written offer, valid for at least three + years, to give any third party, for a charge no more than your + cost of physically performing source distribution, a complete + machine-readable copy of the corresponding source code, to be + distributed under the terms of Sections 1 and 2 above on a medium + customarily used for software interchange; or, + + c) Accompany it with the information you received as to the offer + to distribute corresponding source code. (This alternative is + allowed only for noncommercial distribution and only if you + received the program in object code or executable form with such + an offer, in accord with Subsection b above.) + +The source code for a work means the preferred form of the work for +making modifications to it. For an executable work, complete source +code means all the source code for all modules it contains, plus any +associated interface definition files, plus the scripts used to +control compilation and installation of the executable. However, as a +special exception, the source code distributed need not include +anything that is normally distributed (in either source or binary +form) with the major components (compiler, kernel, and so on) of the +operating system on which the executable runs, unless that component +itself accompanies the executable. + +If distribution of executable or object code is made by offering +access to copy from a designated place, then offering equivalent +access to copy the source code from the same place counts as +distribution of the source code, even though third parties are not +compelled to copy the source along with the object code. + + 4. You may not copy, modify, sublicense, or distribute the Program +except as expressly provided under this License. Any attempt +otherwise to copy, modify, sublicense or distribute the Program is +void, and will automatically terminate your rights under this License. +However, parties who have received copies, or rights, from you under +this License will not have their licenses terminated so long as such +parties remain in full compliance. + + 5. You are not required to accept this License, since you have not +signed it. However, nothing else grants you permission to modify or +distribute the Program or its derivative works. These actions are +prohibited by law if you do not accept this License. Therefore, by +modifying or distributing the Program (or any work based on the +Program), you indicate your acceptance of this License to do so, and +all its terms and conditions for copying, distributing or modifying +the Program or works based on it. + + 6. Each time you redistribute the Program (or any work based on the +Program), the recipient automatically receives a license from the +original licensor to copy, distribute or modify the Program subject to +these terms and conditions. You may not impose any further +restrictions on the recipients' exercise of the rights granted herein. +You are not responsible for enforcing compliance by third parties to +this License. + + 7. If, as a consequence of a court judgment or allegation of patent +infringement or for any other reason (not limited to patent issues), +conditions are imposed on you (whether by court order, agreement or +otherwise) that contradict the conditions of this License, they do not +excuse you from the conditions of this License. If you cannot +distribute so as to satisfy simultaneously your obligations under this +License and any other pertinent obligations, then as a consequence you +may not distribute the Program at all. For example, if a patent +license would not permit royalty-free redistribution of the Program by +all those who receive copies directly or indirectly through you, then +the only way you could satisfy both it and this License would be to +refrain entirely from distribution of the Program. + +If any portion of this section is held invalid or unenforceable under +any particular circumstance, the balance of the section is intended to +apply and the section as a whole is intended to apply in other +circumstances. + +It is not the purpose of this section to induce you to infringe any +patents or other property right claims or to contest validity of any +such claims; this section has the sole purpose of protecting the +integrity of the free software distribution system, which is +implemented by public license practices. Many people have made +generous contributions to the wide range of software distributed +through that system in reliance on consistent application of that +system; it is up to the author/donor to decide if he or she is willing +to distribute software through any other system and a licensee cannot +impose that choice. + +This section is intended to make thoroughly clear what is believed to +be a consequence of the rest of this License. + + 8. If the distribution and/or use of the Program is restricted in +certain countries either by patents or by copyrighted interfaces, the +original copyright holder who places the Program under this License +may add an explicit geographical distribution limitation excluding +those countries, so that distribution is permitted only in or among +countries not thus excluded. In such case, this License incorporates +the limitation as if written in the body of this License. + + 9. The Free Software Foundation may publish revised and/or new versions +of the General Public License from time to time. Such new versions will +be similar in spirit to the present version, but may differ in detail to +address new problems or concerns. + +Each version is given a distinguishing version number. If the Program +specifies a version number of this License which applies to it and "any +later version", you have the option of following the terms and conditions +either of that version or of any later version published by the Free +Software Foundation. If the Program does not specify a version number of +this License, you may choose any version ever published by the Free Software +Foundation. + + 10. If you wish to incorporate parts of the Program into other free +programs whose distribution conditions are different, write to the author +to ask for permission. For software which is copyrighted by the Free +Software Foundation, write to the Free Software Foundation; we sometimes +make exceptions for this. Our decision will be guided by the two goals +of preserving the free status of all derivatives of our free software and +of promoting the sharing and reuse of software generally. + + NO WARRANTY + + 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY +FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN +OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES +PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED +OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF +MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS +TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE +PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, +REPAIR OR CORRECTION. + + 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING +WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR +REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, +INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING +OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED +TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY +YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER +PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE +POSSIBILITY OF SUCH DAMAGES. + + END OF TERMS AND CONDITIONS diff --git a/CREDITS b/CREDITS @@ -0,0 +1,23 @@ +# The PicoLisp system is originally written and maintained by +Alexander Burger <abu@software-lab.de> + +# For many years, ideas and application concepts were contributed by +Josef Bartl <josef.bartl@7fach.org> + +# Build procedure for Mac OS X (Darwin) +Rick Hanson <rick@tamos.net> + +# Port to Cygwin/Win32 +Doug Snead <doug@drugsense.org> + +# Documentation, Mac OS support, OpenGL library, Norwegian localization +Jon Kleiser <jon.kleiser@usit.uio.no> + +# Russian localization +Mansur Mamkin <mmamkin@mail.ru> + +# XML parser (and other) improvements +Tomas Hlavaty <kvietaag@seznam.cz> + +# Spanish localization and emacs picolisp-mode +Armadillo <tc.rucho@gmail.com> diff --git a/INSTALL b/INSTALL @@ -0,0 +1,103 @@ +16mar10abu +(c) Software Lab. Alexander Burger + + + PicoLisp Installation + ===================== + +There is no 'configure' procedure, but the PicoLisp file structure is simple +enough to get along without it (we hope). It should compile and run on +GNU/Linux, FreeBSD, Mac OS X (Darwin), Cygwin/Win32, and possibly other systems +without problems. + +By default, PicoLisp installs completely in a local directory. No need to touch +any system locations, so you don't have to be root. + + +Please follow these steps: + +1. Unpack the distribution + + $ tar xfz picoLisp-XXX.tgz + +2. Change the directory + + $ cd picoLisp-XXX + +3. Compile the PicoLisp interpreter + + $ (cd src; make picolisp) + + or, if you have an x86-64 Linux system, build the 64-bit version + + $ (cd src64; make picolisp) + + In both cases the executable bin/picolisp will be created. + + Note that on the BSD family of operating systems, 'gmake' must be used + instead of 'make'. + +4. Optional (but recommended) are two symbolic links from /usr/lib and /usr/bin + to the installation directory + + # ln -s /<installdir> /usr/lib/picolisp + # ln -s /usr/lib/picolisp/bin/picolisp /usr/bin/picolisp + + In that case, you might also copy the script bin/pil to /usr/bin, for a + convenient global invocation. + + + Invocation + ---------- + +The shell script 'dbg' is usually called to start up PicoLisp in interactive +debugging mode + + $ ./dbg + : + +The colon ':' is PicoLisp's prompt. You may enter some Lisp expression, + + : (+ 1 2 3) + -> 6 + +To exit the interpreter, enter + + : (bye) + +or simply type an empy line (Return). + + + Console Underlines + ================== + +In case that your console (terminal) does not support underlining, you might +want to remove or replace the first statement int "ext.l" which uses the +terminfo database to initialize the global variable '*Tsm' (transient symbol +markup). Unfortunately, the VGA text mode does not properly support underlines. + + + Documentation + ------------- + +For further information, please look at "doc/index.html". There you find the +PicoLisp Reference Manual (doc/ref.html), the PicoLisp tutorials (doc/tut.html +and doc/app.html), and the frequently asked questions (doc/faq.html). + +For details about the 64-bit version, refer to "doc64/README", "doc64/asm" and +"doc64/structures". + +As always, the most accurate and complete documentation is the source code ;-) +Included in the distribution are many utilities and pet projects, including +tests, demo databases and servers, games (chess, minesweeper), 3D animation +(flight simulator), and more. + +Any feedback is welcome! +Hope you enjoy :-) + +-------------------------------------------------------------------------------- + + Alexander Burger + Software Lab. / 7fach GmbH + Bahnhofstr. 24a, D-86462 Langweid + abu@software-lab.de, http://www.software-lab.de, +49 8230 5060 diff --git a/README b/README @@ -0,0 +1,105 @@ +12nov09abu +(c) 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 +"http://software-lab.de/down.html". + + +(2) As an application server framework, PicoLisp provides for + 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, vim 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 redistribute it under the +conditions of the GNU General Public License (GPL). + +It compiles and runs on current 32-bit GNU/Linux, FreeBSD, Mac OS X (Darwin), +Cygwin/Win32 (and possibly other) systems. A native 64-bit version is available +for Linux on x86-64. + +-------------------------------------------------------------------------------- + + Alexander Burger + Software Lab. / 7fach GmbH + Bahnhofstr. 24a, D-86462 Langweid + abu@software-lab.de, http://www.software-lab.de, +49 8230 5060 diff --git a/ReleaseNotes b/ReleaseNotes @@ -0,0 +1,18 @@ +19apr10abu +(c) Software Lab. Alexander Burger + + + Release Notes for picoLisp-3.0.3 + ================================ + +A. The underlined display of transient symbols in the documentation is changed + back to double quotes, to allow an easier copy/paste of example code + fragments. + +B. The function 'not' is included in the group of flow- and logic-functions + which store non-NIL results of their conditional expressions in '@' (see the + chapter "@ Result" in "doc/ref.html"). This makes it consistent with 'nand' + and 'nor'. + +C. The line editor "lib/led.l" cycles with TAB also through path names (in + addition to internal symbols). diff --git a/app/cusu.l b/app/cusu.l @@ -0,0 +1,43 @@ +# 05nov09abu +# (c) Software Lab. Alexander Burger + +(must "Customer/Supplier" Customer) + +(menu ,"Customer/Supplier" + (ifn *ID + (prog + (<h3> NIL ,"Select" " " ,"Customer/Supplier") + (form 'dialog (choCuSu)) ) + (<h3> NIL ,"Customer/Supplier") + (form NIL + (<h2> NIL (<id> (: nr) " -- " (: nm))) + (panel T (pack ,"Customer/Supplier" " @1") '(may Delete) '(choCuSu) 'nr '+CuSu) + (<hr>) + (<tab> + (,"Name" + (<grid> 3 + ,"Number" NIL (gui '(+E/R +NumField) '(nr : home obj) 10) + ,"Salutation" + (gui '(+Hint) ,"Salutation" + '(mapcar '((This) (cons (: nm) This)) (collect 'nm '+Sal)) ) + (gui '(+Hint2 +E/R +Obj +TextField) '(sal : home obj) '(nm +Sal) 20) + ,"Name" NIL (gui '(+E/R +Cue +TextField) '(nm : home obj) ,"Name" 40) + ,"Name 2" NIL (gui '(+E/R +TextField) '(nm2 : home obj) 40) ) ) + (,"Address" + (<grid> 2 + ,"Street" (gui '(+E/R +TextField) '(str : home obj) 40) + NIL NIL + ,"Zip" (gui '(+E/R +TextField) '(plz : home obj) 10) + ,"City" (gui '(+E/R +TextField) '(ort : home obj) 40) ) ) + (,"Contact" + (<grid> 2 + ,"Phone" (gui '(+E/R +TelField) '(tel : home obj) 40) + ,"Fax" (gui '(+E/R +TelField) '(fax : home obj) 40) + ,"Mobile" (gui '(+E/R +TelField) '(mob : home obj) 40) + ,"EMail" (gui '(+E/R +MailField) '(em : home obj) 40) ) ) + ((pack (and (: obj txt) "@ ") ,"Memo") + (gui '(+BlobField) '(txt : home obj) 60 8) ) ) + (<hr>) + (<spread> NIL (editButton T)) ) ) ) + +# vi:et:ts=3:sw=3 diff --git a/app/er.l b/app/er.l @@ -0,0 +1,167 @@ +# 01dec09abu +# (c) Software Lab. Alexander Burger + +### Entity/Relations ### +# +# nr nm nr nm nm +# | | | | | +# +-*----*-+ +-*----*-+ +--*-----+ +# | | sup | | | | +# str --* CuSu O-----------------* Item *-- inv | Role @-- perm +# | | | | | | +# +-*-*--O-+ +----O---+ +----@---+ +# | | | | | usr +# nm tel -+ | | | | +# | | | | itm | role +# +-*-----+ | | +-------+ +---*---+ +----*---+ +# | | | | | | ord | | | | +# | Sal +---+ +---* Ord @--------* Pos | nm --* User *-- pw +# | | cus | | pos | | | | +# +-*---*-+ +-*---*-+ +-*---*-+ +--------+ +# | | | | | | +# hi sex nr dat pr cnt + +(extend +Role) + +(dm url> (Tab) + (and (may RoleAdmin) (list "app/role.l" '*ID This)) ) + + +(extend +User) +(rel nam (+String)) # Full Name +(rel tel (+String)) # Phone +(rel em (+String)) # EMail + +(dm url> (Tab) + (and (may UserAdmin) (list "app/user.l" '*ID This)) ) + + +# Salutation +(class +Sal +Entity) +(rel nm (+Key +String)) # Salutation +(rel hi (+String)) # Greeting +(rel sex (+Any)) # T:male, 0:female + +(dm url> (Tab) + (and (may Customer) (list "app/sal.l" '*ID This)) ) + +(dm hi> (Nm) + (or (text (: hi) Nm) ,"Dear Sir or Madam,") ) + + +# Customer/Supplier +(class +CuSu +Entity) +(rel nr (+Need +Key +Number)) # Customer/Supplier Number +(rel sal (+Link) (+Sal)) # Salutation +(rel nm (+Sn +Idx +String)) # Name +(rel nm2 (+String)) # Name 2 +(rel str (+String)) # Street +(rel plz (+Ref +String)) # Zip +(rel ort (+Fold +Idx +String)) # City +(rel tel (+Fold +Ref +String)) # Phone +(rel fax (+String)) # Fax +(rel mob (+Fold +Ref +String)) # Mobile +(rel em (+String)) # EMail +(rel txt (+Blob)) # Memo + +(dm url> (Tab) + (and (may Customer) (list "app/cusu.l" '*Tab Tab '*ID This)) ) + +(dm check> () + (make + (or (: nr) (link ,"No customer number")) + (or (: nm) (link ,"No customer name")) + (unless (and (: str) (: plz) (: ort)) + (link ,"Incomplete customer address") ) ) ) + + +# Item +(class +Item +Entity) +(rel nr (+Need +Key +Number)) # Item Number +(rel nm (+Fold +Idx +String)) # Item Description +(rel sup (+Ref +Link) NIL (+CuSu)) # Supplier +(rel inv (+Number)) # Inventory +(rel pr (+Ref +Number) NIL 2) # Price +(rel txt (+Blob)) # Memo +(rel jpg (+Blob)) # Picture + +(dm url> (Tab) + (and (may Item) (list "app/item.l" '*ID This)) ) + +(dm cnt> () + (- + (or (: inv) 0) + (sum '((This) (: cnt)) + (collect 'itm '+Pos This) ) ) ) + +(dm check> () + (make + (or (: nr) (link ,"No item number")) + (or (: nm) (link ,"No item description")) ) ) + + +# Order +(class +Ord +Entity) +(rel nr (+Need +Key +Number)) # Order Number +(rel dat (+Need +Ref +Date)) # Order date +(rel cus (+Ref +Link) NIL (+CuSu)) # Customer +(rel pos (+List +Joint) ord (+Pos)) # Positions + +(dm lose> () + (mapc 'lose> (: pos)) + (super) ) + +(dm url> (Tab) + (and (may Order) (list "app/ord.l" '*ID This)) ) + +(dm sum> () + (sum 'sum> (: pos)) ) + +(dm check> () + (make + (or (: nr) (link ,"No order number")) + (or (: dat) (link ,"No order date")) + (if (: cus) + (chain (check> @)) + (link ,"No customer") ) + (if (: pos) + (chain (mapcan 'check> @)) + (link ,"No positions") ) ) ) + + +(class +Pos +Entity) +(rel ord (+Dep +Joint) # Order + (itm) + pos (+Ord) ) +(rel itm (+Ref +Link) NIL (+Item)) # Item +(rel pr (+Number) 2) # Price +(rel cnt (+Number)) # Quantity + +(dm sum> () + (* (: pr) (: cnt)) ) + +(dm check> () + (make + (if (: itm) + (chain (check> @)) + (link ,"Position without item") ) + (or (: pr) (link ,"Position without price")) + (or (: cnt) (link ,"Position without quantity")) ) ) + + +# Database sizes +(dbs + (1 +Role +User +Sal) # (1 . 128) + (2 +CuSu) # (2 . 256) + (1 +Item +Ord) # (3 . 128) + (0 +Pos) # (4 . 64) + (2 (+Role nm) (+User nm) (+Sal nm)) # (5 . 256) + (4 (+CuSu nr plz tel mob)) # (6 . 1024) + (4 (+CuSu nm)) # (7 . 1024) + (4 (+CuSu ort)) # (8 . 1024) + (4 (+Item nr sup pr)) # (9 . 1024) + (4 (+Item nm)) # (10 . 1024) + (4 (+Ord nr dat cus)) # (11 . 1024) + (4 (+Pos itm)) ) # (12 . 1024) + +# vi:et:ts=3:sw=3 diff --git a/app/gui.l b/app/gui.l @@ -0,0 +1,243 @@ +# 20apr10abu +# (c) Software Lab. Alexander Burger + +### GUI ### +(de menu (Ttl . Prg) + (action + (html 0 Ttl *Css NIL + (<div> '(id . menu) + (expires) + (<menu> + (,"Home" "@start") + (,"logout" (and *Login "@stop")) + (NIL (<hr>)) + (T ,"Data" + (,"Orders" (and (may Order) "app/ord.l")) + (,"Items" (and (may Item) "app/item.l")) + (,"Customers/Suppliers" (and (may Customer) "app/cusu.l")) + (,"Salutations" (and (may Customer) "app/sal.l")) ) + (T ,"Report" + (,"Inventory" (and (may Report) "app/inventory.l")) + (,"Sales" (and (may Report) "app/sales.l")) ) + (T ,"System" + (,"Role Administration" (and (may RoleAdmin) "app/role.l")) + (,"User Administration" (and (may UserAdmin) "app/user.l")) ) ) ) + (<div> '(id . main) (run Prg 1)) ) ) ) + +(de start () + (setq *Url "@start") + (and (app) (setq *Menu 3)) + (menu "PicoLisp App" + (<h2> NIL "PicoLisp App") + (<img> "img/7fach.gif" "7fach Logo") + (----) + (form NIL + (gui '(+Init +Map +TextField) + (cons *Ctry *Lang) + *Locales + (mapcar car *Locales) + ',"Language" ) + (gui '(+Button) ',"Change" + '(let V (val> (field -1)) + (locale (car V) (cdr V) "app/loc/") ) ) ) + (form NIL + (<grid> 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 (logout)) + ((login (val> (: home nm)) (val> (: home pw))) + (clr> (: home pw)) ) + (T (err ,"Permission denied")) ) ) + (when *Login + (<nbsp> 4) + (<span> "bold green" + (<big> (ht:Prin "'" (; *Login nm) ,"' logged in")) ) ) ) ) ) + +(de stop () + (logout) + (start) ) + +# Search dialogs +(de choCuSu (Dst) + (diaform '(Dst) + (<grid> "--.-.-." + ,"Number" (gui 'nr '(+Var +NumField) '*CuSuNr 10) + ,"Name" (gui 'nm '(+Focus +Var +TextField) '*CuSuNm 30) + ,"Phone" (gui 'tel '(+Var +TelField) '*CuSuTel 20) + (searchButton '(init> (: home query))) + ,"Zip" (gui 'plz '(+Var +TextField) '*CuSuPlz 10) + ,"City" (gui 'ort '(+Var +TextField) '*CuSuOrt 30) + ,"Mobile" (gui 'mob '(+Var +TelField) '*CuSuMob 20) + (resetButton '(nr nm tel plz ort mob query)) ) + (gui 'query '(+QueryChart) (cho) + '(goal + (quote + @Nr (and *CuSuNr (cons @ T)) + @Nm *CuSuNm + @Tel *CuSuTel + @Plz *CuSuPlz + @Ort *CuSuOrt + @Mob *CuSuMob + (select (@@) + ((nr +CuSu @Nr) (nm +CuSu @Nm) (tel +CuSu @Tel) + (plz +CuSu @Plz) (ort +CuSu @Ort) (mob +CuSu @Mob) ) + (range @Nr @@ nr) + (tolr @Nm @@ nm) + (fold @Tel @@ tel) + (head @Plz @@ plz) + (part @Ort @@ ort) + (fold @Mob @@ mob) ) ) ) + 9 + '((This) (list This (: nr) This (: nm2) (: em) (: plz) (: ort) (: tel) (: mob))) ) + (<table> 'chart (choTtl ,"Customers/Suppliers" 'nr '+CuSu) + (quote + (btn) + (align "#") + (NIL ,"Name") + (NIL) + (NIL ,"EMail") + (NIL ,"Zip") + (NIL ,"City") + (NIL ,"Phone") + (NIL ,"Mobile") ) + (do (cho) + (<row> (alternating) + (gui 1 '(+DstButton) Dst) + (gui 2 '(+NumField)) + (gui 3 '(+ObjView +TextField) '(: nm)) + (gui 4 '(+TextField)) + (gui 5 '(+MailField)) + (gui 6 '(+TextField)) + (gui 7 '(+TextField)) + (gui 8 '(+TelField)) + (gui 9 '(+TelField)) ) ) ) + (<spread> + (scroll (cho)) + (newButton T Dst '(+CuSu) + '(nr genKey 'nr '+CuSu) + 'nm *CuSuNm + 'plz *CuSuPlz + 'ort *CuSuOrt + 'tel *CuSuTel + 'mob *CuSuMob ) + (cancelButton) ) ) ) + +(de choItem (Dst) + (diaform '(Dst) + (<grid> "--.-." + ,"Number" (gui 'nr '(+Focus +Var +NumField) '*ItemNr 10) + ,"Supplier" (gui 'sup '(+Var +TextField) '*ItemSup 20) + (searchButton '(init> (: home query))) + ,"Description" (gui 'nm '(+Var +TextField) '*ItemNm 30) + ,"Price" (gui 'pr '(+Var +FixField) '*ItemPr 2 12) + (resetButton '(nr nm pr sup query)) ) + (gui 'query '(+QueryChart) (cho) + '(goal + (quote + @Nr (and *ItemNr (cons @ T)) + @Nm *ItemNm + @Pr (and *ItemPr (cons @ T)) + @Sup *ItemSup + (select (@@) + ((nr +Item @Nr) (nm +Item @Nm) (pr +Item @Pr) (nm +CuSu @Sup (sup +Item))) + (range @Nr @@ nr) + (part @Nm @@ nm) + (range @Pr @@ pr) + (tolr @Sup @@ sup nm) ) ) ) + 6 + '((This) (list This (: nr) This (: sup) (: sup ort) (: pr))) ) + (<table> 'chart (choTtl ,"Items" 'nr '+Item) + (quote + (btn) + (align "#") + (NIL ,"Description") + (NIL ,"Supplier") + (NIL ,"City") + (align ,"Price") ) + (do (cho) + (<row> (alternating) + (gui 1 '(+DstButton) Dst) + (gui 2 '(+NumField)) + (gui 3 '(+ObjView +TextField) '(: nm)) + (gui 4 '(+ObjView +TextField) '(: nm)) + (gui 5 '(+TextField)) + (gui 6 '(+FixField) 2) ) ) ) + (<spread> + (scroll (cho)) + (newButton T Dst '(+Item) + '(nr genKey 'nr '+Item) + 'nm *ItemNm + 'pr *ItemPr ) + (cancelButton) ) ) ) + +(de choOrd (Dst) + (diaform '(Dst) + (<grid> "--.-.-." + ,"Number" (gui 'nr '(+Focus +Var +NumField) '*OrdNr 10) + ,"Customer" (gui 'cus '(+Var +TextField) '*OrdCus 20) + ,"City" (gui 'ort '(+Var +TextField) '*OrdOrt 20) + (searchButton '(init> (: home query))) + ,"Date" (gui 'dat '(+Var +DateField) '*OrdDat 10) + ,"Supplier" (gui 'sup '(+Var +TextField) '*OrdSup 20) + ,"Item" (gui 'item '(+Var +TextField) '*OrdItem 20) + (resetButton '(nr cus ort dat sup item query)) ) + (gui 'query '(+QueryChart) (cho) + '(goal + (quote + @Nr (cons (or *OrdNr T)) + @Dat (cons (or *OrdDat T)) + @Cus *OrdCus + @Ort *OrdOrt + @Sup *OrdSup + @Item *OrdItem + (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) ) + (range @Nr @@ nr) + (range @Dat @@ dat) + (tolr @Cus @@ cus nm) + (part @Ort @@ cus ort) + (part @Item @@ pos itm nm) + (tolr @Sup @@ pos itm sup nm) ) ) ) + 9 + '((This) + (list This (: nr) This + (: cus) (: cus ort) + (: pos 1 itm sup) (: pos 1 itm) + (: pos 2 itm sup) (: pos 2 itm) ) ) ) + (<table> 'chart (choTtl ,"Orders" 'nr '+Ord) + (quote + (btn) + (align "#") + (NIL ,"Date") + (NIL ,"Customer") + (NIL ,"City") + (NIL ,"Supplier" "(1)") + (NIL ,"Item" "(1)") + (NIL ,"Supplier" "(2)") + (NIL ,"Item" "(2)") ) + (do (cho) + (<row> (alternating) + (gui 1 '(+DstButton) Dst) + (gui 2 '(+NumField)) + (gui 3 '(+ObjView +DateField) '(: dat)) + (gui 4 '(+ObjView +TextField) '(: nm)) + (gui 5 '(+TextField)) + (gui 6 '(+ObjView +TextField) '(: nm)) + (gui 7 '(+ObjView +TextField) '(: nm)) + (gui 8 '(+ObjView +TextField) '(: nm)) + (gui 9 '(+ObjView +TextField) '(: nm)) ) ) ) + (<spread> + (scroll (cho)) + (newButton T Dst '(+Ord) + '(nr genKey 'nr '+Ord) + 'dat (date) ) + (cancelButton) ) ) ) + +# vi:et:ts=3:sw=3 diff --git a/app/init.l b/app/init.l @@ -0,0 +1,81 @@ +# 14jan10abu +# (c) Software Lab. Alexander Burger + +### Role ### +(obj ((+Role) nm "Administration") perm `*Perms) +(obj ((+Role) nm "Accounting") perm (Customer Item Order Report Delete)) +(obj ((+Role) nm "Assistance") perm (Order)) +(commit) + +### User ### +(obj ((+User) nm "admin") pw "admin" nam "Administrator" role `(db 'nm '+Role "Administration")) +(obj ((+User) nm "ben") pw "ben" nam "Ben Affleck" role `(db 'nm '+Role "Accounting")) +(obj ((+User) nm "jodie") pw "jodie" nam "Jodie Foster" role `(db 'nm '+Role "Accounting")) +(obj ((+User) nm "sandy") pw "sandy" nam "Sandra Bullock" role `(db 'nm '+Role "Accounting")) +(obj ((+User) nm "depp") pw "depp" nam "Johnny Depp" role `(db 'nm '+Role "Assistance")) +(obj ((+User) nm "tom") pw "tom" nam "Tom Hanks" role `(db 'nm '+Role "Assistance")) +(commit) + +(obj ((+Sal) nm "Department") hi "Dear Sir or Madam,") +(obj ((+Sal) nm "Mr.") hi "Dear Mr. @1," sex T) +(obj ((+Sal) nm "Mrs.") hi "Dear Mrs. @1," sex 0) +(obj ((+Sal) nm "Ms.") hi "Dear Ms. @1," sex 0) +(obj ((+Sal) nm "Mme") hi "Bonjour Mme @1," sex 0) +(obj ((+Sal) nm "Herr") hi "Sehr geehrter Herr @1," sex T) +(obj ((+Sal) nm "Herr Dr.") hi "Sehr geehrter Herr Dr. @1," sex T) +(obj ((+Sal) nm "Frau") hi "Sehr geehrte Frau @1," sex 0) +(obj ((+Sal) nm "Frau Dr.") hi "Sehr geehrte Frau Dr. @1," sex 0) +(obj ((+Sal) nm "Señor") hi "Estimado Señor @1," sex T) +(obj ((+Sal) nm "Señora") hi "Estimada Señora @1," sex 0) +(commit) + +### Customer/Supplier ### +(obj ((+CuSu) nr 1) + nm "Active Parts Inc." + nm2 "East Division" + str "Wildcat Lane" + plz "3425" + ort "Freetown" + tel "37 4967 6846-0" + fax "37 4967 68462" + mob "37 176 86303" + em "info@api.tld" ) +(obj ((+CuSu) nr 2) + nm "Seven Oaks Ltd." + str "Sunny Side Heights 202" + plz "1795" + ort "Winterburg" + tel "37 6295 5855-0" + fax "37 6295 58557" + em "info@7oaks.tld" ) +(obj ((+CuSu) nr 3) + sal `(db 'nm '+Sal "Mr.") + nm "Miller" + nm2 "Thomas Edwin" + str "Running Lane 17" + plz "1208" + ort "Kaufstadt" + tel "37 4773 82534" + mob "37 129 276877" + em "tem@shoppers.tld" ) +(commit) + +### Item ### +(obj ((+Item) nr 1) nm "Main Part" sup `(db 'nr '+CuSu 1) inv 100 pr 29900) +(obj ((+Item) nr 2) nm "Spare Part" sup `(db 'nr '+CuSu 2) inv 100 pr 1250) +(obj ((+Item) nr 3) nm "Auxiliary Construction" sup `(db 'nr '+CuSu 1) inv 100 pr 15700) +(obj ((+Item) nr 4) nm "Enhancement Additive" sup `(db 'nr '+CuSu 2) inv 100 pr 999) +(obj ((+Item) nr 5) nm "Metal Fittings" sup `(db 'nr '+CuSu 1) inv 100 pr 7980) +(obj ((+Item) nr 6) nm "Gadget Appliance" sup `(db 'nr '+CuSu 2) inv 100 pr 12500) +(commit) + +### Order ### +(let Ord (new (db: +Ord) '(+Ord) 'nr 1 'dat (date 2007 2 14) 'cus (db 'nr '+CuSu 3)) + (put> Ord 'pos + (list + (new (db: +Pos) '(+Pos) 'itm (db 'nr '+Item 1) 'pr 29900 'cnt 1) + (new (db: +Pos) '(+Pos) 'itm (db 'nr '+Item 2) 'pr 1250 'cnt 8) + (new (db: +Pos) '(+Pos) 'itm (db 'nr '+Item 4) 'pr 999 'cnt 20) ) ) ) +(commit) + +# vi:et:ts=3:sw=3 diff --git a/app/inventory.l b/app/inventory.l @@ -0,0 +1,55 @@ +# 08mar10abu +# (c) Software Lab. Alexander Burger + +(must "Inventory" Report) + +(menu ,"Inventory" + (<h3> NIL ,"Inventory") + (form NIL + (<grid> "-.-" + ,"Number" NIL + (prog + (gui '(+Var +NumField) '*InvFrom 10) + (prin " - ") + (gui '(+Var +NumField) '*InvTill 10) ) + ,"Description" NIL (gui '(+Var +TextField) '*InvNm 30) + ,"Supplier" (gui '(+ChoButton) '(choCuSu (field 1))) + (gui '(+Var +Obj +TextField) '*InvSup '(nm +CuSu) 30) ) + (--) + (gui '(+ShowButton) NIL + '(csv ,"Inventory" + (<table> 'chart NIL + (<!> + (quote + (align) + (NIL ,"Description") + (align ,"Inventory") + (NIL ,"Supplier") + NIL + (NIL ,"Zip") + (NIL ,"City") + (align ,"Price") ) ) + (catch NIL + (pilog + (quote + @Rng (cons *InvFrom (or *InvTill T)) + @Nm *InvNm + @Sup *InvSup + (select (@Item) + ((nr +Item @Rng) (nm +Item @Nm) (sup +Item @Sup)) + (range @Rng @Item nr) + (tolr @Nm @Item nm) + (same @Sup @Item sup) ) ) + (with @Item + (<row> (alternating) + (<+> (: nr) This) + (<+> (: nm) This) + (<+> (cnt> This)) + (<+> (: sup nm) (: sup)) + (<+> (: sup nm2)) + (<+> (: sup plz)) + (<+> (: sup ort)) + (<-> (money (: pr))) ) ) + (at (0 . 10000) (or (flush) (throw))) ) ) ) ) ) ) ) + +# vi:et:ts=3:sw=3 diff --git a/app/item.l b/app/item.l @@ -0,0 +1,40 @@ +# 03jan09abu +# (c) Software Lab. Alexander Burger + +(must "Item" Item) + +(menu ,"Item" + (ifn *ID + (prog + (<h3> NIL ,"Select" " " ,"Item") + (form 'dialog (choItem)) ) + (<h3> NIL ,"Item") + (form NIL + (<h2> NIL (<id> (: nr) " -- " (: nm))) + (panel T (pack ,"Item" " @1") '(may Delete) '(choItem) 'nr '+Item) + (<grid> 4 + ,"Number" NIL (gui '(+E/R +NumField) '(nr : home obj) 10) NIL + ,"Description" NIL (gui '(+E/R +Cue +TextField) '(nm : home obj) ,"Item" 30) NIL + ,"Supplier" (gui '(+ChoButton) '(choCuSu (field 1))) + (gui '(+E/R +Obj +TextField) '(sup : home obj) '(nm +CuSu) 30) + (gui '(+View +TextField) '(field -1 'obj 'ort) 30) + ,"Inventory" NIL (gui '(+E/R +NumField) '(inv : home obj) 12) + (gui '(+View +NumField) '(cnt> (: home obj)) 12) + ,"Price" NIL (gui '(+E/R +FixField) '(pr : home obj) 2 12) ) + (--) + (<grid> 2 + ,"Memo" (gui '(+BlobField) '(txt : home obj) 60 8) + ,"Picture" + (prog + (gui '(+Able +UpField) '(not (: home obj jpg)) 30) + (gui '(+Button) '(if (: home obj jpg) ,"Uninstall" ,"Install") + '(if (: home obj jpg) + (ask ,"Uninstall Picture?" + (put!> (: home top 1 obj) 'jpg NIL) ) + (let? F (val> (field -1)) + (blob! (: home obj) 'jpg (tmp F)) ) ) ) ) ) + (<spread> NIL (editButton T)) + (when (: obj jpg) + (<img> (allow (blob (: obj) 'jpg)) ,"Picture") ) ) ) ) + +# vi:et:ts=3:sw=3 diff --git a/app/lib.l b/app/lib.l @@ -0,0 +1,62 @@ +# 22jan08abu +# (c) Software Lab. Alexander Burger + +### PDF-Print ### +(dm (ps> . +Ord) () + (a4) + (font (12 . "Helvetica")) + (eps "img/7fach.eps" 340 150 75) + (window 380 120 120 30 + (font (21 . "Times-Roman") (ps ,"Order" 0)) ) + (brief NIL 8 "7fach GmbH, Bawaria" + (ps) + (with (: cus) + (ps + (pack + (and (: sal) (pack (: sal nm) " ")) + (: nm2) " " (: nm) ) ) + (ps (: str)) + (ps (pack (: plz) " " (: ort))) ) ) + (window 360 280 240 60 + (let Fmt (80 12 60) + (table Fmt ,"Customer" ":" (ps (: cus nr))) + (table Fmt ,"Order" ":" (ps (: nr))) + (table Fmt ,"Date" ":" (ps (datStr (: dat)))) ) ) + (down 360) + (indent 60 60) + (let (Page 1 Fmt (14 6 200 80 80 80)) + (width "0.5" + (hline 0 470 -8) + (font "Helvetica-Bold" + (table Fmt NIL NIL + (ps ,"Item") + (ps ,"Price" T) + (ps ,"Quantity" T) + (ps ,"Total" T) ) ) + (hline 4 470 -8) + (pages 720 + (hline 0 470 -8) + (down 12) + (font 9 (ps (text ,"Continued on page @1" (inc 'Page)))) + (page T) + (eps "img/7fach.eps" 340 150 75) + (down 40) + (font 9 (ps (text ,"Page @1" Page))) + (down 80) + (hline 0 470 -8) ) + (for (I . This) (: pos) + (down 4) + (table Fmt + (ps I T) NIL + (ps (: itm nm)) + (ps (money (: pr)) T) + (ps (: cnt) T) + (ps (money (sum> This)) T) ) ) + (pages) + (hline 4 470 -8) + (down 4) + (table Fmt NIL NIL NIL NIL NIL (ps (money (sum> This)) T)) + (hline 4 470 -8) ) ) + (page) ) + +# vi:et:ts=3:sw=3 diff --git a/app/loc/ar b/app/loc/ar @@ -0,0 +1,5 @@ +# 26aug09art +# Armadillo <tc.rucho@gmail.com> + +T "@app/loc/es" +"Mobile" "Celular" diff --git a/app/loc/ch b/app/loc/ch @@ -0,0 +1,4 @@ +# 10may08abu +# (c) Software Lab. Alexander Burger + +T "app/loc/de" diff --git a/app/loc/de b/app/loc/de @@ -0,0 +1,86 @@ +# 09may08abu +# (c) Software Lab. Alexander Burger + +"(@1 Positions)" "(@1 Positionen)" + +"Address" "Adresse" + +"Can't print order" "Beleg kann nicht gedruckt werden" +"Change" "Ändern" +"City" "Ort" +"Contact" "Kontakt" +"Continued on page @1" "Fortsetzung auf Seite @1" +"Country" "Land" +"Customer" "Kunde" +"Customer/Supplier" "Kunde/Lieferant" +"Customers/Suppliers" "Kunden/Lieferanten" + +"Data" "Daten" +"Date" "Datum" +"Dear Sir or Madam," "Sehr geehrte Damen und Herren," +"Description" "Bezeichnung" + +"eMail" "eMail" + +"Fax" "Fax" +"Full Name" "Vollständiger Name" + +"Greeting" "Gruß" + +"Home" "Startseite" + +"Incomplete customer address" "Unvollständige Kundenadresse" +"Install" "Installieren" +"Inventory" "Lagerbestand" +"Item" "Artikel" +"Items" "Artikel" + +"Login Name" "Login-Name" + +"Memo" "Memo" +"Mobile" "Mobil" + +"Name" "Name" +"Name 2" "Name 2" +"No customer" "Kunde fehlt" +"No customer name" "Kundenname fehlt" +"No customer number" "Kundennummer fehlt" +"No item description" "Artikelbezeichnung fehlt" +"No item number" "Artikelnummer fehlt" +"No order date" "Belegdatum fehlt" +"No order number" "Belegnummer fehlt" +"No positions" "Keine Positionen" +"Number" "Nummer" + +"Order" "Bestellung" +"Orders" "Bestellungen" + +"Page @1" "Seite @1" +"PDF-Print" "PDF-Druck" +"Phone" "Telefon" +"Picture" "Bild" +"Position without item" "Position ohne Artikel" +"Position without price" "Position ohne Preis" +"Position without quantity" "Position ohne Menge" +"Price" "Preis" + +"Quantity" "Menge" + +"Report" "Auswertung" +"Role Administration" "Rollenverwaltung" + +"Sales" "Verkauf" +"Salutation" "Anrede" +"Salutations" "Anreden" +"Sex" "Geschlecht" +"Street" "Straße" +"Supplier" "Lieferant" +"System" "System" + +"Total" "Gesamt" + +"Uninstall" "De-installieren" +"Uninstall Picture?" "Bild de-installieren?" +"User Administration" "Benutzerverwaltung" + +"Zip" "PLZ" diff --git a/app/loc/es b/app/loc/es @@ -0,0 +1,86 @@ +# 20aug09art +# Armadillo <tc.rucho@gmail.com> + +"(@1 Positions)" "(@1 Posiciones)" + +"Address" "Dirección" + +"Can't print order" "No se puede imprimir la órden" +"Change" "Cambiar" +"City" "Ciudad" +"Contact" "Contacto" +"Continued on page @1" "Continuado en la página @1" +"Country" "País" +"Customer" "Cliente" +"Customer/Supplier" "Cliente/Proveedor" +"Customers/Suppliers" "Clientes/Proveedores" + +"Data" "Datos" +"Date" "Fecha" +"Dear Sir or Madam," "Estimado/a Sr/a," +"Description" "Descripción" + +"eMail" "eMail" + +"Fax" "Fax" +"Full Name" "Nombre Completo" + +"Greeting" "Saludos" + +"Home" "Inicio" + +"Incomplete customer address" "Dirección del cliente incompleta" +"Install" "Instalar" +"Inventory" "Inventario" +"Item" "Artículo" +"Items" "Artículos" + +"Login Name" "Nombre de usuario" + +"Memo" "Memo" +"Mobile" "Móbil" + +"Name" "Nombre" +"Name 2" "Segundo nombre" +"No customer" "No cliente" +"No customer name" "Nombre de cliente indefinido" +"No customer number" "Número de cliente indefinido" +"No item description" "Descripción de artículo indefinida" +"No item number" "Número de artículo no definido" +"No order date" "Fecha de órden, indefinida" +"No order number" "Número de órden indefinido" +"No positions" "Posiciones indefinidas" +"Number" "Número" + +"Order" "Orden" +"Orders" "Órdenes" + +"Page @1" "Página @1" +"PDF-Print" "Imprimir-PDF" +"Phone" "Teléfono" +"Picture" "Foto" +"Position without item" "Posición sin artículo" +"Position without price" "Posición sin precio" +"Position without quantity" "Posición sin cantidad" +"Price" "Precio" + +"Quantity" "Cantidad" + +"Report" "Reporte" +"Role Administration" "Administración de roles" + +"Sales" "Ventas" +"Salutation" "Saludo" +"Salutations" "Saludos" +"Sex" "Género" +"Street" "Calle" +"Supplier" "Proveedor" +"System" "Sistema" + +"Total" "Total" + +"Uninstall" "Desinstalar" +"Uninstall Picture?" "Desinstalar foto?" +"User Administration" "Administración de usuarios" + +"Zip" "Código Postal" diff --git a/app/loc/jp b/app/loc/jp @@ -0,0 +1,86 @@ +# 09may08abu +# (c) Software Lab. Alexander Burger + +"(@1 Positions)" "(ポジション数:@1)" + +"Address" "住所" + +"Can't print order" "注文書の印刷ができない" +"Change" "変換" +"City" "都市" +"Contact" "問い合わせ" +"Continued on page @1" "@1ページに続く" +"Country" "国" +"Customer" "カスタマー" +"Customer/Supplier" "カスタマー/注文先" +"Customers/Suppliers" "カスタマー/注文先" + +"Data" "データ" +"Date" "日付" +"Dear Sir or Madam," "拝啓," +"Description" "仕様" + +"eMail" "eメール" + +"Fax" "Fax" +"Full Name" "フルネーム" + +"Greeting" "手紙の書きだし" + +"Home" "ホーム" + +"Incomplete customer address" "カスタマーの住所不十分" +"Install" "インストール" +"Inventory" "在庫目録" +"Item" "商品" +"Items" "商品" + +"Login Name" "ログイン名" + +"Memo" "メモ" +"Mobile" "携帯電話" + +"Name" "名前" +"Name 2" "名前 2" +"No customer" "カスタマーなし" +"No customer name" "カスタマー名なし" +"No customer number" "カスタマー番号なし" +"No item description" "商品仕様なし" +"No item number" "商品番号なし" +"No order date" "注文書日付なし" +"No order number" "注文番号なし" +"No positions" "ポジションなし" +"Number" "番号" + +"Order" "注文" +"Orders" "注文" + +"Page @1" "@1 ページ" +"PDF-Print" "PDF印刷" +"Phone" "電話番号" +"Picture" "写真" +"Position without item" "ポジションに商品がない" +"Position without price" "ポジションに価格がない" +"Position without quantity" "ポジションに数量がない" +"Price" "価格" + +"Quantity" "数量" + +"Report" "レポート" +"Role Administration" "役割管理" + +"Sales" "セールス" +"Salutation" "敬称" +"Salutations" "敬称" +"Sex" "性別" +"Street" "住所" +"Supplier" "注文先" +"System" "システム" + +"Total" "総計" + +"Uninstall" "アンインストール" +"Uninstall Picture?" "写真をアンインストールしますか?" +"User Administration" "ユーザー管理" + +"Zip" "郵便番号" diff --git a/app/loc/no b/app/loc/no @@ -0,0 +1,86 @@ +# 14jan10jk +# Jon Kleiser, jon.kleiser@usit.uio.no + +"(@1 Positions)" "(@1 Posisjoner)" + +"Address" "Adresse" + +"Can't print order" "Kan ikke skrive ut bestilling" +"Change" "Endre" +"City" "By" +"Contact" "Kontakt" +"Continued on page @1" "Fortsettes på side @1" +"Country" "Land" +"Customer" "Kunde" +"Customer/Supplier" "Kunde/Leverandør" +"Customers/Suppliers" "Kunder/Leverandører" + +"Data" "Data" +"Date" "Dato" +"Dear Sir or Madam," "Kjære frue/herre," +"Description" "Beskrivelse" + +"eMail" "e-post" + +"Fax" "Fax" +"Full Name" "Fullt navn" + +"Greeting" "Hilsen" + +"Home" "Startside" + +"Incomplete customer address" "Ufullstendig kundeadresse" +"Install" "Installer" +"Inventory" "Lagerbeholdning" +"Item" "Artikkel" +"Items" "Artikler" + +"Login Name" "Innloggingsnavn" + +"Memo" "Merknad" +"Mobile" "Mobil" + +"Name" "Navn" +"Name 2" "Navn 2" +"No customer" "Kunde mangler" +"No customer name" "Kundenavn mangler" +"No customer number" "Kundenummer mangler" +"No item description" "Artikkelbeskrivelse mangler" +"No item number" "Artikkelnummer mangler" +"No order date" "Bestillingsdato mangler" +"No order number" "Bestillingsnummer mangler" +"No positions" "Ingen posisjoner" +"Number" "Nummer" + +"Order" "Bestilling" +"Orders" "Bestillinger" + +"Page @1" "Side @1" +"PDF-Print" "PDF-utskrift" +"Phone" "Telefon" +"Picture" "Bilde" +"Position without item" "Posisjon uten artikkel" +"Position without price" "Posisjon uten pris" +"Position without quantity" "Posisjon uten antall" +"Price" "Pris" + +"Quantity" "Antall" + +"Report" "Rapport" +"Role Administration" "Rolle-administrasjon" + +"Sales" "Salg" +"Salutation" "Titulering" +"Salutations" "Tituleringer" +"Sex" "Kjønn" +"Street" "Gate" +"Supplier" "Leverandør" +"System" "System" + +"Total" "Total" + +"Uninstall" "Av-installer" +"Uninstall Picture?" "Av-installere bilde?" +"User Administration" "Bruker-administrasjon" + +"Zip" "Postnr." diff --git a/app/loc/ru b/app/loc/ru @@ -0,0 +1,86 @@ +# 25apr08 +# Mansur Mamkin <mmamkin@mail.ru> + +"(@1 Positions)" "(@1 позиций)" + +"Address" "Адрес" + +"Can't print order" "Невозможно напечатать заказ" +"Change" "Изменить" +"City" "Город" +"Contact" "Контакт" +"Continued on page @1" "Продолжение на странице @1" +"Country" "Страна" +"Customer" "Покупатель" +"Customer/Supplier" "Покупатель/Поставщик" +"Customers/Suppliers" "Покупатели/Поставщики" + +"Data" "Данные" +"Date" "Дата" +"Dear Sir or Madam," "Уважаемый(ая)" +"Description" "Описание" + +"eMail" "емейл" + +"Fax" "Факс" +"Full Name" "Полное имя" + +"Greeting" "Приветствие" + +"Home" "Домой" + +"Incomplete customer address" "Неполный адрес покупателя" +"Install" "Установить" +"Inventory" "Инвентаризация" +"Item" "Товар" +"Items" "Товары" + +"Login Name" "Имя регистрации" + +"Memo" "Мемо" +"Mobile" "Мобильный" + +"Name" "Имя" +"Name 2" "Имя 2" +"No customer" "Нет покупателя" +"No customer name" "Нет имени покупателя" +"No customer number" "Нет номера покупателя" +"No item description" "Нет описания товара" +"No item number" "Нет номера товара" +"No order date" "Нет даты заказа" +"No order number" "Нет номера заказа" +"No positions" "Нет позиций" +"Number" "Номер" + +"Order" "Заказ" +"Orders" "Заказы" + +"Page @1" "Страница @1" +"PDF-Print" "Печать PDF" +"Phone" "Телефон" +"Picture" "Картинка" +"Position without item" "Позиция без товара" +"Position without price" "Позиция без цены" +"Position without quantity" "Позиция без количества" +"Price" "Цена" + +"Quantity" "Количество" + +"Report" "Отчет" +"Role Administration" "Управление ролями" + +"Sales" "Продажи" +"Salutation" "Приветствие" +"Salutations" "Приветствия" +"Sex" "Пол" +"Street" "Улица" +"Supplier" "Поставщик" +"System" "Система" + +"Total" "Всего" + +"Uninstall" "Удалить" +"Uninstall Picture?" "Удалить картинку?" +"User Administration" "Управление пользователями" + +"Zip" "Индекс" diff --git a/app/main.l b/app/main.l @@ -0,0 +1,61 @@ +# 14jan10abu +# (c) Software Lab. Alexander Burger + +(allowed ("app/" "img/") + "@start" "@stop" "favicon.ico" "lib.css" "@psh" ) + +(load "lib/http.l" "lib/xhtml.l" "lib/form.l" "lib/ps.l" "lib/adm.l") + +(setq + *Scl 2 + *Css "lib.css" + *Blob "blob/app/" ) + +(load "app/er.l" "app/lib.l" "app/gui.l") + +(permission + Customer ,"Customer" + Item ,"Item" + Order ,"Order" + Report ,"Report" + RoleAdmin ,"Role Administration" + UserAdmin ,"User Administration" + Password ,"Password" + Delete ,"Delete" ) + +(de *Locales + ("English" NIL) + ("English (US)" "US") + ("English (UK)" "UK") + ("Español (AR)" "AR" . "ar") + ("Español (ES)" "ES" . "es") + ("Deutsch (DE)" "DE" . "de") + ("Deutsch (CH)" "CH" . "ch") + ("Norsk" "NO" . "no") + ("Русский" "RU" . "ru") + ("日本語" "JP" . "jp") ) + +# Entry point +(de main () + (call 'mkdir "-p" "db/app/" *Blob) + (pool "db/app/" *Dbs) + (unless (seq *DB) + (load "app/init.l") ) ) + +(de go () + (pw 12) + (task (port 4040) # Set up query server in the background + (let? Sock (accept @) + (unless (fork) # Child process + (in Sock + (while (rd) + (sync) + (out Sock + (pr (eval @)) ) ) ) + (bye) ) + (close Sock) ) ) + (forked) + (rollback) + (server 8080 "@start") ) + +# vi:et:ts=3:sw=3 diff --git a/app/ord.l b/app/ord.l @@ -0,0 +1,58 @@ +# 03sep09abu +# (c) Software Lab. Alexander Burger + +(must "Order" Order) + +(menu ,"Order" + (ifn *ID + (prog + (<h3> NIL ,"Select" " " ,"Order") + (form 'dialog (choOrd)) ) + (<h3> NIL ,"Order") + (form NIL + (<h2> NIL (<id> (: nr))) + (panel T (pack ,"Order" " @1") '(may Delete) '(choOrd) 'nr '+Ord) + (<grid> 4 + ,"Date" NIL + (gui '(+E/R +DateField) '(dat : home obj) 10) + (gui '(+View +TextField) + '(text ,"(@1 Positions)" (length (: home obj pos))) ) + ,"Customer" (gui '(+ChoButton) '(choCuSu (field 1))) + (gui '(+E/R +Obj +TextField) '(cus : home obj) '(nm +CuSu) 30) + (gui '(+View +TextField) '(field -1 'obj 'ort) 30) ) + (--) + (gui '(+Set +E/R +Chart) '((L) (filter bool L)) '(pos : home obj) 8 + '((Pos I) + (with Pos + (list I NIL (: itm) (or (: pr) (: itm pr)) (: cnt) (sum> Pos)) ) ) + '((L D) + (cond + (D + (put!> D 'itm (caddr L)) + (put!> D 'pr (cadddr L)) + (put!> D 'cnt (; L 5)) + (and (; D itm) D) ) + ((caddr L) + (new! '(+Pos) 'itm (caddr L)) ) ) ) ) + (<table> NIL NIL + '((align) (btn) (NIL ,"Item") (NIL ,"Price") (NIL ,"Quantity") (NIL ,"Total")) + (do 8 + (<row> NIL + (gui 1 '(+NumField)) + (gui 2 '(+ChoButton) '(choItem (field 1))) + (gui 3 '(+Obj +TextField) '(nm +Item) 30) + (gui 4 '(+FixField) 2 12) + (gui 5 '(+NumField) 8) + (gui 6 '(+Sgn +Lock +FixField) 2 12) + (gui 7 '(+DelRowButton)) + (gui 8 '(+BubbleButton)) ) ) + (<row> NIL NIL NIL (scroll 8 T) NIL NIL + (gui '(+Sgn +View +FixField) '(sum> (: home obj)) 2 12) ) ) + (<spread> + (gui '(+Rid +Button) ,"PDF-Print" + '(if (check> (: home obj)) + (note ,"Can't print order" (uniq @)) + (psOut 0 ,"Order" (ps> (: home obj))) ) ) + (editButton T) ) ) ) ) + +# vi:et:ts=3:sw=3 diff --git a/app/role.l b/app/role.l @@ -0,0 +1,33 @@ +# 22apr10abu +# (c) Software Lab. Alexander Burger + +(must "Role Administration" RoleAdmin) + +(menu ,"Role Administration" + (ifn *ID + (prog + (<h3> NIL ,"Select" " " ,"Role") + (form 'dialog (choDlg NIL ,"Roles" '(nm +Role))) ) + (<h3> NIL ,"Role Administration") + (form NIL + (<h2> NIL (<id> (: nm))) + (panel T (pack ,"Role" " '@1'") '(may Delete) '(choDlg NIL ,"Roles" '(nm +Role)) 'nm '+Role) + (gui '(+E/R +Cue +TextField) '(nm : home obj) ,"Role" 30 ,"Name") + (<table> NIL NIL NIL + (gui '(+E/R +Fmt +Chart) + '(perm : home obj) + '((Val) (mapcar '((S) (list S (memq S Val))) *Perms)) + '((Lst) (extract '((L P) (and (cadr L) P)) Lst *Perms)) + 2 ) + (do (length *Perms) + (<row> NIL + (gui 1 '(+Set +TextField) '((Sym) (val (val Sym)))) + (gui 2 '(+Checkbox)) ) ) ) + (gui '(+/R +Chart) '(usr : home obj) 1 list) + (<table> 'chart ,"User" NIL + (do 8 + (<row> (alternating) + (gui 1 '(+Obj +TextField) '(nm +User)) ) ) ) + (<spread> (scroll 8 T) (editButton T)) ) ) ) + +# vi:et:ts=3:sw=3 diff --git a/app/sal.l b/app/sal.l @@ -0,0 +1,21 @@ +# 03jan09abu +# (c) Software Lab. Alexander Burger + +(must "Salutation" Customer) + +(menu ,"Salutation" + (ifn *ID + (prog + (<h3> NIL ,"Select" " " ,"Salutation") + (form 'dialog (choDlg NIL ,"Salutations" '(nm +Sal))) ) + (<h3> NIL ,"Salutation") + (form NIL + (<h2> NIL (<id> (: nm))) + (panel T (pack ,"Salutation" " '@1'") '(may Delete) '(choDlg NIL ,"Salutations" '(nm +Sal)) 'nm '+Sal) + (<grid> 2 + ,"Salutation" (gui '(+E/R +Cue +TextField) '(nm : home obj) ,"Salutation" 40) + ,"Greeting" (gui '(+E/R +TextField) '(hi : home obj) 40) + ,"Sex" (gui '(+E/R +SexField) '(sex : home obj)) ) + (<spread> NIL (editButton T)) ) ) ) + +# vi:et:ts=3:sw=3 diff --git a/app/sales.l b/app/sales.l @@ -0,0 +1,56 @@ +# 08mar10abu +# (c) Software Lab. Alexander Burger + +(must "Sales" Report) + +(menu ,"Sales" + (<h3> NIL ,"Sales") + (form NIL + (<grid> "-.-" + ,"Date" NIL + (prog + (gui '(+Var +DateField) '*SalFrom 10) + (prin " - ") + (gui '(+Var +DateField) '*SalTill 10) ) + ,"Customer" (gui '(+ChoButton) '(choCuSu (field 1))) + (gui '(+Var +Obj +TextField) '*SalCus '(nm +CuSu) 30) ) + (--) + (gui '(+ShowButton) NIL + '(csv ,"Sales" + (<table> 'chart NIL + (<!> + (quote + (align) + (NIL ,"Date") + (NIL ,"Customer") + NIL + (NIL ,"Zip") + (NIL ,"City") + (align ,"Total") ) ) + (catch NIL + (let Sum 0 + (pilog + (quote + @Rng (cons *SalFrom (or *SalTill T)) + @Cus *SalCus + (select (@Ord) + ((dat +Ord @Rng) (cus +Ord @Cus)) + (range @Rng @Ord dat) + (same @Cus @Ord cus) ) ) + (with @Ord + (let N (sum> This) + (<row> (alternating) + (<+> (: nr) This) + (<+> (datStr (: dat)) This) + (<+> (: cus nm) (: cus)) + (<+> (: cus nm2)) + (<+> (: cus plz)) + (<+> (: cus ort)) + (<-> (money N)) ) + (inc 'Sum N) ) ) + (at (0 . 10000) (or (flush) (throw))) ) + (<row> 'nil + (<strong> ,"Total") - - - - - + (<strong> (prin (money Sum))) ) ) ) ) ) ) ) ) + +# vi:et:ts=3:sw=3 diff --git a/app/user.l b/app/user.l @@ -0,0 +1,36 @@ +# 03jan09abu +# (c) Software Lab. Alexander Burger + +(must "User Administration" UserAdmin) + +(menu ,"User Administration" + (ifn *ID + (prog + (<h3> NIL ,"Select" " " ,"User") + (form 'dialog (choDlg NIL ,"Users" '(nm +User))) ) + (<h3> NIL ,"User Administration") + (form NIL + (<h2> NIL (<id> (: nm))) + (panel T (pack ,"User" " '@1'") '(may Delete) '(choDlg NIL ,"Users" '(nm +User)) 'nm '+User) + (<grid> 2 + ,"Login Name" (gui '(+E/R +Cue +TextField) '(nm : home obj) ,"User" 30) + ,"Password" + (gui '(+Tip +Able +E/R +Fmt +TextField) + '(and (may Password) (val> This)) + '(may Password) + '(pw : home obj) + '((V) (and V "****")) + '((V) (if (= V "****") (: home obj pw) V)) + 30 ) + ,"Role" + (gui '(+Able +E/R +Obj +TextField) + '(may RoleAdmin) + '(role : home obj) + '(nm +Role) + T ) + ,"Full Name" (gui '(+E/R +TextField) '(nam : home obj) 40) + ,"Phone" (gui '(+E/R +TelField) '(tel : home obj) 40) + ,"EMail" (gui '(+E/R +MailField) '(em : home obj) 40) ) + (<spread> NIL (editButton T)) ) ) ) + +# vi:et:ts=3:sw=3 diff --git a/bin/pil b/bin/pil @@ -0,0 +1,2 @@ +#!/usr/bin/picolisp /usr/lib/picolisp/lib.l +(load "@lib/misc.l" "@lib/btree.l" "@lib/db.l" "@lib/pilog.l") diff --git a/bin/psh b/bin/psh @@ -0,0 +1,14 @@ +#!bin/picolisp lib.l +# 28sep07abu +# (c) Software Lab. Alexander Burger + +(load "@lib/misc.l" "@lib/http.l") + +(raw T) +(let *Dbg NIL + (client "localhost" (format (opt)) + (pack "@psh?" (pw) "&" (in '("tty") (line T))) + (ctty (read)) + (line) + (line) ) ) +(bye) diff --git a/bin/replica b/bin/replica @@ -0,0 +1,31 @@ +#!bin/picolisp lib.l +# 21aug07abu +# Use: bin/replica <port> <keyFile> <journal> <dbFile> <blob/app/> [dbs1 ..] +# : bin/ssl <host> 443 <port>/@replica <keyFile> <journal> <blob/app/> 60 + +(load "@lib/misc.l" "@lib/http.l") + +(allowed NIL "@replica") + +(argv *Port *KeyFile *Journal *Pool *Blob . *Dbs) + +(setq + *Port (format *Port) + *SSLKey (in *KeyFile (line T)) ) + +(de replica () + (ctl *KeyFile + (protect + (when (= (line T) *SSLKey) + (let? X (line T) + (if (format X) + (when (out (tmp 'replica) (echo @)) # Journal + (prin (peek)) + (flush) + (journal (tmp 'replica)) ) + (let Blob (pack *Blob X) # Blob + (call 'mkdir "-p" (dirname Blob)) + (out Blob (echo)) ) ) ) ) ) ) ) + +(pool *Pool (mapcar format *Dbs) *Journal) +(server *Port) diff --git a/bin/scrape b/bin/scrape @@ -0,0 +1,11 @@ +#!bin/picolisp lib.l +# 07oct08abu +# (c) Software Lab. Alexander Burger + +(load "ext.l" "dbg.l" "lib/http.l" "lib/scrape.l") + +(scrape + (or (opt) "localhost") + (or (format (opt)) 8080) ) + +# vi:et:ts=3:sw=3 diff --git a/bin/watchdog b/bin/watchdog @@ -0,0 +1,68 @@ +#!bin/picolisp lib.l +# 09mar08abu +# (c) Software Lab. Alexander Burger +# Use: bin/watchdog <host> <port> <from> <to1> <to2> .. + +(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") ) + +(push1 '*Bye '(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) + (del (assoc X *Watch) '*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 5 (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 (filter '((X) (> D (cadr X))) *Watch) + (if (caddr W) + (prog + (msg (car W) " " (stamp) + (if (kill (car W) 15) " killed" " gone") ) + (del W '*Watch) ) + (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) diff --git a/cygwin/README b/cygwin/README @@ -0,0 +1,170 @@ +Porting PicoLisp to Cygwin + +A few months back, I was looking at Lisp programming language +offerings for the MS Windows environment. I want an interpreter +that is fast and powerful, yet small. I want it to work well in +the Cygwin/Win32 environment. + +Enter PicoLisp. http://software-lab.de/down.html + +According to the PicoLisp FAQ, "PicoLisp is for programmers +who want to control their programming environment, at all +levels, from the application domain down to the bare metal." +Yes! That's part of what I want a Lisp for. Especially a Lisp I +might embed in other applications. I want control. PicoLisp +looked promising. + +PicoLisp is designed with a philosophy of "succinctness", +according to the literature on the site. Although there are +even smaller Lisp interpreters available, PicoLisp seemed to +strike a balance between terseness and functionality. + +PicoLisp is written using standard C, and the author +(Alexander Burger) distributes it as C source code under the +GNU General Public License. That means if you want to use +PicoLisp, you'll need to compile it yourself, or otherwise obtain +the executables. PicoLisp comes in two flavours: picolisp, and +an even smaller version: mini picolisp. (More about mini +picolisp in a bit.) + +When you do build PicoLisp for yourself, you'll get a +powerhouse of a Lisp including APIs for building web servers, +gui web application servers (for browser clients running java +and/or javascript) integrated relational databases, prolog db +access, and much more. PicoLisp even comes with two example +versions of a flight simulator: one which runs under X-Windows, +the other which uses a client's browser/java for the display. +There's a chess game written in PicoLisp and Prolog. + +Lest one think that PicoLisp is a mere toy, consider this. In +2006, PicoLisp won second prize in the German-language C't +Magazine database contest, beating entries written using DB2 +and Oracle. Industrial-strength databases with tightly +integrated web applications have been crafted with PicoLisp. +http://tinyurl.com/y9wu39 + +PicoLisp has some drawbacks and limitations. As the FAQ warns, +PicoLisp "does not pretend to be easy to learn." It is not a +Common Lisp flavor. It is not "some standard, 'safe' black-box, +which may be easier to learn." Also, for my purposes, I want +software that runs not only on Linux, but also on PCs with the +MS-Windows operating systems. And there was the rub: PicoLisp +isn't distributed with binaries or Windows exe files. + +Even worse (for Windows users), PicoLisp wasn't ported to +Cygwin. I have a growing list of portable apps that will run on +a flash drive, many of them I compiled from source from using +Cygwin tools like make, gcc, etc. + +Cygwin provides a POSIX emulation layer in the form of +cygwin1.dll and other libraries. This lets a PC running Windows +look like much like a Linux or UNIX box to programs which have +been compiled for Cygwin. I'd compiled hundreds of programs +for Cygwin and here was PicoLisp which I wanted to have +running on all my PCs, Linux ones as well as the MS-Windows +PCs, too. + +So this was beginning to look like a challenge. I'd just take a +little peek at porting PicoLisp to Cygwin, and see how it +would go. I'd ported everything from sox to busybox to fluxbox +to Cygwin, so I felt ready for porting PicoLisp. + +PicoLisp comes in two flavors. Mini picolisp and full +picolisp. + +Mini PicoLisp is a kind of a "pure" PicoLisp without +system-dependent functions like databases, UTF-8, bignums, IPC, +and networking. This seemed like a good place to start my +PicoLisp porting adventures. I first tried a straight Cygwin/gcc +build, and that worked fine, no hitches. + +Then I remembered the -mno-cygwin compiler flag for Cygwin's +gcc. When you compile with -mno-cygwin, gcc causes the +resulting executable to be built without Cygwin dll library +dependances. For C code that relies heavily upon the POSIX +emulation aspects of Cygwin, this might not work. But why not +try building mini picolisp with the -mno-cygwin option? + +The C code for mini picolisp is free from Linux/POSIX system +calls, and it compiled with no problems using -mno-cygwin. It +produced a mini picolisp exe file of about 73K, which is not +dependant upon any Cygwin DLLs. + +Porting the full PicoLisp interpreter proved to be more of a +challenge. Whereas the mini picolisp was careful to avoid Linux +system calls, PicoLisp takes the opposite approach and uses +Linux (UNIX/POSIX) system functions where needed. + +Additionally, PicoLisp has the ability to dynamically load +shared libraries for various extensions. + +Since we need to use shared libraries anyway, I wanted for all +of picolisp to go into a single DLL. Then the picolisp exe +would be a just small stub that uses that the shared library, +picolisp.dll. PicoLisp applications often use fork, so this +should also be more efficient when forking. + +Splitting up PicoLisp this way (a DLL and an exe stub) would +allow the picolisp.dll to be used as a Lisp library. As a +shared library, it would then be possible for other +applications to treat PicoLisp as an embedded interpreter, +somewhat like librep, but much smaller and more portable. + +Wanting to see how much I could squeeze down the size of the +executables and libraries under Cygwin, I used gcc's -Os +option, which requests that gcc optimize by making the smallest +possible code. Doing this resulted in a picolisp dll of just +150K, and a picolisp exe stub of only 2K. + +Of course, if you want this full PicoLisp to run on a Windows +PC which does not already have Cygwin installed, you'll need to +obtain a few Cygwin DLLs which provide the POSIX emulation +layer for PicoLisp. + +For the most part, the port to Win32/Cygwin went smoothly. +There were just a few differences between Linux and Cygwin that +were handled with macro ifdef statements in the C code that +allow something to be done differently for the Cygwin +compilation. + +In the end it turned out that the biggest problem was the fcntl +system function that does file and record locking. This was +especially frustrating, as time and time again, I thought I'd +found a solution or a work-around to the differences in +semantics of the fcntl call between Linux and Cygwin, only to +have the my "solution" fail with more rigorous testing. + +The locking problem was finally just circumvented for Windows +by simply not using fcntl locking. So, there is no file or +record locking for PicoLisp running under Windows. (See the +locking notes in http://www.sqlite.org/lockingv3.html for +another perspective on locking system functions in Windows.) +However, all the example applications run fine, running in a +special (Solo) mode in PicoLisp, in the few places it even +matters. This avoids depending on buggy or non-existent record +locking functionality with the various Windows versions and +file system types. + +So, what do we have at this point? PicoLisp is running on the +PC. A working, industrial-strength Lisp interpreter is +PicoLisp, ready for writing applications that are succinct yet +powerful. PicoLisp comes with a Prolog interpreter and +relational databases and flight simulators and chess games and +web servers and chat servers and sendmail and much more. + +And PicoLisp itself is written in highly portable C, running +on Linux and Windows. PicoLisp is readily embedable, and will +be useful to add scripting languages (Lisp, Prolog) to other +applications, either statically linked, or as a shared library +(DLL). + +PicoLisp is a little dynamo. It even has the ability to use +in-line C code which is compiled on-the-fly into a shared +library. This in-line C ability uses gcc. (And it works with +tcc, the Tiny C Compiler, too.) + +With the tremendous number of PCs out there now able to run +PicoLisp, watch out! PicoLisp may be small, but sometimes +very powerful things come in small packages. + +Doug Snead, Jan. 2007 diff --git a/cygwin/tcc.l b/cygwin/tcc.l @@ -0,0 +1,22 @@ +# 21jan07abu +# (c) Software Lab. Alexander Burger + +# use the Tiny C Compiler http://fabrice.bellard.free.fr/tcc +(de tcc (S L . @) + (out (tmp S ".c") + (chdir '@ (prinl "#include <pico.h>")) + (here "/**/") ) + (apply call L 'tcc "-shared" "-rdynamic" + (pack "-I" (dospath "/usr/include")) + (pack "-I" (dospath (path "@/src"))) + "-falign-functions" "-fomit-frame-pointer" + "-W" "-Wimplicit" "-Wreturn-type" "-Wunused" "-Wformat" + "-Wuninitialized" "-Wstrict-prototypes" "-pipe" + "-D_GNU_SOURCE" "-D_FILE_OFFSET_BITS=64" "-DNOWAIT" + "-o" (tmp S ".dll") (tmp S ".c") + (dospath (path "@/bin/picolisp.def"))) + (while (args) + (def (next) (def (tmp S ': (arg)))) ) ) + +(de dospath (p) + (in '("cygpath" "-m" p) (line T)) ) diff --git a/dbg b/dbg @@ -0,0 +1,2 @@ +#!/bin/sh +exec ${0%/*}/bin/picolisp -"on *Dbg" ${0%/*}/lib.l @ext.l @dbg.l "$@" diff --git a/dbg.l b/dbg.l @@ -0,0 +1,16 @@ +# 14apr10abu +# (c) Software Lab. Alexander Burger + +(on *Dbg) + +(when (sys "TERM") + (setq *Tsm + (cons + (in '("tput" "smul") (line T)) + (in '("tput" "rmul") (line T)) ) ) ) + +(load "@lib/debug.l" "@lib/led.l" "@lib/edit.l" "@lib/lint.l" "@lib/sq.l") + +(noLint 'later (loc "@Prg" later)) + +# vi:et:ts=3:sw=3 diff --git a/doc/app.html b/doc/app.html @@ -0,0 +1,2551 @@ +<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.0 Transitional//EN" "http://www.w3.org/TR/1998/REC-html40-19980424/loose.dtd"> +<html lang="en"> +<head> +<meta http-equiv="Content-Type" content="text/html; charset=utf-8"> +<title>PicoLisp Application Development</title> +<link rel="stylesheet" href="doc.css" type="text/css"> +</head> +<body> +<a href="mailto:abu@software-lab.de">abu@software-lab.de</a> + +<h1>PicoLisp Application Development</h1> + +<p align=right>(c) Software Lab. Alexander Burger + +<p>This document presents an introduction to writing browser-based applications +in PicoLisp. + +<p>It concentrates on the XHTML/CSS GUI-Framework (as opposed to the previous +Java-AWT, Java-Swing and Plain-HTML frameworks), which is easier to use, more +flexible in layout design, and does not depend on plug-ins, JavaScript or +cookies. + +<p>A plain HTTP/HTML GUI has various advantages: It runs on any browser, and can +be fully driven by scripts ("lib/scrape.l"). + +<p>To be precise: CSS <i>can</i> be used to enhance the layout. And browsers +<i>with</i> JavaScript will respond faster and smoother. But this framework +works just fine in browsers which do not know anything about CSS or JavaScript. +All examples were also tested using the w3m text browser. + +<p>For basic informations about the PicoLisp system please look at the <a +href="ref.html">PicoLisp Reference</a> and the <a href="tut.html">PicoLisp +Tutorial</a>. Knowledge of HTML, and a bit of CSS and HTTP is assumed. + +<p>Throughout this document, transient symbols will be displayed with <code><a +href="refT.html#*Tsm">*Tsm</a></code> turned off, i.e. as "Name" (double-quoted) +instead of <u>Name</u> (underlined), to make it easier to copy/paste the +examples. + +<p><ul> +<li><a href="#static">Static Pages</a> + <ul> + <li><a href="#hello">Hello World</a> + <ul> + <li><a href="#server">Start the application server</a> + <li><a href="#how">How does it work?</a> + </ul> + <li><a href="#urlSyntax">URL Syntax</a> + <li><a href="#security">Security</a> + <ul> + <li><a href="#pw">The ".pw" File</a> + </ul> + <li><a href="#htmlFoo">The <code>html</code> Function</a> + <li><a href="#cssAttr">CSS Attributes</a> + <li><a href="#tags">Tag Functions</a> + <ul> + <li><a href="#simple">Simple Tags</a> + <li><a href="#lists">(Un)ordered Lists</a> + <li><a href="#tables">Tables</a> + <li><a href="#menus">Menus and Tabs</a> + </ul> + </ul> +<li><a href="#forms">Interactive Forms</a> + <ul> + <li><a href="#sessions">Sessions</a> + <li><a href="#actionForms">Action Forms</a> + <ul> + <li><a href="#guiFoo">The <code>gui</code> Function</a> + <li><a href="#ctlFlow">Control Flow</a> + <li><a href="#switching">Switching URLs</a> + <li><a href="#dialogs">Alerts and Dialogs</a> + <li><a href="#calc">A Calculator Example</a> + </ul> + <li><a href="#charts">Charts</a> + <ul> + <li><a href="#scrolling">Scrolling</a> + <li><a href="#putGet">Put and Get Functions</a> + </ul> + </ul> +<li><a href="#guiClasses">GUI Classes</a> + <ul> + <li><a href="#inputFields">Input Fields</a> + <ul> + <li><a href="#numberFields">Numeric Input Fields</a> + <li><a href="#timeDateFields">Time &amp; Date</a> + <li><a href="#telFields">Telephone Numbers</a> + <li><a href="#checkboxes">Checkboxes</a> + </ul> + <li><a href="#fieldPrefix">Field Prefix Classes</a> + <ul> + <li><a href="#initPrefix">Initialization</a> + <li><a href="#ablePrefix">Disabling and Enabling</a> + <li><a href="#formatPrefix">Formatting</a> + <li><a href="#sideEffects">Side Effects</a> + <li><a href="#validPrefix">Validation</a> + <li><a href="#linkage">Data Linkage</a> + </ul> + <li><a href="#buttons">Buttons</a> + <ul> + <li><a href="#dialogButtons">Dialog Buttons</a> + <li><a href="#jsButtons">Active JavaScript</a> + </ul> + </ul> +<a name="minAppRef"></a> +<li><a href="#minApp">A Minimal Complete Application</a> + <ul> + <li><a href="#getStarted">Getting Started</a> + <ul> + <li><a href="#localization">Localization</a> + <li><a href="#navigation">Navigation</a> + <li><a href="#choosing">Choosing Objects</a> + <li><a href="#editing">Editing</a> + <li><a href="#btnLinks">Buttons vs. Links</a> + </ul> + <li><a href="#dataModel">The Data Model</a> + <li><a href="#usage">Usage</a> + <ul> + <li><a href="#cuSu">Customer/Supplier</a> + <li><a href="#item">Item</a> + <li><a href="#order">Order</a> + <li><a href="#reports">Reports</a> + </ul> + <li><a href="#bugs">Bugs</a> + </ul> +</ul> + + +<p><hr> +<h2><a name="static">Static Pages</a></h2> + +<p>You can use PicoLisp to generate static HTML pages. This does not make much +sense in itself, because you could directly write HTML code as well, but it +forms the base for interactive applications, and allows us to introduce the +application server and other fundamental concepts. + +<p><hr> +<h3><a name="hello">Hello World</a></h3> + +<p>To begin with a minimal application, please enter the following two lines +into a generic source file named "project.l" in the PicoLisp installation +directory. + +<pre><code> +######################################################################## +(html 0 "Hello" "lib.css" NIL + "Hello World!" ) +######################################################################## +</code></pre> + +<p>(We will modify and use this file in all following examples and experiments. +Whenever you find such a program snippet between hash ('#') lines, just copy and +paste it into your "project.l" file, and press the "reload" button of your +browser to view the effects) + + +<h4><a name="server">Start the application server</a></h4> + +<p>Open a second terminal window, and start a PicoLisp application server + +<pre><code> +$ ./dbg lib/http.l lib/xhtml.l lib/form.l -'server 8080 "project.l"' +</code></pre> + +<p>No prompt appears. The server just sits, and waits for connections. You can +stop it later by hitting <code>Ctrl-C</code> in that terminal, or by executing +'<code>killall picolisp</code>' in some other window. + +<p>(In the following, we assume that this HTTP server is up and running) + +<p>Now open the URL '<code><a +href="http://localhost:8080">http://localhost:8080</a></code>' with your +browser. You should see an empty page with a single line of text. + + +<h4><a name="how">How does it work?</a></h4> + +<p>The above line loads the debugger ('./dbg', which is equivalent to "./p +dbg.l"), the HTTP server code ("lib/http.l"), the XHTML functions +("lib/xhtml.l") and the input form framework ("lib/form.l", it will be needed +later for <a href="#forms">interactive forms</a>). + +<p>Then the <code>server</code> function is called with a port number and a +default URL. It will listen on that port for incoming HTTP requests in an +endless loop. Whenever a GET request arrives on port 8080, the file "project.l" +will be <code><a href="refL.html#load">(load)</a></code>ed, causing the +evaluation (= execution) of all its Lisp expressions. + +<p>During that execution, all data written to the current output channel is sent +directly to to the browser. The code in "project.l" is responsible to produce +HTML (or anything else the browser can understand). + + +<p><hr> +<h3><a name="urlSyntax">URL Syntax</a></h3> + +<p>The PicoLisp application server uses a slightly specialized syntax when +communicating URLs to and from a client. The "path" part of an URL - which +remains when + +<p><ul> +<li>the preceding protocol, host and port specifications, +<li>and the trailing question mark plus arguments +</ul> + +are stripped off - is interpreted according so some rules. The most prominent +ones are: + +<p><ul> +<li>If a path starts with an at-mark ('@'), the rest (without the '@') is taken +as the name of a Lisp function to be called. All arguments following the +question mark are passed to that function. + +<li>If a path ends with ".l" (a dot and a lower case 'L'), it is taken as a Lisp +source file name to be <code><a href="refL.html#load">(load)</a></code>ed. This +is the most common case, and we use it in our example "project.l". + +<li>If the extension of a file name matches an entry in the global mime type +table <code>*Mimes</code>, the file is sent to the client with mime-type and +max-age values taken from that table. + +<li>Otherwise, the file is sent to the client with a mime-type of +"application/octet-stream" and a max-age of 1 second. + +</ul> + +<p>An application is free to extend or modify the <code>*Mimes</code> table with +the <code>mime</code> function. For example + +<pre><code> +(mime "doc" "application/msword" 60) +</code></pre> + +<p>defines a new mime type with a max-age of one minute. + +<p>Argument values in URLs, following the path and the question mark, are +encoded in such a way that Lisp data types are preserved: + +<p><ul> +<li>An internal symbol starts with a dollar sign ('$') +<li>A number starts with a plus sign ('+') +<li>An external (database) symbol starts with dash ('-') +<li>A list (one level only) is encoded with underscores ('_') +<li>Otherwise, it is a transient symbol (a plain string) + +</ul> + +<p>In that way, high-level data types can be directly passed to functions +encoded in the URL, or assigned to global variables before a file is loaded. + + +<p><hr> +<h3><a name="security">Security</a></h3> + +<p>It is, of course, a huge security hole that - directly from the URL - any +Lisp source file can be loaded, and any Lisp function can be called. For that +reason, applications must take care to declare exactly which files and functions +are to be allowed in URLs. The server checks a global variable <code><a +href="refA.html#*Allow">*Allow</a></code>, and - when its value is +non-<code>NIL</code> - denies access to anything that does not match its +contents. + +<p>Normally, <code>*Allow</code> is not manipulated directly, but set with the +<code><a href="refA.html#allowed">allowed</a></code> and <code><a +href="refA.html#allow">allow</a></code> functions + +<pre><code> +(allowed ("img/" "demo/") + "favicon.ico" "lib.css" + "@start" "customer.l" "article.l") +</code></pre> + +<p>This is usually called in the beginning of an application, and allows access +to the directories "img/" and "demo/", to the function 'start', and to the files +"favicon.ico", "lib.css", "customer.l" and "article.l". + +<p>Later in the program, <code>*Allow</code> may be dynamically extended with +<code>allow</code> + +<pre><code> +(allow "@foo") +(allow "newdir/" T) +</code></pre> + +<p>This adds the function 'foo', and the directory "newdir/", to the set of +allowed items. + + +<h4><a name="pw">The ".pw" File</a></h4> + +<p>For a variety of security checks (most notably for using the <code>psh</code> +function, as in some later examples) it is necessary to create a file named +".pw" in the PicoLisp installation directory. This file should contain a single +line of arbitrary data, to be used as a password for identifying local +resources. + +<p>The recommeded way to create this file is to call the <code>pw</code> +function, defined in "lib/http.l" + +<pre><code> +$ ./p lib/http.l -'pw 12' -bye +</code></pre> + +<p>Please execute this command. + + +<p><hr> +<h3><a name="htmlFoo">The <code>html</code> Function</a></h3> + +<p>Now back to our "Hello World" example. In principle, you could write +"project.l" as a sequence of print statements + +<pre><code> +######################################################################## +(prinl "HTTP/1.0 200 OK^M") +(prinl "Content-Type: text/html; charset=utf-8") +(prinl "^M") +(prinl "&lt;html&gt;") +(prinl "Hello World!") +(prinl "&lt;/html&gt;") +######################################################################## +</code></pre> + +<p>but using the <code>html</code> function is much more convenient. + +<p>Moreover, <code>html</code> <b>is</b> nothing more than a printing function. +You can see this easily if you connect a PicoLisp Shell (<code>psh</code>) to +the server process (you must have generated a <a href="#pw">".pw" file</a> for +this), and enter the <code>html</code> statement + +<pre><code> +$ bin/psh 8080 +: (html 0 "Hello" "lib.css" NIL "Hello World!") +HTTP/1.0 200 OK +Server: PicoLisp +Date: Fri, 29 Dec 2006 07:28:58 GMT +Cache-Control: max-age=0 +Cache-Control: no-cache +Content-Type: text/html; charset=utf-8 + +&lt;!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd"&gt; +&lt;html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en" lang="en"&gt; +&lt;head&gt; +&lt;title&gt;Hello&lt;/title&gt; +&lt;base href="http://localhost:8080/"/&gt; +&lt;link rel="stylesheet" href="http://localhost:8080/lib.css" type="text/css"/&gt; +&lt;/head&gt; +&lt;body&gt;Hello World!&lt;/body&gt; +&lt;/html&gt; +-&gt; &lt;/html&gt; +: # (type ENTER here to terminate the PicoLisp Shell) +</code></pre> + +<p>These are the arguments to <code>html</code>: + +<ol> + +<li><code>0</code>: A max-age value for cache-control (in seconds, zero means +"no-cache"). You might pass a higher value for pages that change seldom, or +<code>NIL</code> for no cache-control at all. + +<li><code>"Hello"</code>: The page title. + +<li><code>"lib.css"</code>: A CSS-File name. Pass <code>NIL</code> if you do not want +to use any CSS-File, or a list of file names if you want to give more than one +CSS-File. + +<li><code>NIL</code>: A CSS style attribute specification (see the description +of <a href="#cssAttr">CSS Attributes</a> below). It will be passed to the +<code>body</code> tag. + +</ol> + +<p>After these four arguments, an arbitrary number of expressions may follow. +They form the body of the resulting page, and are evaluated according to a +special rule. <a name="tagRule">This rule</a> is slightly different from the +evaluation of normal Lisp expressions: + +<p><ul> + +<li>If an argument is an atom (a number or a symbol (string)), its value is +printed immediately. + +<li>Otherwise (a list), it is evaluated as a Lisp function (typically some form +of print statement). + +</ul> + +<p>Therefore, our source file might as well be written as: + +<pre><code> +######################################################################## +(html 0 "Hello" "lib.css" NIL + (prinl "Hello World!") ) +######################################################################## +</code></pre> + +<p>The most typical print statements will be some HTML-tags: + +<pre><code> +######################################################################## +(html 0 "Hello" "lib.css" NIL + (&lt;h1&gt; NIL "Hello World!") + (&lt;br&gt; "This is some text.") + (ht:Prin "And this is a number: " (+ 1 2 3)) ) +######################################################################## +</code></pre> + +<p><code>&lt;h1&gt;</code> and <code>&lt;br&gt;</code> are tag functions. +<code>&lt;h1&gt;</code> takes a CSS attribute as its first argument. + +<p>Note the use of <code>ht:Prin</code> instead of <code>prin</code>. +<code>ht:Prin</code> should be used for all direct printing in HTML pages, +because it takes care to escape special characters. + + +<p><hr> +<h3><a name="cssAttr">CSS Attributes</a></h3> + +<p>The <a href="#htmlFoo"><code>html</code> function</a> above, and many of the +HTML <a href="#tags">tag functions</a>, accept a CSS attribute specification. +This may be either an atom, a cons pair, or a list of cons pairs. We demonstrate +the effects with the <code>&lt;h1&gt;</code> tag function. + +<p>An atom (usually a symbol or a string) is taken as a CSS class name + +<pre><code> +: (&lt;h1&gt; 'foo "Title") +&lt;h1 class="foo"&gt;Title&lt;/h1&gt; +</code></pre> + +<p>For a cons pair, the CAR is taken as an attribute name, and the CDR as the +attribute's value + +<pre><code> +: (&lt;h1&gt; '(id . bar) "Title") +&lt;h1 id="bar"&gt;Title&lt;/h1&gt; +</code></pre> + +<p>Consequently, a list of cons pairs gives a set of attribute-value pairs + +<pre><code> +: (&lt;h1&gt; '((id . "abc") (lang . "de")) "Title") +&lt;h1 id="abc" lang="de"&gt;Title&lt;/h1&gt; +</code></pre> + + +<p><hr> +<h3><a name="tags">Tag Functions</a></h3> + +<p>All pre-defined XHTML tag functions can be found in "lib/xhtml.l". We +recommend to look at their sources, and to experiment a bit, by executing them +at a PicoLisp prompt, or by pressing the browser's "Reload" button after editing +the "project.l" file. + +<p>For a suitable PicoLisp prompt, either execute (in a separate terminal +window) the PicoLisp Shell (<code>psh</code>) command (works only if the +application server is running, and you did generate a <a href="#pw">".pw" +file</a>) + +<pre><code> +$ bin/psh 8080 +: +</code></pre> + +<p>or start the interpreter stand-alone, with "lib/xhtml.l" loaded + +<pre><code> +$ ./dbg lib/http.l lib/xhtml.l +: +</code></pre> + +<p>Note that for all these tag functions the above <a href="#tagRule">tag body +evaluation rule</a> applies. + + +<h4><a name="simple">Simple Tags</a></h4> + +<p>Most tag functions are simple and straightforward. Some of them just print +their arguments + +<pre><code> +: (&lt;br&gt; "Hello world") +Hello world&lt;br/&gt; + +: (&lt;em&gt; "Hello world") +&lt;em&gt;Hello world&lt;/em&gt; +</code></pre> + +<p>while most of them take a <a href="#cssAttr">CSS attribute specification</a> +as their first argument (like the <code>&lt;h1&gt;</code> tag above) + +<pre><code> +: (&lt;div&gt; 'main "Hello world") +&lt;div class="main"&gt;Hello world&lt;/div&gt; + +: (&lt;p&gt; NIL "Hello world") +&lt;p&gt;Hello world&lt;/p&gt; + +: (&lt;p&gt; 'info "Hello world") +&lt;p class="info"&gt;Hello world&lt;/p&gt; +</code></pre> + +<p>All of these functions take an arbitrary number of arguments, and may nest to +an arbitrary depth (as long as the resulting HTML is legal) + +<pre><code> +: (&lt;div&gt; 'main + (&lt;h1&gt; NIL "Head") + (&lt;p&gt; NIL + (&lt;br&gt; "Line 1") + "Line" + (&lt;nbsp&gt;) + (+ 1 1) ) ) +&lt;div class="main"&gt;&lt;h1&gt;Head&lt;/h1&gt; +&lt;p&gt;Line 1&lt;br/&gt; +Line&nbsp;2&lt;/p&gt; +&lt;/div&gt; +</code></pre> + + +<h4><a name="lists">(Un)ordered Lists</a></h4> + +<p>HTML-lists, implemented by the <code>&lt;ol&gt;</code> and +<code>&lt;ul&gt;</code> tags, let you define hierarchical structures. You might +want to paste the following code into your copy of "project.l": + +<pre><code> +######################################################################## +(html 0 "Unordered List" "lib.css" NIL + (&lt;ul&gt; NIL + (&lt;li&gt; NIL "Item 1") + (&lt;li&gt; NIL + "Sublist 1" + (&lt;ul&gt; NIL + (&lt;li&gt; NIL "Item 1-1") + (&lt;li&gt; NIL "Item 1-2") ) ) + (&lt;li&gt; NIL "Item 2") + (&lt;li&gt; NIL + "Sublist 2" + (&lt;ul&gt; NIL + (&lt;li&gt; NIL "Item 2-1") + (&lt;li&gt; NIL "Item 2-2") ) ) + (&lt;li&gt; NIL "Item 3") ) ) +######################################################################## +</code></pre> + +<p>Here, too, you can put arbitrary code into each node of that tree, including +other tag functions. + + +<h4><a name="tables">Tables</a></h4> + +<p>Like the hierarchical structures with the list functions, you can generate +two-dimensional tables with the <code>&lt;table&gt;</code> and +<code>&lt;row&gt;</code> functions. + +<p>The following example prints a table of numbers and their squares: + +<pre><code> +######################################################################## +(html 0 "Table" "lib.css" NIL + (&lt;table&gt; NIL NIL NIL + (for (N 1 (&gt;= 10 N) (inc N)) # A table with 10 rows + (&lt;row&gt; NIL N (prin (* N N))) ) ) ) # and 2 columns +######################################################################## +</code></pre> + +<p>The first argument to <code>&lt;table&gt;</code> is the usual CSS attribute, +the second an optional title ("caption"), and the third an optional list +specifying the column headers. In that list, you may supply a list for a each +column, with a CSS attribute in its CAR, and a tag body in its CDR for the +contents of the column header. + +<p>The body of <code>&lt;table&gt;</code> contains calls to the +<code>&lt;row&gt;</code> function. This function is special in that each +expression in its body will go to a separate column of the table. If both for +the column header and the row function an CSS attribute is given, they will be +combined by a space and passed to the HTML <code>&lt;td&gt;</code> tag. This +permits distinct CSS specifications for each column and row. + +<p>As an extension of the above table example, let's pass some attributes for +the table itself (not recommended - better define such styles in a CSS file and +then just pass the class name to <code>&lt;table&gt;</code>), right-align both +columns, and print each row in an alternating red and blue color + +<pre><code> +######################################################################## +(html 0 "Table" "lib.css" NIL + (&lt;table&gt; + '((width . "200px") (style . "border: dotted 1px;")) # table style + "Square Numbers" # caption + '((align "Number") (align "Square")) # 2 headers + (for (N 1 (&gt;= 10 N) (inc N)) # 10 rows + (&lt;row&gt; (xchg '(red) '(blue)) # red or blue + N # 2 columns + (prin (* N N) ) ) ) ) ) +######################################################################## +</code></pre> + +<p>If you wish to concatenate two or more cells in a table, so that a single +cell spans several columns, you can pass the symbol '<code>-</code>' for the +additional cell data to <code>&lt;row&gt;</code>. This will cause the data given +to the left of the '<code>-</code>' symbols to expand to the right. + +<p>You can also directly specify table structures with the simple +<code>&lt;th&gt;</code>, <code>&lt;tr&gt;</code> and <code>&lt;td&gt;</code> tag +functions. + +<p>If you just need a two-dimensional arrangement of components, the even +simpler <code>&lt;grid&gt;</code> function might be convenient: + +<pre><code> +######################################################################## +(html 0 "Grid" "lib.css" NIL + (&lt;grid&gt; 3 + "A" "B" "C" + 123 456 789 ) ) +######################################################################## +</code></pre> + +<p>It just takes a specification for the number of columns (here: 3) as its +first argument, and then a single expression for each cell. Instead of a number, +you can also pass a list of CSS attributes. Then the length of that list will +determine the number of columns. You can change the second line in the above +example to + +<pre><code> + (&lt;grid&gt; '(NIL NIL right) +</code></pre> + +<p>Then the third column will be right aligned. + + +<h4><a name="menus">Menus and Tabs</a></h4> + +<p>The two most powerful tag functions are <code>&lt;menu&gt;</code> and +<code>&lt;tab&gt;</code>. Used separately or in combination, they form a +navigation framework with + +<p><ul> +<li>menu items which open and close submenus +<li>submenu items which switch to different pages +<li>tabs which switch to different subpages +</ul> + +<p>The following example is not very useful, because the URLs of all items link +to the same "project.l" page, but it should suffice to demonstrate the +functionality: + +<pre><code> +######################################################################## +(html 0 "Menu+Tab" "lib.css" NIL + (&lt;div&gt; '(id . menu) + (&lt;menu&gt; + ("Item" "project.l") # Top level item + (NIL (&lt;hr&gt;)) # Plain HTML + (T "Submenu 1" # Submenu + ("Subitem 1.1" "project.l") + (T "Submenu 1.2" + ("Subitem 1.2.1" "project.l") + ("Subitem 1.2.2" "project.l") + ("Subitem 1.2.3" "project.l") ) + ("Subitem 1.3" "project.l") ) + (T "Submenu 2" + ("Subitem 2.1" "project.l") + ("Subitem 2.2" "project.l") ) ) ) + (&lt;div&gt; '(id . main) + (&lt;h1&gt; NIL "Menu+Tab") + (&lt;tab&gt; + ("Tab1" + (&lt;h3&gt; NIL "This is Tab 1") ) + ("Tab2" + (&lt;h3&gt; NIL "This is Tab 2") ) + ("Tab3" + (&lt;h3&gt; NIL "This is Tab 3") ) ) ) ) +######################################################################## +</code></pre> + +<p><code>&lt;menu&gt;</code> takes a sequence of menu items. Each menu item is a +list, with its CAR either + +<p><ul> +<li><code>NIL</code>: The entry is not an active menu item, and the rest of the +list may consist of arbitrary code (usually HTML tags). + +<li><code>T</code>: The second element is taken as a submenu name, and a click +on that name will open or close the corresponding submenu. The rest of the list +recursively specifies the submenu items (may nest to arbitrary depth). + +<li>Otherwise: The menu item specifies a direct action (instead of opening a +submenu), where the first list element gives the item's name, and the second +element the corresponding URL. + +</ul> + +<p><code>&lt;tab&gt;</code> takes a list of subpages. Each page is simply a tab +name, followed by arbitrary code (typically HTML tags). + +<p>Note that only a single menu and a single tab may be active at the same time. + + +<p><hr> +<h2><a name="forms">Interactive Forms</a></h2> + +<p>In HTML, the only possibility for user input is via <code>&lt;form&gt;</code> +and <code>&lt;input&gt;</code> elements, using the HTTP POST method to +communicate with the server. + +<p>"lib/xhtml.l" defines a function called <code>&lt;post&gt;</code>, and a +collection of input tag functions, which allow direct programming of HTML forms. +We will supply only one simple example: + +<pre><code> +######################################################################## +(html 0 "Simple Form" "lib.css" NIL + (&lt;post&gt; NIL "project.l" + (&lt;field&gt; 10 '*Text) + (&lt;submit&gt; "Save") ) ) +######################################################################## +</code></pre> + +<p>This associates a text input field with a global variable <code>*Text</code>. +The field displays the current value of <code>*Text</code>, and pressing the +submit button causes a reload of "project.l" with <code>*Text</code> set to any +string entered by the user. + +<p>An application program could then use that variable to do something useful, +for example store its value in a database. + +<p>The problem with such a straightforward use of forms is that + +<p><ol> +<li>they require the application programmer to take care of maintaining lots of +global variables. Each input field on the page needs an associated variable for +the round trip between server and client. + +<li>they do not preserve an application's internal state. Each POST request +spawns an individual process on the server, which sets the global variables to +their new values, generates the HTML page, and terminates thereafter. The +application state has to be passed along explicitly, e.g. using +<code>&lt;hidden&gt;</code> tags. + +<li>they are not very interactive. There is typically only a single submit +button. The user fills out a possibly large number of input fields, but changes +will take effect only when the submit button is pressed. + +</ol> + +<p>Though we wrote a few applications in that style, we recommend the GUI +framework provided by "lib/form.l". It does not need any variables for the +client/server communication, but implements a class hierarchy of GUI components +for the abstraction of application logic, button actions and data linkage. + + +<p><hr> +<h3><a name="sessions">Sessions</a></h3> + +<p>First of all, we need to establish a persistent environment on the server, to +handle each individual session (for each connected client). + +<p>Technically, this is just a child process of the server we started <a +href="#server">above</a>, which does not terminate immediately after it sent its +page to the browser. It is achieved by calling the <code>app</code> function +somewhere in the application's startup code. + +<pre><code> +######################################################################## +(app) # Start a session + +(html 0 "Simple Session" "lib.css" NIL + (&lt;post&gt; NIL "project.l" + (&lt;field&gt; 10 '*Text) + (&lt;submit&gt; "Save") ) ) +######################################################################## +</code></pre> + +<p>Nothing else changed from the previous example. However, when you connect +your browser and then look at the terminal window where you started the +application server, you'll notice a colon, the PicoLisp prompt + +<pre><code> +$ ./dbg lib/http.l lib/xhtml.l lib/form.l -'server 8080 "project.l"' +: +</code></pre> + +<p>Tools like the Unix <code>ps</code> utility will tell you that now two +<code>picolisp</code> processes are running, the first being the parent of the +second. + +<p>If you enter some text, say "abcdef", into the text field in the browser +window, press the submit button, and inspect the Lisp <code>*Text</code> +variable, + +<pre><code> +: *Text +-> "abcdef" +</code></pre> + +<p>you see that we now have a dedicated PicoLisp process, "connected" to the +client. + +<p>You can terminate this process (like any interactive PicoLisp) by hitting +ENTER on an empty line. Otherwise, it will terminate by itself if no other +browser requests arrive within a default timeout period of 5 minutes. + +<p>To start a (non-debug) production version, the server is commonly started not +as 'dbg' but with a 'p', and with <code>-wait</code> + +<pre><code> +$ ./p lib/http.l lib/xhtml.l lib/form.l -'server 8080 "project.l"' -wait +</code></pre> + +<p>In that way, no command line prompt appears when a client connects. + + +<p><hr> +<h3><a name="actionForms">Action Forms</a></h3> + +<p>Now that we have a persistent session for each client, we can set up an +active GUI framework. + +<p>This is done by wrapping the call to the <code>html</code> function with +<code>action</code>. Inside the body of <code>html</code> can be - in addition +to all other kinds of tag functions - one or more calls to <code>form</code> + +<pre><code> +######################################################################## +(app) # Start session + +(action # Action handler + (html 0 "Form" "lib.css" NIL # HTTP/HTML protocol + (form NIL # Form + (gui 'a '(+TextField) 10) # Text Field + (gui '(+Button) "Print" # Button + '(msg (val&gt; (: home a))) ) ) ) ) +######################################################################## +</code></pre> + +<p>Note that there is no longer a global variable like <code>*Text</code> to +hold the contents of the input field. Instead, we gave a local, symbolic name +'<code>a</code>' to a <code>+TextField</code> component + +<pre><code> + (gui 'a '(+TextField) 10) # Text Field +</code></pre> + +<p>Other components can refer to it + +<pre><code> + '(msg (val&gt; (: home a))) +</code></pre> + +<p><code>(: home)</code> is always the form which contains this GUI component. +So <code>(: home a)</code> evaluates to the component '<code>a</code>' in the +current form. As <code><a href="refM.html#msg">msg</a></code> prints its +argument to standard error, and the <code>val&gt;</code> method retrieves the +current contents of a component, we will see on the console the text typed into +the text field when we press the button. + +<p>An <code>action</code> without embedded <code>form</code>s - or a +<code>form</code> without a surrounding <code>action</code> - does not make much +sense by itself. Inside <code>html</code> and <code>form</code>, however, calls +to HTML functions (and any other Lisp functions, for that matter) can be freely +mixed. + +<p>In general, a typical page may have the form + +<pre><code> +(action # Action handler + (html .. # HTTP/HTML protocol + (&lt;h1&gt; ..) # HTML tags + (form NIL # Form + (&lt;h3&gt; ..) + (gui ..) # GUI component(s) + (gui ..) + .. ) + (&lt;h2&gt; ..) + (form NIL # Another form + (&lt;h3&gt; ..) + (gui ..) # GUI component(s) + .. ) + (&lt;br&gt; ..) + .. ) ) +</code></pre> + + +<h4><a name="guiFoo">The <code>gui</code> Function</a></h4> + +<p>The most prominent function in a <code>form</code> body is <code>gui</code>. +It is the workhorse of GUI construction. + +<p>Outside of a <code>form</code> body, <code>gui</code> is undefined. +Otherwise, it takes an optional alias name, a list of classes, and additional +arguments as needed by the constructors of these classes. We saw this example +before + +<pre><code> + (gui 'a '(+TextField) 10) # Text Field +</code></pre> + +Here, '<code>a</code>' is an alias name for a component of type +<code>(+TextField)</code>. The numeric argument <code>10</code> is passed to the +text field, specifying its width. See the chapter on <a href="#guiClasses">GUI +Classes</a> for more examples. + +<p>During a GET request, <code>gui</code> is basically a front-end to +<code>new</code>. It builds a component, stores it in the internal structures of +the current form, and initializes it by sending the <code>init&gt;</code> +message to the component. Finally, it sends it the <code>show&gt;</code> +message, to produce HTML code and transmit it to the browser. + +<p>During a POST request, <code>gui</code> does not build any new components. +Instead, the existing components are re-used. So <code>gui</code> does not have +much more to do than sending the <code>show&gt;</code> message to a component. + + +<h4><a name="ctlFlow">Control Flow</a></h4> + +<p>HTTP has only two methods to change a browser window: GET and POST. We employ +these two methods in a certain defined, specialized way: + +<p><ul> +<li>GET means, a <b>new page</b> is being constructed. It is used when a page is +visited for the first time, usually by entering an URL into the browser's +address field, or by clicking on a link (which is often a <a +href="#menus">submenu item or tab</a>). + +<li>POST is always directed to the <b>same page</b>. It is triggered by a button +press, updates the corresponding form's data structures, and executes that +button's action code. + +</ul> + +<p>A button's action code can do almost anything: Read and modify the contents +of input fields, communicate with the database, display alerts and dialogs, or +even fake the POST request to a GET, with the effect of showing a completely +different document (See <a href="#switching">Switching URLs</a>). + +<p>GET builds up all GUI components on the server. These components are objects +which encapsulate state and behavior of the HTML page in the browser. Whenever a +button is pressed, the page is reloaded via a POST request. Then - before any +output is sent to the browser - the <code>action</code> function takes control. +It performs error checks on all components, processes possible user input on the +HTML page, and stores the values in correct format (text, number, date, object +etc.) in each component. + +<p>The state of a form is preserved over time. When the user returns to a +previous page with the browser's BACK button, that state is reactivated, and may +be POSTed again. + +<p>The following silly example displays two text fields. If you enter some text +into the "Source" field, you can copy it in upper or lower case to the +"Destination" field by pressing one of the buttons + +<pre><code> +######################################################################## +(app) + +(action + (html 0 "Case Conversion" "lib.css" NIL + (form NIL + (&lt;grid&gt; 2 + "Source" (gui 'src '(+TextField) 30) + "Destination" (gui 'dst '(+Lock +TextField) 30) ) + (gui '(+JS +Button) "Upper Case" + '(set&gt; (: home dst) + (uppc (val&gt; (: home src))) ) ) + (gui '(+JS +Button) "Lower Case" + '(set&gt; (: home dst) + (lowc (val&gt; (: home src))) ) ) ) ) ) +######################################################################## +</code></pre> + +<p>The <code>+Lock</code> prefix class in the "Destination" field makes that +field read-only. The only way to get some text into that field is by using one +of the buttons. + + +<h4><a name="switching">Switching URLs</a></h4> + +<p>Because an action code runs before <code>html</code> has a chance to output +an HTTP header, it can abort the current page and present something different to +the user. This might, of course, be another HTML page, but would not be very +interesting as a normal link would suffice. Instead, it can cause the download +of dynamically generated data. + +<p>The next example shows a text area and two buttons. Any text entered into the +text area is exported either as a text file via the first button, or a PDF +document via the second button + +<pre><code> +######################################################################## +(load "lib/ps.l") + +(app) + +(action + (html 0 "Export" "lib.css" NIL + (form NIL + (gui '(+TextField) 30 8) + (gui '(+Button) "Text" + '(let Txt (tmp "export.txt") + (out Txt (prinl (val&gt; (: home gui 1)))) + (url Txt) ) ) + (gui '(+Button) "PDF" + '(psOut NIL "foo" + (a4) + (indent 40 40) + (down 60) + (hline 3) + (font (14 . "Times-Roman") + (ps (val&gt; (: home gui 1))) ) + (hline 3) + (page) ) ) ) ) ) +######################################################################## +</code></pre> + +<p>(a text area is built when you supply two numeric arguments (columns and +rows) to a <code>+TextField</code> class) + +<p>The action code of the first button creates a temporary file (i.e. a file +named "export.txt" in the current process's temporary space), prints the value +of the text area (this time we did not bother to give it a name, we simply refer +to it as the form's first gui list element) into that file, and then calls the +<code>url</code> function with the file name. + +<p>The second button uses the PostScript library "lib/ps.l" to create a +temporary file "foo.pdf". Here, the temporary file creation and the call to the +<code>url</code> function is hidden in the internal mechanisms of +<code>psOut</code>. The effect is that the browser receives a PDF document and +displays it. + + +<h4><a name="dialogs">Alerts and Dialogs</a></h4> + +<p>Alerts and dialogs are not really what they used to be ;-) + +<p>They do not "pop up". In this framework, they are just a kind of +simple-to-use, pre-fabricated form. They can be invoked by a button's action +code, and appear always on the current page, immediately preceding the form +which created them. + +<p>Let's look at an example which uses two alerts and a dialog. In the +beginning, it displays a simple form, with a locked text field, and two buttons + +<pre><code> +######################################################################## +(app) + +(action + (html 0 "Alerts and Dialogs" "lib.css" NIL + (form NIL + (gui '(+Init +Lock +TextField) "Initial Text" 20 "My Text") + (gui '(+Button) "Alert" + '(alert NIL "This is an alert " (okButton)) ) + (gui '(+Button) "Dialog" + '(dialog NIL + (&lt;br&gt; "This is a dialog.") + (&lt;br&gt; + "You can change the text here " + (gui '(+Init +TextField) (val&gt; (: top 1 gui 1)) 20) ) + (&lt;br&gt; "and then re-submit it to the form.") + (gui '(+Button) "Re-Submit" + '(alert NIL "Are you sure? " + (yesButton + '(set&gt; (: home top 2 gui 1) + (val&gt; (: home top 1 gui 1)) ) ) + (noButton) ) ) + (cancelButton) ) ) ) ) ) +######################################################################## +</code></pre> + +<p>The <code>+Init</code> prefix class initializes the "My Text" field with the +string "Initial Text". As the field is locked, you cannot modify this value +directly. + +<p>The first button brings up an alert saying "This is an alert.". You can +dispose it by pressing "OK". + +<p>The second button brings up a dialog with an editable text field, containing +a copy of the value from the form's locked text field. You can modify this +value, and send it back to the form, if you press "Re-Submit" and answer "Yes" +to the "Are you sure?" alert. + + +<h4><a name="calc">A Calculator Example</a></h4> + +<p>Now let's forget our "project.l" test file for a moment, and move on to a +more substantial and practical, stand-alone, example. Using what we have learned +so far, we want to build a simple bignum calculator. ("bignum" because PicoLisp +can do <i>only</i> bignums) + +<p>It uses a single form, a single numeric input field, and lots of buttons. It +can be found in the PicoLisp distribution in "misc/calc.l", together with a +directly executable wrapper script "misc/calc". + +<p>To use it, change to the PicoLisp installation directory, and start it as + +<pre><code> +$ misc/calc +</code></pre> + +<p>If you want to use it from other directories too, change the two relative +path names in the first line to absolute paths. We recommend symbolic links in +some global directories, as described in the <a +href="tut.html#script">Scripting</a> section of the PicoLisp Tutorial. + +<p>If you like to get a PicoLisp prompt for inspection, start it instead as + +<pre><code> +$ ./dbg misc/calc.l -main -go +</code></pre> + +<p>Then - as before - point your browser to '<code><a +href="http://localhost:8080">http://localhost:8080</a></code>'. + +<p>The code for the calculator logic and the GUI is rather straightforward. The +entry point is the single function <code>calculator</code>. It is called +directly (as described in <a href="#urlSyntax">URL Syntax</a>) as the server's +default URL, and implicitly in all POST requests. No further file access is +needed once the calculator is running. + +<p>Note that for a production application, we inserted an allow-statement (as +recommended by the <a href="#security">Security</a> chapter) + +<pre><code> +(allowed NIL "@calculator" "favicon.ico" "lib.css") +</code></pre> + +<p>at the beginning of "misc/calc.l". This will restrict external access to that +single function. + +<p>The calculator uses three global variables, <code>*Init</code>, +<code>*Accu</code> and <code>*Stack</code>. <code>*Init</code> is a boolean flag +set by the operator buttons to indicate that the next digit should initialize +the accumulator to zero. <code>*Accu</code> is the accumulator. It is always +displayed in the numeric input field, accepts user input, and it holds the +results of calculations. <code>*Stack</code> is a push-down stack, holding +postponed calculations (operators, priorities and intermediate results) with +lower-priority operators, while calculations with higher-priority operators are +performed. + +<p>The function <code>digit</code> is called by the digit buttons, and adds +another digit to the accumulator. + +<p>The function <code>calc</code> does an actual calculation step. It pops the +stack, checks for division by zero, and displays an error alert if necessary. + +<p><code>operand</code> processes an operand button, accepting a function and a +priority as arguments. It compares the priority with that in the top-of-stack +element, and delays the calculation if it is less. + +<p><code>finish</code> is used to calculate the final result. + +<p>The <code>calculator</code> function has one numeric input field, with a +width of 60 characters + +<pre><code> + (gui '(+Var +NumField) '*Accu 60) +</code></pre> + +<p>The <code>+Var</code> prefix class associates this field with the global +variable <code>*Accu</code>. All changes to the field will show up in that +variable, and modification of that variable's value will appear in the field. + +<p>The <a name="sqrtButton">square root operator button</a> has an +<code>+Able</code> prefix class + +<pre><code> + (gui '(+Able +JS +Button) '(ge0 *Accu) (char 8730) + '(setq *Accu (sqrt *Accu)) ) +</code></pre> + + +<p>with an argument expression which checks that the current value in the +accumulator is positive, and disables the button if otherwise. + +<p>The rest of the form is just an array (grid) of buttons, encapsulating all +functionality of the calculator. The user can enter numbers into the input +field, either by using the digit buttons, or by directly typing them in, and +perform calculations with the operator buttons. Supported operations are +addition, subtraction, multiplication, division, sign inversion, square root and +power (all in bignum integer arithmetic). The '<code>C</code>' button just +clears the accumulator, while the '<code>A</code>' button also clears all +pending calculations. + +<p>All that in 53 lines of code! + + +<p><hr> +<h3><a name="charts">Charts</a></h3> + +<p>Charts are virtual components, maintaining the internal representation of +two-dimensional data. + +<p>Typically, these data are nested lists, database selections, or some kind of +dynamically generated tabular information. Charts make it possible to view them +in rows and columns (usually in HTML <a href="#tables">tables</a>), scroll up +and down, and associate them with their corresponding visible GUI components. + +<p>In fact, the logic to handle charts makes up a substantial part of the whole +framework, with large impact on all internal mechanisms. Each GUI component must +know whether it is part of a chart or not, to be able to handle its contents +properly during updates and user interactions. + +<p>Let's assume we want to collect textual and numerical data. We might create a +table + +<pre><code> +######################################################################## +(app) + +(action + (html 0 "Table" "lib.css" NIL + (form NIL + (&lt;table&gt; NIL NIL '((NIL "Text") (NIL "Number")) + (do 4 + (&lt;row&gt; NIL + (gui '(+TextField) 20) + (gui '(+NumField) 10) ) ) ) + (&lt;submit&gt; "Save") ) ) ) +######################################################################## +</code></pre> + +<p>with two columns "Text" and "Number", and four rows, each containing a +<code>+TextField</code> and a <code>+NumField</code>. + +<p>You can enter text into the first column, and numbers into the second. +Pressing the "Save" button stores these values in the components on the server +(or produces an error message if a string in the second column is not a legal +number). + +<p>There are two problems with this solution: + +<p><ol> +<li>Though you can get at the user input for the individual fields, e.g. + +<pre><code> +: (val> (get *Top 'gui 2)) # Value in the first row, second column +-> 123 +</code></pre> + +there is no direct way to get the whole data structure as a single list. +Instead, you have to traverse all GUI components and collect the data. + +<li>The user cannot input more than four rows of data, because there is no easy +way to scroll down and make space for more. + +</ol> + +<p>A chart can handle these things: + +<pre><code> +######################################################################## +(app) + +(action + (html 0 "Chart" "lib.css" NIL + (form NIL + (gui '(+Chart) 2) # Inserted a +Chart + (&lt;table&gt; NIL NIL '((NIL "Text") (NIL "Number")) + (do 4 + (&lt;row&gt; NIL + (gui 1 '(+TextField) 20) # Inserted '1' + (gui 2 '(+NumField) 10) ) ) ) # Inserted '2' + (&lt;submit&gt; "Save") ) ) ) +######################################################################## +</code></pre> + +<p>Note that we inserted a <code>+Chart</code> component before the GUI +components which should be managed by the chart. The argument '2' tells the +chart that it has to expect two columns. + +<p>Each component got an index number (here '1' and '2') as the first argument +to <code>gui</code>, indicating the column into which this component should go +within the chart. + +<p>Now - if you entered "a", "b" and "c" into the first, and 1, 2, and 3 into +the second column - we can retrieve the chart's complete contents by sending it +the <code>val&gt;</code> message + +<pre><code> +: (val> (get *Top 'chart 1)) # Retrieve the value of the first chart +-> (("a" 1) ("b" 2) ("c" 3)) +</code></pre> + +<p>BTW, a more convenient function is <code>chart</code> + +<pre><code> +: (val> (chart)) # Retrieve the value of the current chart +-> (("a" 1) ("b" 2) ("c" 3)) +</code></pre> + +<p><code>chart</code> can be used instead of the above construct when we want to +access the "current" chart, i.e. the chart most recently processed in the +current form. + + +<h4><a name="scrolling">Scrolling</a></h4> + +<p>To enable scrolling, let's also insert two buttons. We use the pre-defined +classes <code>+UpButton</code> and <code>+DnButton</code> + +<pre><code> +######################################################################## +(app) + +(action + (html 0 "Scrollable Chart" "lib.css" NIL + (form NIL + (gui '(+Chart) 2) + (&lt;table&gt; NIL NIL '((NIL "Text") (NIL "Number")) + (do 4 + (&lt;row&gt; NIL + (gui 1 '(+TextField) 20) + (gui 2 '(+NumField) 10) ) ) ) + (gui '(+UpButton) 1) # Inserted two buttons + (gui '(+DnButton) 1) + (----) + (&lt;submit&gt; "Save") ) ) ) +######################################################################## +</code></pre> + +<p>to scroll down and up a single (argument '1') line at a time. + +<p>Now it is possible to enter a few rows of data, scroll down, and continue. It +is not necessary (except in the beginning, when the scroll buttons are still +disabled) to press the "Save" button, because <b>any</b> button in the form will +send changes to the server's internal structures before any action is performed. + + +<h4><a name="putGet">Put and Get Functions</a></h4> + +<p>As we said, a chart is a virtual component to edit two-dimensional data. +Therefore, a chart's native data format is a list of lists: Each sublist +represents a single row of data, and each element of a row corresponds to a +single GUI component. + +<p>In the example above, we saw a row like + +<pre><code> + ("a" 1) +</code></pre> + +<p>being mapped to + +<pre><code> + (gui 1 '(+TextField) 20) + (gui 2 '(+NumField) 10) +</code></pre> + +<p>Quite often, however, such a one-to-one relationship is not desired. The +internal data structures may have to be presented in a different form to the +user, and user input may need conversion to an internal representation. + +<p>For that, a chart accepts - in addition to the "number of columns" argument - +two optional function arguments. The first function is invoked to 'put' the +internal representation into the GUI components, and the second to 'get' data +from the GUI into the internal representation. + +<p>A typical example is a chart displaying customers in a database. While the +internal representation is a (one-dimensional) list of customer objects, 'put' +expands each object to a list with, say, the customer's first and second name, +telephone number, address and so on. When the user enters a customer's name, +'get' locates the matching object in the database and stores it in the internal +representation. In the following, 'put' will in turn expand it to the GUI. + +<p>For now, let's stick with a simpler example: A chart that holds just a list +of numbers, but expands in the GUI to show also a textual form of each number +(in German). + +<pre><code> +######################################################################## +(app) + +(load "lib/zahlwort.l") + +(action + (html 0 "Numerals" "lib.css" NIL + (form NIL + (gui '(+Init +Chart) (1 5 7) 2 + '((N) (list N (zahlwort N))) + car ) + (&lt;table&gt; NIL NIL '((NIL "Numeral") (NIL "German")) + (do 4 + (&lt;row&gt; NIL + (gui 1 '(+NumField) 9) + (gui 2 '(+Lock +TextField) 90) ) ) ) + (gui '(+UpButton) 1) + (gui '(+DnButton) 1) + (----) + (&lt;submit&gt; "Save") ) ) ) +######################################################################## +</code></pre> + +<p>"lib/zahlwort.l" defines the utility function <code>zahlwort</code>, which is +required later by the 'put' function. <code>zahlwort</code> accepts a number and +returns its wording in German. + +<p>Now look at the code + +<pre><code> + (gui '(+Init +Chart) (1 5 7) 2 + '((N) (list N (zahlwort N))) + car ) +</code></pre> + +<p>We prefix the <code>+Chart</code> class with <code>+Init</code>, and pass it +a list of numbers <code>(1 5 7)</code> for the initial value of the chart. Then, +following the '2' (the chart has two columns), we pass a 'put' function + +<pre><code> + '((N) (list N (zahlwort N))) +</code></pre> + +<p>which takes a number and returns a list of that number and its wording, and a +'get' function + +<pre><code> + car ) +</code></pre> + +<p>which in turn accepts such a list and returns a number, which happens to be +the list's first element. + +<p>You can see from this example that 'get' is the inverse function of 'put'. +'get' can be omitted, however, if the chart is read-only (contains no (or only +locked) input fields). + +<p>The field in the second column + +<pre><code> + (gui 2 '(+Lock +TextField) 90) ) ) ) +</code></pre> + +<p>is locked, because it displays the text generated by 'put', and is not +supposed to accept any user input. + +<p>When you start up this form in your browser, you'll see three pre-filled +lines with "1/eins", "5/fünf" and "7/sieben", according to the +<code>+Init</code> argument <code>(1 5 7)</code>. Typing a number somewhere into +the first column, and pressing ENTER or one of the buttons, will show a suitable +text in the second column. + + +<p><hr> +<h2><a name="guiClasses">GUI Classes</a></h2> + +<p>In previous chapters we saw examples of GUI classes like +<code>+TextField</code>, <code>+NumField</code> or <code>+Button</code>, often +in combination with prefix classes like <code>+Lock</code>, <code>+Init</code> +or <code>+Able</code>. Now we take a broader look at the whole hierarchy, and +try more examples. + +<p>The abstract class <code>+gui</code> is the base of all GUI classes. A live +view of the class hierarchy can be obtained with the <code><a +href="refD.html#dep">dep</a></code> ("dependencies") function: + +<pre><code> +: (dep '+gui) + +JsField + +Button + +UpButton + +PickButton + +DstButton + +ClrButton + +ChoButton + +Hint + +GoButton + +BubbleButton + +DelRowButton + +ShowButton + +DnButton + +field + +Checkbox + +TextField + +FileField + +ClassField + +numField + +NumField + +FixField + +BlobField + +DateField + +SymField + +UpField + +MailField + +SexField + +AtomField + +PwField + +ListTextField + +LinesField + +TelField + +TimeField + +HttpField + +Radio +-> +gui +</code></pre> + +<p>We see, for example, that <code>+DnButton</code> is a subclass of +<code>+Button</code>, which in turn is a subclass of <code>+gui</code>. +Inspecting <code>+DnButton</code> directly + +<pre><code> +: (dep '+DnButton) + +Tiny + +Rid + +JS + +Able + +gui + +Button ++DnButton +-> +DnButton +</code></pre> + +<p>shows that <code>+DnButton</code> inherits from <code>+Tiny</code>, +<code>+Rid</code>, <code>+Able</code> and <code>+Button</code>. The actual +definition of <code>+DnButton</code> can be found in "lib/form.l" + +<pre><code> +(class +DnButton +Tiny +Rid +JS +Able +Button) +... +</code></pre> + +<p>In general, "lib/form.l" is the ultimate reference to the framework, and +should be freely consulted. + + +<p><hr> +<h3><a name="inputFields">Input Fields</a></h3> + +<p>Input fields implement the visual display of application data, and allow - +when enabled - input and modification of these data. + +<p>On the HTML level, they can take the form of + +<ul> +<li>Normal text input fields +<li>Textareas +<li>Checkboxes +<li>Drop-down selections +<li>Password fields +<li>HTML links +<li>Plain HTML text +</ul> + +<p>Except for checkboxes, which are implemented by the <a +href="#checkboxes">Checkbox</a> class, all these HTML representations are +generated by <code>+TextField</code> and its content-specific subclasses like +<code>+NumField</code>, <code>+DateField</code> etc. Their actual appearance (as +one of the above forms) depends on their arguments: + +<p>We saw already "normal" text fields. They are created with a single numeric +argument. This example creates an editable field with a width of 10 characters: + +<pre><code> + (gui '(+TextField) 10) +</code></pre> + +<p>If you supply a second numeric for the line count ('4' in this case), you'll +get a text area: + +<pre><code> + (gui '(+TextField) 10 4) +</code></pre> + +<p>Supplying a list of values instead of a count yields a drop-down selection +(combo box): + +<pre><code> + (gui '(+TextField) '("Value 1" "Value 2" "Value 3")) +</code></pre> + +<p>In addition to these arguments, you can pass a string. Then the field is +created with a label: + +<pre><code> + (gui '(+TextField) 10 "Plain") + (gui '(+TextField) 10 4 "Text Area") + (gui '(+TextField) '("Value 1" "Value 2" "Value 3") "Selection") +</code></pre> + +<p>Finally, without any arguments, the field will appear as a plain HTML text: + +<pre><code> + (gui '(+TextField)) +</code></pre> + +<p>This makes mainly sense in combination with prefix classes like +<code>+Var</code> and <code>+Obj</code>, to manage the contents of these fields, +and achieve special behavior as HTML links or scrollable chart values. + + +<h4><a name="numberFields">Numeric Input Fields</a></h4> + +<p>A <code>+NumField</code> returns a number from its <code>val&gt;</code> +method, and accepts a number for its <code>set&gt;</code> method. It issues an +error message when user input cannot be converted to a number. + +<p>Large numbers are shown with a thousands-separator, as determined by the +current locale. + +<pre><code> +######################################################################## +(app) + +(action + (html 0 "+NumField" "lib.css" NIL + (form NIL + (gui '(+NumField) 10) + (gui '(+JS +Button) "Print value" + '(msg (val&gt; (: home gui 1))) ) + (gui '(+JS +Button) "Set to 123" + '(set&gt; (: home gui 1) 123) ) ) ) ) +######################################################################## +</code></pre> + +<p>A <code>+FixField</code> needs an additional scale factor argument, and +accepts/returns scaled fixpoint numbers. + +<p>The decimal separator is determined by the current locale. + +<pre><code> +######################################################################## +(app) + +(action + (html 0 "+FixField" "lib.css" NIL + (form NIL + (gui '(+FixField) 3 10) + (gui '(+JS +Button) "Print value" + '(msg (format (val&gt; (: home gui 1)) 3)) ) + (gui '(+JS +Button) "Set to 123.456" + '(set&gt; (: home gui 1) 123456) ) ) ) ) +######################################################################## +</code></pre> + + +<h4><a name="timeDateFields">Time &amp; Date</a></h4> + +<p>A <code>+DateField</code> accepts and returns a <code><a +href="refD.html#date">date</a></code> value. + +<pre><code> +######################################################################## +(app) + +(action + (html 0 "+DateField" "lib.css" NIL + (form NIL + (gui '(+DateField) 10) + (gui '(+JS +Button) "Print value" + '(msg (datStr (val&gt; (: home gui 1)))) ) + (gui '(+JS +Button) "Set to \"today\"" + '(set&gt; (: home gui 1) (date)) ) ) ) ) +######################################################################## +</code></pre> + +<p>The format displayed to - and entered by - the user depends on the current +locale (see <code><a href="refD.html#datStr">datStr</a></code> and <code><a +href="refE.html#expDat">expDat</a></code>). You can change it, for example to + +<pre><code> +: (locale "DE" "de") +-> NIL +</code></pre> + +<p>If no locale is set, the format is YYYY-MM-DD. Some pre-defined locales use +patterns like DD.MM.YYYY (DE), YYYY/MM/DD (JP), DD/MM/YYYY (UK), or MM/DD/YYYY +(US). + +<p>An error is issued when user input does not match the current locale's date +format. + +<p>Independent from the locale setting, a <code>+DateField</code> tries to +expand abbreviated input from the user. A small number is taken as that day of +the current month, larger numbers expand to day and month, or to day, month and +year: + +<ul> +<li>"7" gives the 7th of the current month +<li>"031" or "0301" give the 3rd of January of the current year +<li>"311" or "3101" give the 31st of January of the current year +<li>"0311" gives the 3rd of November of the current year +<li>"01023" or "010203" give the first of February in the year 2003 +<li>and so on +</ul> + +<p>Similar is the <code>+TimeField</code>. It accepts and returns a <code><a +href="refT.html#time">time</a></code> value. + +<pre><code> +######################################################################## +(app) + +(action + (html 0 "+TimeField" "lib.css" NIL + (form NIL + (gui '(+TimeField) 8) + (gui '(+JS +Button) "Print value" + '(msg (tim$ (val&gt; (: home gui 1)))) ) + (gui '(+JS +Button) "Set to \"now\"" + '(set&gt; (: home gui 1) (time)) ) ) ) ) +######################################################################## +</code></pre> + +<p>When the field width is '8', like in this example, time is displayed in the +format <code>HH:MM:SS</code>. Another possible value would be '5', causing +<code>+TimeField</code> to display its value as <code>HH:MM</code>. + +<p>An error is issued when user input cannot be converted to a time value. + +<p>The user may omit the colons. If he inputs just a small number, it should be +between '0' and '23', and will be taken as a full hour. '125' expands to +"12:05", '124517' to "12:45:17", and so on. + + +<h4><a name="telFields">Telephone Numbers</a></h4> + +<p>Telephone numbers are represented internally by the country code (without a +leading plus sign or zero) followed by the local phone number (ideally separated +by spaces) and the phone extension (ideally separated by a hyphen). The exact +format of the phone number string is not enforced by the GUI, but further +processing (e.g. database searches) normally uses <code><a +href="refF.html#fold">fold</a></code> for better reproducibility. + +<p>To display a phone number, <code>+TelField</code> replaces the country code +with a single zero if it is the country code of the current locale, or prepends +it with a plus sign if it is a foreign country (see <code><a +href="refT.html#telStr">telStr</a></code>). + +<p>For user input, a plus sign or a double zero is simply dropped, while a +single leading zero is replaced with the current locale's country code (see +<code><a href="refE.html#expTel">expTel</a></code>). + +<pre><code> +######################################################################## +(app) +(locale "DE" "de") + +(action + (html 0 "+TelField" "lib.css" NIL + (form NIL + (gui '(+TelField) 20) + (gui '(+JS +Button) "Print value" + '(msg (val&gt; (: home gui 1))) ) + (gui '(+JS +Button) "Set to \"49 1234 5678-0\"" + '(set&gt; (: home gui 1) "49 1234 5678-0") ) ) ) ) +######################################################################## +</code></pre> + + +<h4><a name="checkboxes">Checkboxes</a></h4> + +<p>A <code>+Checkbox</code> is straightforward. User interaction is restricted +to clicking it on and off. It accepts boolean (<code>NIL</code> or +non-<code>NIL</code>) values, and returns <code>T</code> or <code>NIL</code>. + +<pre><code> +######################################################################## +(app) + +(action + (html 0 "+Checkbox" "lib.css" NIL + (form NIL + (gui '(+Checkbox)) + (gui '(+JS +Button) "Print value" + '(msg (val&gt; (: home gui 1))) ) + (gui '(+JS +Button) "On" + '(set&gt; (: home gui 1) T) ) + (gui '(+JS +Button) "Off" + '(set&gt; (: home gui 1) NIL) ) ) ) ) +######################################################################## +</code></pre> + + +<p><hr> +<h3><a name="fieldPrefix">Field Prefix Classes</a></h3> + +<p>A big part of this framework's power is owed to the combinatorial flexibility +of prefix classes for GUI- and DB-objects. They allow to surgically override +individual methods in the inheritance tree, and can be combined in various ways +to achieve any desired behavior. + +<p>Technically, there is nothing special about prefix classes. They are just +normal classes. They are called "prefix" because they are intended to be written +<i>before</i> other classes in a class's or object's list of superclasses. + +<p>Usually they take their own arguments for their <code>T</code> method from +the list of arguments to the <code>gui</code> function. + + +<h4><a name="initPrefix">Initialization</a></h4> + +<p><code>+Init</code> overrides the <code>init&gt;</code> method for that +component. The <code>init&gt;</code> message is sent to a <code>+gui</code> +component when the page is loaded for the first time (during a GET request). +<code>+Init</code> takes an expression for the initial value of that field. + +<pre><code> + (gui '(+Init +TextField) "This is the initial text" 30) +</code></pre> + +<p>Other classes which automatically give a value to a field are +<code>+Var</code> (linking the field to a variable) and <code>+E/R</code> +(linking the field to a database entity/relation). + +<p><code>+Cue</code> can be used, for example in "mandatory" fields, to give a +hint to the user about what he is supposed to enter. It will display the +argument value, in angular brackets, if and only if the field's value is +<code>NIL</code>, and the <code>val&gt;</code> method will return +<code>NIL</code> despite the fact that this value is displayed. + +<p>Cause an empty field to display "&lt;Please enter some text here&gt;": + +<pre><code> + (gui '(+Cue +TextField) "Please enter some text here" 30) +</code></pre> + + +<h4><a name="ablePrefix">Disabling and Enabling</a></h4> + +<p>An important feature of an interactive GUI is the context-sensitive disabling +and enabling of individual components, or of a whole form. + +<p>The <code>+Able</code> prefix class takes an argument expression, and +disables the component if this expression returns <code>NIL</code>. We saw an +example for its usage already in the <a href="#sqrtButton">square root +button</a> of the calculator example. Or, for illustration purposes, imagine a +button which is supposed to be enabled only after Christmas + +<pre><code> + (gui '(+Able +Button) + '(>= (cdr (date (date))) (12 24)) + "Close this year" + '(endOfYearProcessing) ) +</code></pre> + +<p>or a password field that is disabled as long as somebody is logged in + +<pre><code> + (gui '(+Able +PwField) '(not *Login) 10 "Password") +</code></pre> + +<p>A special case is the <code>+Lock</code> prefix, which permanently and +unconditionally disables a component. It takes no arguments + +<pre><code> + (gui '(+Lock +NumField) 10 "Count") +</code></pre> + +<p>('10' and "Count" are for the <code>+NumField</code>), and creates a +read-only field. + +<p>The whole form can be disabled by calling <code>disable</code> with a +non-<code>NIL</code> argument. This affects all components in this form. Staying +with the above example, we can make the form read-only until Christmas + +<pre><code> + (form NIL + (disable (> (12 24) (cdr (date (date))))) # Disable whole form + (gui ..) + .. ) +</code></pre> + +<p>Even in a completely disabled form, however, it is often necessary to +re-enable certain components, as they are needed for navigation, scrolling, or +other activities which don't affect the contents of the form. This is done by +prefixing these fields with <code>+Rid</code> (i.e. getting "rid" of the lock). + +<pre><code> + (form NIL + (disable (> (12 24) (cdr (date (date))))) + (gui ..) + .. + (gui '(+Rid +Button) ..) # Button is enabled despite the disabled form + .. ) +</code></pre> + + +<h4><a name="formatPrefix">Formatting</a></h4> + +<p>GUI prefix classes allow a fine-grained control of how values are stored in - +and retrieved from - components. As in predefined classes like +<code>+NumField</code> or <code>+DateField</code>, they override the +<code>set&gt;</code> and/or <code>val&gt;</code> methods. + +<p><code>+Set</code> takes an argument function which is called whenever that +field is set to some value. To convert all user input to upper case + +<pre><code> + (gui '(+Set +TextField) uppc 30) +</code></pre> + +<p><code>+Val</code> is the complement to <code>+Set</code>. It takes a function +which is called whenever the field's value is retrieved. To return the square of +a field's value + +<pre><code> + (gui '(+Val +NumField) '((N) (* N N)) 10) +</code></pre> + +<p><code>+Fmt</code> is just a combination of <code>+Set</code> and +<code>+Val</code>, and takes two functional arguments. This example will display +upper case characters, while returning lower case characters internally + +<pre><code> + (gui '(+Fmt +TextField) uppc lowc 30) +</code></pre> + +<p><code>+Map</code> does (like <code>+Fmt</code>) a two-way translation. It +uses a list of cons pairs for a linear lookup, where the CARs represent the +displayed values which are internally mapped to the values in the CDRs. If a +value is not found in this list during <code>set&gt;</code> or +<code>val&gt;</code>, it is passed through unchanged. + +<p>Normally, <code>+Map</code> is used in combination with the combo box +incarnation of text fields (see <a href="#inputFields">Input Fields</a>). This +example displays "One", "Two" and "Three" to the user, but returns a number 1, 2 +or 3 internally + +<pre><code> +######################################################################## +(app) + +(action + (html 0 "+Map" "lib.css" NIL + (form NIL + (gui '(+Map +TextField) + '(("One" . 1) ("Two" . 2) ("Three" . 3)) + '("One" "Two" "Three") ) + (gui '(+Button) "Print" + '(msg (val> (field -1))) ) ) ) ) +######################################################################## +</code></pre> + + +<h4><a name="sideEffects">Side Effects</a></h4> + +<p>Whenever a button is pressed in the GUI, any changes caused by +<code>action</code> in the current environment (e.g. the database or application +state) need to be reflected in the corresponding GUI fields. For that, the +<code>upd&gt;</code> message is sent to all components. Each component then +takes appropriate measures (e.g. refresh from database objects, load values from +variables, or calculate a new value) to update its value. + +<p>While the <code>upd&gt;</code> method is mainly used internally, it can be +overridden in existing classes via the <code>+Upd</code> prefix class. Let's +print updated values to standard error + +<pre><code> +######################################################################## +(app) +(default *Number 0) + +(action + (html 0 "+Upd" "lib.css" NIL + (form NIL + (gui '(+Upd +Var +NumField) + '(prog (extra) (msg *Number)) + '*Number 8 ) + (gui '(+JS +Button) "Increment" + '(inc '*Number) ) ) ) ) +######################################################################## +</code></pre> + + +<h4><a name="validPrefix">Validation</a></h4> + +<p>To allow automatic validation of user input, the <code>chk&gt;</code> message +is sent to all components at appropriate times. The corresponding method should +return <code>NIL</code> if the value is all right, or a string describing the +error otherwise. + +<p>Many of the built-in classes have a <code>chk&gt;</code> method. The +<code>+NumField</code> class checks for legal numeric input, or the +<code>+DateField</code> for a valid calendar date. + +<p>An on-the-fly check can be implemented with the <code>+Chk</code> prefix +class. The following code only accepts numbers not bigger than 9: The +<code>or</code> expression first delegates the check to the main +<code>+NumField</code> class, and - if it does not give an error - returns an +error string when the current value is greater than 9. + +<pre><code> +######################################################################## +(app) + +(action + (html 0 "+Chk" "lib.css" NIL + (form NIL + (gui '(+Chk +NumField) + '(or + (extra) + (and (&gt; (val&gt; This) 9) "Number too big") ) + 12 ) + (gui '(+JS +Button) "Print" + '(msg (val&gt; (field -1))) ) ) ) ) +######################################################################## +</code></pre> + +<p>A more direct kind of validation is built-in via the <code>+Limit</code> +class. It controls the <code>maxlength</code> attribute of the generated HTML +input field component. Thus, it is impossible to type to more characters than +allowed into the field. + +<pre><code> +######################################################################## +(app) + +(action + (html 0 "+Limit" "lib.css" NIL + (form NIL + (gui '(+Limit +TextField) 4 8) + (gui '(+JS +Button) "Print" + '(msg (val&gt; (field -1))) ) ) ) ) +######################################################################## +</code></pre> + + +<h4><a name="linkage">Data Linkage</a></h4> + +<p>Although <code>set&gt;</code> and <code>val&gt;</code> are the official +methods to get a value in and out of a GUI component, they are not very often +used explicitly. Instead, components are directly linked to internal Lisp data +structures, which are usually either variables or database objects. + +<p>The <code>+Var</code> prefix class takes a variable (described as the +<code>var</code> data type - either a symbol or a cell - in the <a +href="ref.html#fun">Function Reference</a>). In the following example, we +initialize a global variable with the value "abc", and let a +<code>+TextField</code> operate on it. The "Print" button can be used to display +its current value. + +<pre><code> +######################################################################## +(app) + +(setq *TextVariable "abc") + +(action + (html 0 "+Var" "lib.css" NIL + (form NIL + (gui '(+Var +TextField) '*TextVariable 8) + (gui '(+JS +Button) "Print" + '(msg *TextVariable) ) ) ) ) +######################################################################## +</code></pre> + +<p><code>+E/R</code> takes an entity/relation specification. This is a cell, +with a relation in its CAR (e.g. <code>nm</code>, for an object's name), and an +expression in its CDR (typically <code>(: home obj)</code>, the object stored in +the <code>obj</code> property of the current form). + +<p>For an isolated, simple example, we create a temporary database, and access +the <code>nr</code> and <code>nm</code> properties of an object stored in a +global variable <code>*Obj</code>. + +<pre><code> +######################################################################## +(when (app) # On start of session + (class +Tst +Entity) # Define data model + (rel nr (+Number)) # with a number + (rel nm (+String)) # and a string + (pool (tmp "db")) # Create temporary DB + (setq *Obj # and a single object + (new! '(+Tst) 'nr 1 'nm "New Object") ) ) + +(action + (html 0 "+E/R" "lib.css" NIL + (form NIL + (gui '(+E/R +NumField) '(nr . *Obj) 8) # Linkage to 'nr' + (gui '(+E/R +TextField) '(nm . *Obj) 20) # Linkage to 'nm' + (gui '(+JS +Button) "Show" # Show the object + '(out 2 (show *Obj)) ) ) ) ) # on standard error +######################################################################## +</code></pre> + + +<p><hr> +<h3><a name="buttons">Buttons</a></h3> + +<p>Buttons are, as explained in <a href="#ctlFlow">Control Flow</a>, the only +way (via POST requests) for an application to communicate with the server. + +<p>Basically, a <code>+Button</code> takes + +<ul> +<li>a label, which may be either a string or the name of an image file +<li>an optional alternative label, shown when the button is disabled +<li>and an executable expression. +</ul> + +<p>Here is a minimal button, with just a label and an expression: + +<pre><code> + (gui '(+Button) "Label" '(doSomething)) +</code></pre> + +<p>And this is a button displaying different labels, depending on the state: + +<pre><code> + (gui '(+Button) "Enabled" "Disabled" '(doSomething)) +</code></pre> + +<p>To show an image instead of plain text, the label(s) must be preceeded by the +<code>T</code> symbol: + +<pre><code> + (gui '(+Button) T "img/enabled.png" "img/disabled.png" '(doSomething)) +</code></pre> + +<p>The expression will be executed during <code>action</code> handling (see <a +href="#actionForms">Action Forms</a>), when this button was pressed. + +<p>Like other components, buttons can be extended and combined with prefix +classes, and a variety of predefined classes and class combinations are +available. + + +<h4><a name="dialogButtons">Dialog Buttons</a></h4> + +<p>Buttons are essential for the handling of <a href="#dialogs">alerts and +dialogs</a>. Besides buttons for normal functions, like <a +href="#scrolling">scrolling</a> in charts or other <a href="#sideEffects">side +effects</a>, special buttons exist which can <i>close</i> an alert or dialog in +addition to doing their principal job. + +<p>Such buttons are usually subclasses of <code>+Close</code>, and most of them +can be called easily with ready-made functions like <code>closeButton</code>, +<code>cancelButton</code>, <code>yesButton</code> or <code>noButton</code>. We +saw a few examples in <a href="#dialogs">Alerts and Dialogs</a>. + + +<h4><a name="jsButtons">Active JavaScript</a></h4> + +<p>When a button inherits from the <code>+JS</code> class (and JavaScript is +enabled in the browser), that button will possibly show a much faster response +in its action. + +<p>The reason is that the activation of a <code>+JS</code> button will - instead +of doing a normal POST - first try to send only the contents of all GUI +components via an XMLHttpRequest to the server, and receive the updated values +in response. This avoids the flicker caused by reloading and rendering of the +whole page, is much faster, and also does not jump to the beginning of the page +if it is larger than the browser window. The effect is especially noticeable +while scrolling in charts. + +<p>Only if this fails, for example because an error message was issued, or a +dialog popped up, it will fall back, and the form will be POSTed in the normal +way. + +<p>Thus it makes no sense to use the <code>+JS</code> prefix for buttons that +cause a change of the HTML code, open a dialog, or jump to another page. In such +cases, overall performance will even be worse, because the XMLHttpRequest is +tried first (but in vain). + +<p>When JavaScript is disabled int the browser, the XMLHttpRequest will not be +tried at all. The form will be fully usable, though, with identical +functionality and behavior, just a bit slower and not so smooth. + + +<p><hr> +<h2><a name="minApp">A Minimal Complete Application</a></h2> + +<p>The PicoLisp release includes in the "app/" directory a minimal, yet complete +reference application. This application is typical, in the sense that it +implements many of the techniques described in this document, and it can be +easily modified and extended. In fact, we use it as templates for our own +production application development. + +<p>It is a kind of simplified ERP system, containing customers/suppliers, +products (items), orders, and other data. The order input form performs live +updates of customer and product selections, price, inventory and totals +calculations, and generates on-the-fly PDF documents. Fine-grained access +permissions are controlled via users, roles and permissions. It comes localized +in four languages (English, German, Russian and Japanese), with a some initial +data and two sample reports. + + +<p><hr> +<h3><a name="getStarted">Getting Started</a></h3> + +<p>As ever, you may start up the application in debugging mode + +<pre><code> +$ ./dbg app/main.l -main -go +</code></pre> + +<p>or in (non-debug) production mode + +<pre><code> +$ ./p app/main.l -main -go -wait +</code></pre> + +<p>and go to '<code><a +href="http://localhost:8080">http://localhost:8080</a></code>' with your +browser. You can login as user "admin", with password "admin". The demo data +contain several other users, but those are more restricted in their role +permissions. + +<p>Another possibility is to try the online version of this application at <a +href="http://app.7fach.de">app.7fach.de</a>. + + +<h4><a name="localization">Localization</a></h4> + +<p>Before or after you logged in, you can select another language, and click on +the "Change" button. This will effect all GUI components (though not text from +the database), and also the numeric, date and telephone number formats. + + +<h4><a name="navigation">Navigation</a></h4> + +<p>The navigation menu on the left side shows two items "Home" and "logout", and +three submenus "Data", "Report" and "System". + +<p>Both "Home" and "logout" bring you back to the initial login form. Use +"logout" if you want to switch to another user (say, for another set of +permissions), and - more important - before you close your browser, to release +possible locks and process resources on the server. + +<p>The "Data" submenu gives access to application specific data entry and +maintenance: Orders, product items, customers and suppliers. The "Report" +submenu contains two simple inventory and sales reports. And the "System" +submenu leads to role and user administration. + +<p>You can open and close each submenu individually. Keeping more than one +submenu open at a time lets you switch rapidly between different parts of the +application. + +<p>The currently active menu item is indicated by a highlighted list style (no +matter whether you arrived at this page directly via the menu or by clicking on +a link somewhere else). + + +<h4><a name="choosing">Choosing Objects</a></h4> + +<p>Each item in the "Data" or "System" submenu opens a search dialog for that +class of entities. You can specify a search pattern, press the top right +"Search" button (or just ENTER), and scroll through the list of results. + +<p>While the "Role" and "User" entities present simple dialogs (searching just +by name), other entities can be searched by a variety of criteria. In those +cases, a "Reset" button clears the contents of the whole dialog. A new object +can be created with bottom right "New" button. + +<p>In any case, the first column will contain either a "@"-link (to jump to that +object) or a "@"-button (to insert a reference to that object into the current +form). + +<p>By default, the search will list all database objects with an attribute value +greater than or equal to the search criterion. The comparison is done +arithmetically for numbers, and alphabetically (case sensitive!) for text. This +means, if you type "Free" in the "City" field of the "Customer/Supplier" dialog, +the value of "Freetown" will be matched. On the other hand, an entry of "free" +or "town" will yield no hits. + +<p>Some search fields, however, show a different behavior depending on the +application: + +<ul> +<li>The names of persons, companies or products allow a tolerant search, +matching either a slightly misspelled name ("Mühler" instead of "Miller") or a +substring ("Oaks" will match "Seven Oaks Ltd."). + +<li>The search field may specify an upper instead of a lower limit, resulting in +a search for database objects with an attribute value less than or equal to the +search criterion. This is useful, for example in the "Order" dialog, to list +orders according to their number or date, by starting with the newest then and +going backwards. + +</ul> + +<p>Using the bottom left scroll buttons, you can scroll through the result list +without limit. Clicking on a link will bring up the corresponding object. Be +careful here to select the right column: Some dialogs (those for "Item" and +"Order") also provide links for related entities (e.g. "Supplier"). + + +<h4><a name="editing">Editing</a></h4> + +<p>A database object is usually displayed in its own individual form, which is +determined by its entity class. + +<p>The basic layout should be consistent for all classes: Below the heading +(which is usually the same as the invoking menu item) is the object's identifier +(name, number, etc.), and then a row with an "Edit" button on the left, and +"Delete" button, a "Select" button and two navigation links on the right side. + +<p>The form is brought up initially in read-only mode. This is necessary to +prevent more than one user from modifying an object at the same time (and +contrary to the previous PicoLisp Java frameworks, where this was not a problem +because all changes were immediately reflected in the GUIs of other users). + +<p>So if you want to modify an object, you have to gain exclusive access by +clicking on the "Edit" button. The form will be enabled, and the "Edit" button +changes to "Done". Should any other user already have reserved this object, you +will see a message telling his name and process ID. + +<p>An exception to this are objects that were just created with "New". They will +automatically be reserved for you, and the "Edit" button will show up as "Done". + +<p>The "Delete" button pops up an alert, asking for confirmation. If the object +is indeed deleted, this button changes to "Restore" and allows to undelete the +object. Note that objects are never completely deleted from the database as long +as there are any references from other objects. When a "deleted" object is +shown, its identifier appears in square brackets. + +<p>The "Select" button (re-)displays the search dialog for this class of +entities. The search criteria are preserved between invocations of each dialog, +so that you can conveniently browse objects in this context. + +<p>The navigation links, pointing left and right, serve a similar purpose. They +let you step sequentially through all objects of this class, in the order of the +identifier's index. + +<p>Other buttons, depending on the entity, are usually arranged at the bottom of +the form. The bottom rightmost one should always be another "Edit" / "Done" +button. + +<p>As we said in the chapter on <a href="#scrolling">Scrolling</a>, any button +in the form will save changes to the underlying data model. As a special case, +however, the "Done" button releases the object and reverts to "Edit". Besides +this, the edit mode will also cease as soon as another object is displayed, be +it by clicking on an object link (the pencil icon), the top right navigation +links, or a link in a search dialog. + + +<h4><a name="btnLinks">Buttons vs. Links</a></h4> + +<p>The only way to interact with a HTTP-based application server is to click +either on a HTML link, or on a submit button (see also <a +href="#ctlFlow">Control Flow</a>). It is essential to understand the different +effects of such a click on data entered or modified in the current form. + +<ul> +<li>A click on a link will leave or reload the page. Changes are discarded. +<li>A click on a button will commit changes, and perform the associated action. +</ul> + +<p>For that reason the layout design should clearly differentiate between links +and buttons. Image buttons are not a good idea when in other places images are +used for links. The standard button components should be preferred; they are +usually rendered by the browser in a non-ambiguous three-dimensional look and +feel. + +<p>Note that if JavaScript is enabled in the browser, changes will be +automatically committed to the server. + +<p>The enabled or disabled state of a button is an integral part of the +application logic. It must be indicated to the user with appropriate styles. + + +<p><hr> +<h3><a name="dataModel">The Data Model</a></h3> + +<p>The data model for this mini application consists of only six entity classes +(see the E/R diagram at the beginning of "app/er.l"): + +<ul> +<li>The three main entities are <code>+CuSu</code> (Customer/Supplier), +<code>+Item</code> (Product Item) and <code>+Ord</code> (Order). + +<li>A <code>+Pos</code> object is a single position in an order. + +<li><code>+Role</code> and <code>+User</code> objects are needed for +authentication and authorization. + +</ul> + +<p>The classes <code>+Role</code> and <code>+User</code> are defined in +"lib/adm.l". A <code>+Role</code> has a name, a list of permissions, and a list +of users assigned to this role. A <code>+User</code> has a name, a password and +a role. + +<p>In "app/er.l", the <code>+Role</code> class is extended to define an +<code>url&gt;</code> method for it. Any object whose class has such a method is +able to display itself in the GUI. In this case, the file "app/role.l" will be +loaded - with the global variable <code>*ID</code> pointing to it - whenever an +HTML link to this role object is activated. + +<p>The <code>+User</code> class is also extended. In addition to the login name, +a full name, telephone number and email address is declared. And, of course, the +ubiquitous <code>url&gt;</code> method. + +<p>The application logic is centered around orders. An order has a number, a +date, a customer (an instance of <code>+CuSu</code>) and a list of positions +(<code>+Pos</code> objects). The <code>sum&gt;</code> method calculates the +total amount of this order. + +<p>Each position has an <code>+Item</code> object, a price and a quantity. The +price in the position overrides the default price from the item. + +<p>Each item has a number, a description, a supplier (also an instance of +<code>+CuSu</code>), an inventory count (the number of these items that were +counted at the last inventory taking), and a price. The <code>cnt&gt;</code> +method calculates the current stock of this item as the difference of the +inventory and the sold item counts. + +<p>The call to <code>dbs</code> at the end of "app/er.l" configures the physical +database storage. Each of the supplied lists has a number in its CAR which +determines the block size as (64 &lt;&lt; N) of the corresponding database file. +The CDR says that the instances of this class (if the element is a class symbol) +or the tree nodes (if the element is a list of a class symbol and a property +name) are to be placed into that file. This allows for some optimizations in the +database layout. + + +<p><hr> +<h3><a name="usage">Usage</a></h3> + +<p>When you are connected to the application (see <a href="#getStarted">Getting +Started</a>) you might try to do some "real" work with it. Via the "Data" menu +(see <a href="#navigation">Navigation</a>) you can create or modify customers, +suppliers, items and orders, and produce simple overviews via the "Report" menu. + + +<h4><a name="cuSu">Customer/Supplier</a></h4> + +<p align=right>Source in "app/cusu.l" + +<p>The Customer/Supplier search dialog (<code>choCuSu</code> in "app/gui.l") +supports a lot of search criteria. These become necessary when the database +contains a large number of customers, and can filter by zip, by phone number +prefixes, and so on. + +<p>In addition to the basic layout (see <a href="#editing">Editing</a>), the +form is divided into four separate tabs. Splitting a form into several tabs +helps to reduce traffic, with possibly better GUI response. In this case, four +tabs are perhaps overkill, but ok for demonstration purposes, and they leave +room for extensions. + +<p>Be aware that when data were modified in one of the tabs, the "Done" button +has to be pressed before another tab is clicked, because tabs are implemented as +HTML links (see <a href="#btnLinks">Buttons vs. Links</a>). + +<p>New customers or suppliers will automatically be assigned the next free +number. You can enter another number, but an error will result if you try to use +an existing number. The "Name" field is mandatory, you need to overwrite the +"&lt;Name&gt;" clue. + +<p>Phone and fax numbers in the "Contact" tab must be entered in the correct +format, depending on the locale (see <a href="#telFields">Telephone +Numbers</a>). + +<p>The "Memo" tab contains a single text area. It is no problem to use it for +large pieces of text, as it gets stored in a database blob internally. + + +<h4><a name="item">Item</a></h4> + +<p align=right>Source in "app/item.l" + +<p>Items also have a unique number, and a mandatory "Description" field. + +<p>To assign a supplier, click on the "+" button. The Customer/Supplier search +dialog will appear, and you can pick the desired supplier with the "@" button in +the first column. Alternatively, if you are sure to know the exact spelling of +the supplier's name, you can also enter it directly into the text field. + +<p>In the search dialog you may also click on a link, for example to inspect a +possible supplier, and then return to the search dialog with the browser's back +button. The "Edit" mode will then be lost, however, as another object has been +visited (this is described in the last part of <a href="#editing">Editing</a>). + +<p>You can enter an inventory count, the number of items currently in stock. The +following field will automatically reflect the remaining pieces after some of +these items were sold (i.e. referenced in order positions). It cannot be changed +manually. + +<p>The price should be entered with the decimal separator according to the +current locale. It will be formatted with two places after the decimal +separator. + +<p>The "Memo" is for an arbitrary info text, like in <a +href="#cuSu">Customer/Supplier</a> above, stored in a database blob. + +<p>Finally, a JPEG picture can be stored in a blob for this item. Choose a file +with the browser's file select control, and click on the "Install" button. The +picture will appear at the bottom of the page, and the "Install" button changes +to "Uninstall", allowing the picture's removal. + + +<h4><a name="order">Order</a></h4> + +<p align=right>Source in "app/ord.l" + +<p>Oders are identified by number and date. + +<p>The number must be unique. It is assigned when the order is created, and +cannot be changed for compliance reasons. + +<p>The date is initialized to "today" for a newly created order, but may be +changed manually. The date format depends on the locale. It is YYYY-MM-DD (ISO) +by default, DD.MM.YYYY in the German and YYYY/MM/DD in the Japanese locale. As +described in <a href="#timeDateFields">Time &amp; Date</a>, this field allows +input shortcuts, e.g. just enter the day to get the full date in the current +month. + +<p>To assign a customer to this order, click on the "+" button. The +Customer/Supplier search dialog will appear, and you can pick the desired +customer with the "@" button in the first column (or enter the name directly +into the text field), just as described above for <a href="#item">Item</a>s. + +<p>Now enter order the positions: Choose an item with the "+" button. The +"Price" field will be preset with the item's default price, you may change it +manually. Then enter a quantity, and click a button (typically the "+" button to +select the next item, or a scroll button go down in the chart). The form will be +automatically recalculated to show the total prices for this position and the +whole order. + +<p>Instead of the "+" or scroll buttons, as recommended above, you could of +course also press the "Done" button to commit changes. This is all right, but +has the disadvantage that the button must be pressed a second time (now "Edit") +if you want to continue with the entry of more positions. + +<p>The "x" button at the right of each position deletes that position without +further confirmation. It has to be used with care! + +<p>The "^" button is a "bubble" button. It exchanges a row with the row above it. +Therefore, it can be used to rearrange all items in a chart, by "bubbling" them +to their desired positions. + +<p>The "PDF-Print" button generates and displays a PDF document for this order. +The browser should be configured to display downloaded PDF documents in an +appropriate viewer. The source for the postscript generating method is in +"app/lib.l". It produces one or several A4 sized pages, depending on the number +of positions. + + +<h4><a name="reports">Reports</a></h4> + +<p align=right>Sources in "app/inventory.l and "app/sales.l" + +<p>The two reports ("Inventory" and "Sales") come up with a few search fields +and a "Show" button. + +<p>If no search criteria are entered, the "Show" button will produce a listing +of the relevant part of the whole database. This may take a long time and cause +a heavy load on the browser if the database is large. + +<p>So in the normal case, you will limit the domain by stating a range of item +numbers, a description pattern, and/or a supplier for the inventory report, or a +range of order dates and/or a customer for the sales report. If a value in a +range specification is omitted, the range is considered open in that direction. + +<p>At the end of each report appears a "CSV" link. It downloads a file with the +TAB-separated values generated by this report. + +</body> +</html> diff --git a/doc/apply b/doc/apply @@ -0,0 +1,30 @@ + Apply/Mapping + + + ApplyBody + | + V + +-----+-----+ + | / | | | + +-----+--+--+ + | + +-----------+ + | + | +--------------------------+ + | | | + | +--------------------------+ | + | | | | | + | V V | | + | +-----+-----+ +-----+--+--+ +-----+--+--+ + | | | | / | | | | | | | | | | | <-- ApplyArgs + | +--+--+-----+ +--+--+-----+ +--+--+-----+ + | | | | + | V V V + | +-----+-----+ +-----+-----+ +-----+-----+ + +------> | | | ---+---> | | | ---+---> | | | / | + +--+--+-----+ +--+--+-----+ +--+--+-----+ + | | | + V V V + +-----+-----+ +-----+-----+ +-----+-----+ + | 1 | / | | 2 | / | | 3 | / | + +-----+-----+ +-----+-----+ +-----+-----+ diff --git a/doc/db b/doc/db @@ -0,0 +1,91 @@ + Max DB-Size: 7 digits -> 2**42 (4 Tera) Blocks + Blocksize 64 -> (2**48 Bytes (256 TB)) + + Tree + NIL -> (val *DB) + {x} -> (val '{x}) + (var . {x}) -> (get '{x} 'var) + (var . +Cls) -> (get *DB '+Cls 'var) + (var +Cls . {x}) -> (get '{x} '+Cls 'var) + + B-Tree root: + (cnt . node) + + B-Tree node: + (less (key more . value) (key more . value) ..) + + Per node + <Link> BEG EXTERN <6> .. NIX + 6+1+1+6+1 = 15 + + Per key + BEG TRANSIENT <key> EXTERN <7> DOT EXTERN <7> + 1+1+<key>+1+6+1+1+7 = 18 + <key> + + + Key Arguments for DB- and Pilog-functions: + + 123, {abc} -> (123) (123 . T) + T -> All + "abc" -> ("abc") ("abcT" . T) + + (a b) -> (a b) (a b . T) + ((a 1) b 2) -> (a 1) (b 2 . T) + + (a . b) -> (a) (b . T) + (b . a) -> (b . T) (a) + + + loaded/dirty/deleted + + | | | | + | (1) | (2) | (3) | + | | | | + ---------+-----------------+-----------------+-----------------+ + | load | load | empty | + NIL | -> loaded | -> dirty | -> deleted | + | | | | + ---------+-----------------+-----------------+-----------------+ + | | | empty | + loaded | | -> dirty | -> deleted | + | | | | + ---------+-----------------+-----------------+-----------------+ + | | | empty | + dirty | | | -> deleted | + | | | | + ---------+-----------------+-----------------+-----------------+ + | | | | + deleted | | | | + | | | | + + + | | | + | commit | rollback | + | | | + -------------+-----------------+-----------------+ + | | | + NIL | | | + | | | + -------------+-----------------+-----------------+ + | | empty | + (1) loaded | | -> NIL | + | | | + -------------+-----------------+-----------------+ + | save | empty | + (2) dirty | -> loaded | -> NIL | + | | | + -------------+-----------------+-----------------+ + | empty | empty | + (3) deleted | -> NIL | -> NIL | + | | | + + + + +-----+-----+ + | V1 | | | + +-----+--+--+ + | + V + +-----+-----+ +-----+-----+ + | P1 | ---+---> | N | ---+---> @@ + +-----+-----+ +-----+-----+ diff --git a/doc/doc.css b/doc/doc.css @@ -0,0 +1,12 @@ +/* 19may07abu + * (c) Software Lab. Alexander Burger + */ + +body { + margin-left: 80px; + margin-right: 60px +} + +code { + color: rgb(0%,40%,0%); +} diff --git a/doc/family.l b/doc/family.l @@ -0,0 +1,242 @@ +# 04feb10abu +# (c) Software Lab. Alexander Burger + +(load "lib/http.l" "lib/xhtml.l" "lib/form.l" "lib/ps.l") + +### DB ### +(class +Person +Entity) +(rel nm (+Need +Sn +Idx +String)) # Name +(rel pa (+Joint) kids (+Man)) # Father +(rel ma (+Joint) kids (+Woman)) # Mother +(rel mate (+Joint) mate (+Person)) # Partner +(rel job (+Ref +String)) # Occupation +(rel dat (+Ref +Date)) # born +(rel fin (+Ref +Date)) # died +(rel txt (+String)) # Info + +(dm url> (Tab) + (list "@person" '*ID This) ) + + +(class +Man +Person) +(rel kids (+List +Joint) pa (+Person)) # Children + +(class +Woman +Person) +(rel kids (+List +Joint) ma (+Person)) # Children + +(dbs + (0) # (1 . 64) + (2 +Person) # (2 . 256) + (3 (+Person nm)) # (3 . 512) + (3 (+Person job dat fin)) ) # (4 . 512) + + +### GUI ### +(de choPerson (Dst) + (diaform '(Dst) + (<grid> "--.-.-." + "Name" (gui 'nm '(+Focus +Var +TextField) '*PrsNm 20) + "Occupation" (gui 'job '(+Var +TextField) '*PrsJob 20) + "born" (prog + (gui 'dat1 '(+Var +DateField) '*PrsDat1 10) + (gui 'dat2 '(+Var +DateField) '*PrsDat2 10) ) + (searchButton '(init> (: home query))) + "Father" (gui 'pa '(+Var +TextField) '*PrsPa 20) + "Mother" (gui 'ma '(+Var +TextField) '*PrsMa 20) + "Partner" (gui 'mate '(+Var +TextField) '*PrsMate 20) + (resetButton '(nm pa ma mate job dat1 dat2 query)) ) + (gui 'query '(+QueryChart) (cho) + '(goal + (quote + @Nm *PrsNm + @Pa *PrsPa + @Ma *PrsMa + @Mate *PrsMate + @Job *PrsJob + @Dat (and (or *PrsDat1 *PrsDat2) (cons *PrsDat1 (or *PrsDat2 T))) + (select (@@) + ((nm +Person @Nm) + (nm +Person @Pa kids) + (nm +Person @Ma kids) + (nm +Person @Mate mate) + (job +Person @Job) + (dat +Person @Dat) ) + (tolr @Nm @@ nm) + (tolr @Pa @@ pa nm) + (tolr @Ma @@ ma nm) + (tolr @Mate @@ mate nm) + (head @Job @@ job) + (range @Dat @@ dat) ) ) ) + 7 + '((This) (list This This (: pa) (: ma) (: mate) (: job) (: dat))) ) + (<table> 'chart NIL + '((btn) (NIL "Name") (NIL "Father") (NIL "Mother") (NIL "Partner") (NIL "Occupation") (NIL "born")) + (do (cho) + (<row> (alternating) + (gui 1 '(+DstButton) Dst) + (gui 2 '(+ObjView +TextField) '(: nm)) + (gui 3 '(+ObjView +TextField) '(: nm)) + (gui 4 '(+ObjView +TextField) '(: nm)) + (gui 5 '(+ObjView +TextField) '(: nm)) + (gui 6 '(+TextField)) + (gui 7 '(+DateField)) ) ) ) + (<spread> + (scroll (cho)) + (<nbsp> 4) + (prin "Man") + (newButton T Dst '(+Man) 'nm *PrsNm) + (<nbsp>) + (prin "Woman") + (newButton T Dst '(+Woman) 'nm *PrsNm) + (<nbsp> 4) + (cancelButton) ) ) ) + +# Person HTML Page +(de person () + (app) + (action + (html 0 (get (default *ID (val *DB)) 'nm) "lib.css" NIL + (form NIL + (<h2> NIL (<id> (: nm))) + (panel T "Person '@1'" T '(choPerson) 'nm '+Person) + (<p> NIL + (gui '(+E/R +TextField) '(nm : home obj) 40 "Name") + (gui '(+ClassField) '(: home obj) '(("Male" +Man) ("Female" +Woman))) ) + (<grid> 5 + "Occupation" (gui '(+E/R +TextField) '(job : home obj) 20) + "Father" (gui '(+ChoButton) '(choPerson (field 1))) + (gui '(+E/R +Obj +TextField) '(pa : home obj) '(nm +Man) 30) + "born" (gui '(+E/R +DateField) '(dat : home obj) 10) + "Mother" (gui '(+ChoButton) '(choPerson (field 1))) + (gui '(+E/R +Obj +TextField) '(ma : home obj) '(nm +Woman) 30) + "died" (gui '(+E/R +DateField) '(fin : home obj) 10) + "Partner" (gui '(+ChoButton) '(choPerson (field 1))) + (gui '(+E/R +Obj +TextField) '(mate : home obj) '(nm +Person) 30) ) + (gui '(+E/R +Chart) '(kids : home obj) 5 + '((This) (list NIL This (: dat) (: pa) (: ma))) + cadr ) + (<table> NIL NIL + '(NIL (NIL "Children") (NIL "born") (NIL "Father") (NIL "Mother")) + (do 4 + (<row> NIL + (gui 1 '(+ChoButton) '(choPerson (field 1))) + (gui 2 '(+Obj +TextField) '(nm +Person) 20) + (gui 3 '(+E/R +DateField) '(dat curr) 10) + (gui 4 '(+ObjView +TextField) '(: nm) 20) + (gui 5 '(+ObjView +TextField) '(: nm) 20) ) ) + (<row> NIL NIL (scroll 4)) ) + (----) + (gui '(+E/R +TextField) '(txt : home obj) 40 4) + (gui '(+Rid +Button) "Contemporaries" + '(url "@contemporaries" (: home obj)) ) + (gui '(+Rid +Button) "Tree View" + '(url "@treeReport" (: home obj)) ) + (editButton T) ) ) ) ) + + +### Reports ### +# Show all contemporaries of a person +(de contemporaries (*ID) + (action + (html 0 "Contemporaries" "lib.css" NIL + (form NIL + (<h3> NIL (<id> "Contemporaries of " (: nm))) + (ifn (: obj dat) + (<h3> NIL (ht:Prin "No birth date for " (: obj nm))) + (gui '(+QueryChart) 12 + '(goal + (quote + @Obj (: home obj) + @Dat (: home obj dat) + @Beg (- (: home obj dat) 36525) + @Fin (or (: home obj fin) (+ (: home obj dat) 36525)) + (db dat +Person (@Beg . @Fin) @@) + (different @@ @Obj) + (@ >= (get (-> @@) 'fin) (-> @Dat)) + (@ <= (get (-> @@) 'dat) (-> @Fin)) ) ) + 7 + '((This) + (list This (: job) (: dat) (: fin) (: pa) (: ma) (: mate)) ) ) + (<table> NIL (pack (datStr (: obj dat)) " - " (datStr (: obj fin))) + (quote + (NIL "Name") (NIL "Occupation") (NIL "born") (NIL "died") + (NIL "Father") (NIL "Mother") (NIL "Partner") ) + (do 12 + (<row> NIL + (gui 1 '(+ObjView +TextField) '(: nm)) + (gui 2 '(+TextField)) + (gui 3 '(+DateField)) + (gui 4 '(+DateField)) + (gui 5 '(+ObjView +TextField) '(: nm)) + (gui 6 '(+ObjView +TextField) '(: nm)) + (gui 7 '(+ObjView +TextField) '(: nm)) ) ) ) + (scroll 12) + (----) + (gui '(+Rid +Button) "Textfile" + '(let Txt (tmp "Contemporaries.txt") + (out Txt (txt> (chart))) + (url Txt) ) ) + (gui '(+Rid +Button) "PDF" + '(psOut NIL "Contemporaries" + (out (tmp "Contemporaries.txt") + (txt> (chart)) ) + (in (tmp "Contemporaries.txt") + (let (Page 1 Fmt (200 120 50 50 120 120 120) Ttl (line T)) + (a4L) + (font (7 . "Helvetica")) + (indent 30 10) + (down 12) + (font 9 (ps Ttl)) + (down 12) + (table Fmt + "Name" "Occupation" "born" "died" "Father" "Mother" "Partner" ) + (down 6) + (pages 560 + (page T) + (down 12) + (ps (pack Ttl ", Page " (inc 'Page))) + (down 12) ) + (until (eof) + (let L (split (line) "^I") + (down 8) + (table Fmt + (font "Helvetica-Bold" (ps (head 50 (car L)))) + (ps (head 30 (cadr L))) + (ps (get L 3)) + (ps (get L 4)) + (ps (head 30 (get L 5))) + (ps (head 30 (get L 6))) + (ps (head 30 (get L 7))) ) + (down 4) ) ) ) ) + (page) ) ) ) ) ) ) ) + +# Tree display of a person's descendants +(de treeReport (This) + (html 0 "Family Tree View" "lib.css" NIL + (<h3> NIL "Family Tree View") + (<ul> NIL + (recur (This) + (when (try 'url> This 1) + (<li> NIL + (<href> (: nm) (mkUrl @)) + (when (try 'url> (: mate) 1) + (prin " -- ") + (<href> (: mate nm) (mkUrl @)) ) ) + (when (: kids) + (<ul> NIL (mapc recurse (: kids))) ) ) ) ) ) ) + +### RUN ### +(de main () + (pool "doc/family/" *Dbs) + (unless (val *DB) + (put> + (set *DB (request '(+Man) 'nm "Adam")) + 'mate + (request '(+Woman) 'nm "Eve") ) + (commit) ) ) + +(de go () + (rollback) + (server 8080 "@person") ) + +# vi:et:ts=3:sw=3 diff --git a/doc/family/1 b/doc/family/1 Binary files differ. diff --git a/doc/family/2 b/doc/family/2 Binary files differ. diff --git a/doc/family/3 b/doc/family/3 Binary files differ. diff --git a/doc/family/4 b/doc/family/4 Binary files differ. diff --git a/doc/faq.html b/doc/faq.html @@ -0,0 +1,664 @@ +<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.0 Transitional//EN" "http://www.w3.org/TR/1998/REC-html40-19980424/loose.dtd"> +<html lang="en"> +<head> +<meta http-equiv="Content-Type" content="text/html; charset=utf-8"> +<title>PicoLisp FAQ</title> +<link rel="stylesheet" href="doc.css" type="text/css"> +</head> +<body> +<a href="mailto:abu@software-lab.de">abu@software-lab.de</a> + +<p align=right> +<i>Monk: "If I have nothing in my mind, what shall I do?"</i><br> +<i>Joshu: "Throw it out."</i><br> +<i>Monk: "But if there is nothing, how can I throw it out?"</i><br> +<i>Joshu: "Well, then carry it out."</i><br> +<i>(Zen koan)</i><br> + +<h1>PicoLisp Frequently Asked Questions</h1> + +<p align=right>(c) Software Lab. Alexander Burger + +<p><ul> +<li><a href="#yet">Why did you write yet another Lisp?</a> +<li><a href="#who">Who can use PicoLisp?</a> +<li><a href="#advantages">What are the advantages over other Lisp systems?</a> +<li><a href="#performance">How is the performance compared to other Lisp systems?</a> +<li><a href="#interpreted">What means "interpreted"?</a> +<li><a href="#compiler">Is there (or will be in the future) a compiler available?</a> +<li><a href="#portable">Is it portable?</a> +<li><a href="#webServer">Is PicoLisp a web server?</a> +<li><a href="#lambda">I cannot find the LAMBDA keyword in PicoLisp</a> +<li><a href="#dynamic">Why do you use dynamic variable binding?</a> +<li><a href="#problems">Are there no problems caused by dynamic binding?</a> +<li><a href="#closures">But with dynamic binding I cannot implement closures!</a> +<li><a href="#macros">Do you have macros?</a> +<li><a href="#strings">Why are there no strings?</a> +<li><a href="#arrays">What about arrays?</a> +<li><a href="#bind">What happens when I locally bind a symbol which has a function definition?</a> +<li><a href="#hardware">Would it make sense to build PicoLisp in hardware?</a> +<li><a href="#ask">Where can I ask questions?</a> +</ul> + +<p><hr> +<h2><a name="yet">Why did you write yet another Lisp?</a></h2> + +<p>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. + + +<p><hr> +<h2><a name="who">Who can use PicoLisp?</a></h2> + +<p>PicoLisp is for programmers who want to control their programming +environment, at all levels, from the application domain down to the bare metal. +Who want use a transparent and simple - yet universal - programming model, and +want to know exactly what is going on. This is an aspect influenced by Forth. + +<p>It does <i>not</i> pretend to be easy to learn. There are already plenty of +languages that do so. It is not for people who don't care what's under the hood, +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. + + +<p><hr> +<h2><a name="advantages">What are the advantages over other Lisp systems?</a></h2> + +<h3>Simplicity</h3> +<p>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. + +<h3>A Clear Model</h3> +<p>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. + +<p>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 <a href="ref.html#vm">The +PicoLisp Machine</a> in the reference manual. + +<h3>Orthogonality</h3> +<p>There is only one symbolic data type, no distinction (confusion) between +symbols, strings, variables, special variables and identifiers. + +<p>Most data-manipulation functions operate on the value cells of symbols as +well as the CARs of list cells: + +<pre><code> +: (let (N 7 L (7 7 7)) (inc 'N) (inc (cdr L)) (cons N L)) +-> (8 7 8 7) +</code></pre> + +<p>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 + +<pre><code> +: (mapcar if '(T NIL T NIL) '(1 2 3 4) '(5 6 7 8)) +-> (1 6 3 8) +</code></pre> + +<p>PicoLisp has no such restrictions. It favors the principle of "Least +Astonishment". + +<h3>Object System</h3> +<p>The OOP system is very powerful, because it is fully dynamic, yet extremely +simple: + +<p><ul> +<li>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. + +<li>The multiple inheritance is such that not only classes can have several +superclasses, but each individual object can be of more than one class. + +<li>Prefix classes can surgically change the inheritance tree for any class or +object. They behave like Mixins in this regard. + +<li>Fine-control of inheritance in methods with <code><a +href="refS.html#super">super</a></code> and <code><a +href="refE.html#extra">extra</a></code>. + +</ul> + +<h3>Pragmatism</h3> +<p>PicoLisp has many practical features not found in other Lisp dialects. Among +them are: + +<p><ul> +<li>Auto-quoting of lists when the CAR is a number. Instead of <code>'(1 2 +3)</code> you can just write <code>(1 2 3)</code>. This is possible because a +number never makes sense as a function name, and has to be checked at runtime +anyway. + +<li>The <code><a href="refQ.html#quote">quote</a></code> function returns all +unevaluated arguments, instead of just the first one. This is both faster +(<code>quote</code> does not have to take the CAR of its argument list) and +smaller (a single cell instead of two). For example, <code>'A</code> expands to +<code>(quote . A)</code> and <code>'(A B C)</code> expands to <code>(quote A B +C)</code>. + +<li>The symbol <code><a href="ref.html#atres">@</a></code> 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. + +<li><a href="tut.html#funio">Functional I/O</a> is more convenient than +explicitly passing around file descriptors. + +<li>A well-defined <a href="ref.html#cmp">ordinal relationship</a> between +arbitrary data types facilitates generalized comparing and sorting. + +<li>Uniform handling of <code>var</code> locations (i.e. values of symbols and +CARs of list cells). + +<li>The universality and usefulness of symbol properties is enforced and +extended with implicit and explicit bindings of the symbol <code><a +href="refT.html#This">This</a></code> in combination with the access functions +<code><a href="ref_.html#=:">=:</a></code>, <code><a +href="ref_.html#:">:</a></code> and <code><a href="ref_.html#::">::</a></code>. + +<li>A very convenient list-building machinery, using the <code><a +href="refL.html#link">link</a></code>, <code><a +href="refY.html#yoke">yoke</a></code>, <code><a +href="refC.html#chain">chain</a></code> and <code><a +href="refM.html#made">made</a></code> functions in the <code><a +href="refM.html#make">make</a></code> environment. + +<li>The syntax of often-used functions is kept non-verbose. For example, instead +of <code>(let ((A 1) (B 2) C 3) ..)</code> you write <code>(let (A 1 B 2 C 3) +..)</code>, or just <code>(let A 1 ..)</code> if there is only a single +variable. + +<li>The use of the hash (<code>#</code>) as a comment character is more adequate +today, and allows a clean hash-bang (<code>#!</code>) syntax for stand-alone +scripts. + +<li>The interpreter is <a href="ref.html#invoc">invoked</a> 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 <a href="tut.html#script">script</a>. + +<li>A sophisticated system of interprocess communication, file locking and +synchronization allows multi-user access to database applications. + +<li>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 <code>select</code> can be used in database +queries. + +</ul> + +<h3>Persistent Symbols</h3> +<p>Database objects ("external" symbols) are a primary data type in PicoLisp. +They look like normal symbols to the programmer, but are managed (fetched from, +and stored to, the data base) automatically by the system. Symbol manipulation +functions like <code>set</code>, <code>put</code> or <code>get</code>, the +garbage collector, and other parts of the interpreter know about them. + +<h3>Application Server</h3> +<p>Stand-alone system: Does not depend on external programs like Apache or +MySQL. Provides a "live" user interface on the client side, with an application +server session for each connected client. The GUI layout and behavior is +described with s-expressions, generated dynamically at runtime, and interacts +directly with the database structures. + +<h3>Localization</h3> +<p>Internal exclusive and full use of UTF-8 encoding, and self-translating <a +href="ref.html#transient-io">transient symbols</a> (strings), make it easy to +write country- and language-independent applications. + + +<p><hr> +<h2><a name="performance">How is the performance compared to other Lisp systems?</a></h2> + +<p>Despite the fact that PicoLisp is an interpreted-only system, the performance +is quite good. Typical Lisp programs, operating on list data structures, execute +in (interpreted) PicoLisp at about the same speed as in (compiled) CMUCL, and +about two or three times faster than in CLisp or Scheme48. Programs with lots of +numeric calculations, however, are several times slower, mainly due to +PicoLisp's somewhat inefficient implementation of bignums in the 32-bit version. + +<p>But in practice, speed was never a problem, even with the first versions of +PicoLisp in 1988 on a Mac II with a 12 MHz CPU. And certain things are cleaner +and easier to do in plain C anyway. It is very easy to write C functions in +PicoLisp, either in the kernel, as shared object libraries, or even inline in +the Lisp code. + +<p>PicoLisp is very space-effective. Other Lisp systems reserve heap space twice +as much as needed, or use rather large internal structures to store cells and +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. + + +<p><hr> +<h2><a name="interpreted">What means "interpreted"?</a></h2> + +<p>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. + +<p>Lisp data are the "real" things, like numbers, symbols and lists, which can +be directly handled by the system. They are <i>not</i> the textual +representation of these structures (which is outside the Lisp realm and taken +care of the <code><a href="refR.html#read">read</a></code>ing and <code><a +href="refP.html#print">print</a></code>ing interfaces). + +<p>The following example builds a function and immediately calls it with two +arguments: + +<pre><code> +: ((list (list 'X 'Y) (list '* 'X 'Y)) 3 4) +-> 12 +</code></pre> + +<p>Note that no time is wasted to build up a lexical environment. Variable +bindings take place dynamically during interpretation. + +<p>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: + +<pre><code> +(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 +</code></pre> + +<p>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. + + +<p><hr> +<h2><a name="compiler">Is there (or will be in the future) a compiler available?</a></h2> + +<p>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 very much 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. + + +<p><hr> +<h2><a name="portable">Is it portable?</a></h2> + +<p>Yes and No. Though we wrote and tested PicoLisp originally only on Linux, it +now also runs on FreeBSD, Mac OS X (Darwin), Cygwin/Win32, and probably 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? + +<p>The GUI is completely platform independent (Browser), and in the times of +Internet an application <u>server</u> does not really need to be portable. + + +<p><hr> +<h2><a name="webServer">Is PicoLisp a web server?</a></h2> + +<p>Not really, but it evolved a great deal into that direction. + +<p>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. + +<p>In a sense, PicoLisp is a "pure" application server, not a web server +handling "web applications". + + +<p><hr> +<h2><a name="lambda">I cannot find the LAMBDA keyword in PicoLisp</a></h2> + +<p>Because it isn't there. The reason is that it is redundant; it is equivalent +to the <code>quote</code> function in any aspect, because there's no distinction +between code and data in PicoLisp, and <code>quote</code> returns the whole +(unevaluated) argument list. If you insist on it, you can define your own +<code>lambda</code>: + +<pre><code> +: (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) +</code></pre> + + +<p><hr> +<h2><a name="dynamic">Why do you use dynamic variable binding?</a></h2> + +<p>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. + +<p>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 +<code>labels</code> to extend the scope of variables beyond a single function. + +<p>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: + +<pre><code> +(de recur recurse + (run (cdr recurse)) ) +</code></pre> + +<p>It implements anonymous recursion, by defining <code>recur</code> statically +and <code>recurse</code> 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 <code>recur</code> and <code>recurse</code> you can simply +write: + +<pre><code> +: (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) +</code></pre> + +<p>Needless to say, the call to <code>recurse</code> does not have to reside in +the same function as the corresponding <code>recur</code>. Can you implement +anonymous recursion so elegantly with lexical binding? + + +<p><hr> +<h2><a name="problems">Are there no problems caused by dynamic binding?</a></h2> + +<p>You mean the <i>funarg</i> problem, or problems that arise when a variable +might be bound to <i>itself</i>? For that reason we have a convention in +PicoLisp to use <a href="ref.html#transient-io">transient symbols</a> (instead +of internal symbols) + +<ol> + +<li>for all parameters and locals, when functional arguments or executable lists +are passed through the current dynamic bindings + +<li>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 + +</ol> + +<p>This is a form of lexical <i>scoping</i> - though we still have dynamic +<i>binding</i> - of symbols, similar to the <code>static</code> keyword in C. + +<p>In fact, these problems are a real threat, and may lead to mysterious bugs +(other Lisps have similar problems, e.g. with symbol capture in macros). They +can be avoided, however, when the above conventions are observed. As an example, +consider a function which doubles the value in a variable: + +<pre><code> +(de double (Var) + (set Var (* 2 (val Var))) ) +</code></pre> + +<p>This works fine, as long as we call it as <code>(double 'X)</code>, but will +break if we call it as <code>(double 'Var)</code>. Therefore, the correct +implementation of <code>double</code> should be: + +<pre><code> +(de double (<u>Var</u>) + (set <u>Var</u> (* 2 (val <u>Var</u>))) ) +</code></pre> + +<p>If <code>double</code> is defined that way in a separate source file, and/or +isolated via the <code><a href="ref_.html#====">====</a></code> function, then +the symbol <code><u>Var</u></code> is locked into a private lexical context +and cannot conflict with other symbols. + +<p>Admittedly, there are two disadvantages with this solution: + +<ol> + +<li>The rules for when to use transient 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. + +<li>The string-like syntax of transient symbols as variables may look strange to +alumni of other languages. Therefore, the use of <a +href="refT.html#*Tsm">transient symbol markup</a> is recommended. + +</ol> + +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. + + +<p><hr> +<h2><a name="closures">But with dynamic binding I cannot implement closures!</a></h2> + +<p>This is not true. Closures are a matter of scope, not of binding. + +<p>For a closure it is necessary to build and maintain an environment. For +lexical bindings, this has <i>always</i> to be done, and in case of 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. + +<p>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. + +<p>You have several options in PicoLisp. For simple cases, you can take +advantage of the static scope of <a href="ref.html#transient-io">transient +symbols</a>. For the general case, PicoLisp has built-in functions like <code><a +href="refB.html#bind">bind</a></code> or <code><a +href="refJ.html#job">job</a></code>, which dynamically manage statically scoped +environments. + +<p>As an example, consider a currying function: + +<pre><code> +(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)) ) ) ) ) ) +</code></pre> + +<p>When called, it returns a function-building function which may be applied to +some argument: + +<pre><code> +: ((curry (X) (N) (* X N)) 3) +-> ((N) (job '((X . 3)) (* X N))) +</code></pre> + +<p>or used as: + +<pre><code> +: (((curry (X) (N) (* X N)) 3) 4) +-> 12 +</code></pre> + +<p>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: + +<pre><code> +(de curry Args + (list + (cadr Args) + (list 'fill + (lit (cons (car Args) (cddr Args))) + (lit (cadr Args)) ) ) ) +</code></pre> + +<p>Then the function built above will just be: + +<pre><code> +: ((curry (X) (N) (* X N)) 3) +-> ((X) (* X 3)) +</code></pre> + +<p>In that case, the "environment build-up" is reduced by a simple (lexical) +constant substitution with zero runtime overhead. + +<p>Note that the actual <code><a href="refC.html#curry">curry</a></code> +function is simpler and more pragmatic. It combines both strategies (to use +<code>job</code>, or to substitute), deciding at runtime what kind of function +to build. + + +<p><hr> +<h2><a name="macros">Do you have macros?</a></h2> + +<p>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. + + +<p><hr> +<h2><a name="strings">Why are there no strings?</a></h2> + +<p>Because PicoLisp has something better: <a +href="ref.html#transient-io">Transient symbols</a>. They look and behave like +strings in any respect, but are nevertheless true symbols, with a value cell and +a property list. + +<p>This leads to interesting opportunities. The value cell, for example, can +point to other data that represent the string's the translation. This is used +extensively for localization. When a program calls + +<pre><code> + (prinl "Good morning!") +</code></pre> + +<p>then changing the value of the symbol <code>"Good morning!"</code> to its +translation will change the program's output at runtime. + +<p>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 (on the 64-bit version) 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 avarage), 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. + +<p>Because transient symbols are temporarily interned (while <code><a +href="refL.html#load">load</a></code>ing 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. + + +<p><hr> +<h2><a name="arrays">What about arrays?</a></h2> + +<p>PicoLisp has no array or vector data type. Instead, lists must be used for +any type of sequentially arranged data. + +<p>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 rather expensive. Access with a known (numeric) +index is not really 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. + +<p>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. + +<p>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. + + +<p><hr> +<h2><a name="bind">What happens when I locally bind a symbol which has a function definition?</a></h2> + +<p>That's not a good idea. The next time that function gets executed within the +dynamic context the system may crash. Therefore we have a convention to use an +upper case first letter for locally bound symbols: + +<pre><code> +(de findCar (Car List) + (when (member Car (cdr List)) + (list Car (car List)) ) ) +</code></pre> + +;-) + + +<p><hr> +<h2><a name="hardware">Would it make sense to build PicoLisp in hardware?</a></h2> + +<p>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. + +<p>Primitive functions like <code>set</code>, <code>val</code>, <code>if</code> +and <code>while</code>, which are written in <Code>C</code> or assembly language +now, would be implemented in microcode. Plus a few I/O functions for hardware +access. <code>EVAL</code> itself would be a microcode subroutine. + +<p>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. + +<p>There would be no assembly-language. The lowest level (above the hardware and +microcode levels) are s-expressions: The machine language is <i>Lisp</i>. + + +<p><hr> +<h2><a name="ask">Where can I ask questions?</a></h2> + +<p>The best place is the <a +href="mailto:picolisp@software-lab.de?subject=Subscribe">PicoLisp Mailing +List</a> (see also <a +href="http://www.mail-archive.com/picolisp@software-lab.de/">The Mail +Archive</a>), or the IRC <a href="irc://irc.freenode.net/picolisp">#picolisp</a> +channel on FreeNode.net. + +</body> +</html> diff --git a/doc/fun.l b/doc/fun.l @@ -0,0 +1,9 @@ +# 25jun07abu +# (c) Software Lab. Alexander Burger + +(de fact (N) + (if (=0 N) + 1 + (* N (fact (dec N))) ) ) + +# vi:et:ts=3:sw=3 diff --git a/doc/hello.l b/doc/hello.l @@ -0,0 +1,5 @@ +(load "lib/xhtml.l") + +(html 0 "Hello" NIL NIL + (<h3> NIL "Hello world") + "This is PicoLisp" ) diff --git a/doc/index.html b/doc/index.html @@ -0,0 +1,108 @@ +<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN" + "http://www.w3.org/TR/html4/loose.dtd"> +<html> +<head> + <meta http-equiv="content-type" content="text/html; charset=utf-8"> + <title>PicoLisp Docs</title> + <meta name="generator" content="BBEdit 8.6"> + <script type="text/javascript" language="javascript"> + <!-- +function frameIdAsVariable(aFrame) { + // IE hack + // http://www.greymagic.com/security/advisories/gm011-ie/ + if (aFrame.name == "toc") return tocfid; + if (aFrame.name == "upper") return upfid; +} + +function contentDoc(aFrame) { + if (aFrame.contentDocument) { + return aFrame.contentDocument; + } else { + var fid = frameIdAsVariable(aFrame); + if (fid) { + return fid.document; + } + } + alert("Couldn't access a frame's document for this kind of browser."); +} + +function doTocSublists(upDoc) { + var tocDoc = contentDoc(document.getElementById("tocfid")); + var ul = tocDoc.getElementById("upperul"); + var oldExp = null; + var newSub = null; + for (var i=0; i<ul.childNodes.length; i++) { + var cni = ul.childNodes[i]; + if (cni.firstChild) { + // cni.firstChild is an anchor + if (cni.firstChild.href == upDoc.URL) { + // Found TOC anchor that matches upper document + if (upDoc.URL.indexOf("#") < 0) { + if (cni.lastChild.nodeName != "UL") { + // Expansion required, making sub-list ... + newSub = tocDoc.createElement("ul"); + newSub.className = "sub"; + for (var j=0; j<upDoc.anchors.length; j++) { + var ajText = null; + if (upDoc.anchors[j].innerText) { + ajText = upDoc.anchors[j].innerText; + } else if (upDoc.anchors[j].text) { + ajText = upDoc.anchors[j].text; + } + if (ajText) { + var li = tocDoc.createElement("li"); + var a = tocDoc.createElement("a"); + a.href = upDoc.URL + "#" + upDoc.anchors[j].name; + a.target = "upper"; + a.appendChild(tocDoc.createTextNode(ajText)); + li.appendChild(a); + newSub.appendChild(li); + } + } + cni.appendChild(newSub); + } + } + } else if (cni.lastChild.nodeName == "UL") { + oldExp = cni; + } + } + } + if ((oldExp != null) && (newSub != null)) { + // Remove old sub-list to save TOC space ... + oldExp.removeChild(oldExp.lastChild); + } +} + +function upperLoad(upperFrame) { + try { + var upDoc = contentDoc(upperFrame); + // First modify the targets of the ref anchors ... + var anchors = upDoc.getElementsByTagName("a"); + for (var i=0; i<anchors.length; i++) { + var ai = anchors[i]; + if (ai.href.match(/\/ref\w\.html/)) { + ai.target = "lower"; + } + } + doTocSublists(upDoc); + } catch (e) { + alert(e); + } +} + //--> +</script> +</head> +<frameset cols="15%,85%"> + <frameset rows="*,80"> + <frame id="tocfid" name="toc" src="toc.html"> + <frame name="reflook" src="rlook.html"> + </frameset> + + <frameset rows="50%,50%"> + <frame id="upfid" name="upper" src="ref.html#fun" onload="upperLoad(this);"> + <frame name="lower" src="ref.html"> + </frameset> + +</frameset> + +</html> diff --git a/doc/model b/doc/model @@ -0,0 +1,57 @@ +# 20aug04abu +# (c) Software Lab. Alexander Burger + +Sym Val -> Model list: +( + pos.x pos.y pos.z # Position + rot.a.x rot.a.y rot.a.z # Orientation + rot.b.x rot.b.y rot.b.z + rot.c.x rot.c.y rot.c.z + sym # Submodel + .. + (col1 col2 ["text"] p1.x p1.y p1.z p2.x p2.y p2.z ..) # Face + .. + sym # Submodel + .. + (col1 col2 p1.x p1.y p1.z p2.x p2.y p2.z p3.x p3.y p3.z ..) # Face + .. +) + +<col> <col> # Both sides visible +<col> NIL # Backface culling + NIL <col> # Foreside culling + NIL NIL # Transparent + NIL T # Shadow + + +Transmission format: + hor sky gnd + cnt x y z "text" x y z x y z .. col + cnt x y z NIL x y z x y z x y z .. col + .. + 0 32767 | 0 snx sny + +Transmission size: + (4 + 2 * polygons + 3 * points) * 4 bytes + + +Polygon design rules: + +- All polygons should be convex + (split concave polygons if necessary) + +- Points loop right when seen from the front side + (if the two faces should have different colors) + +- The first three points must not be on a straight line + (to allow the calculation of the normal vector) + +- The first point cannot be the local origin + (if 'aRot' is to be used) + + +z3dField .graf +((x y . "string") ..) + +Transmission format: + cnt x y "string" .. diff --git a/doc/quine b/doc/quine @@ -0,0 +1,24 @@ +With lambda (= 'quote'): + : ('((X) (list (lit X) (lit X))) '((X) (list (lit X) (lit X)))) + -> ('((X) (list (lit X) (lit X))) '((X) (list (lit X) (lit X)))) + + +With 'let': + : (let X '(list 'let 'X (lit X) X) (list 'let 'X (lit X) X)) + -> (let X '(list 'let 'X (lit X) X) (list 'let 'X (lit X) X)) + + +Cheating: + : (de quine NIL + (pp 'quine) ) + -> quine + + : (quine) + (de quine NIL + (pp 'quine) ) + -> quine + + +Succinct: + : T + -> T diff --git a/doc/ref.html b/doc/ref.html @@ -0,0 +1,2455 @@ +<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.0 Transitional//EN" "http://www.w3.org/TR/1998/REC-html40-19980424/loose.dtd"> +<html lang="en"> +<head> +<meta http-equiv="Content-Type" content="text/html; charset=utf-8"> +<title>PicoLisp Reference</title> +<link rel="stylesheet" href="doc.css" type="text/css"> +</head> +<body> +<a href="mailto:abu@software-lab.de">abu@software-lab.de</a> + +<p align=right> +<i>Perfection is attained</i><br> +<i>not when there is nothing left to add</i><br> +<i>but when there is nothing left to take away</i><br> +<i>(Antoine de Saint-Exupéry)</i><br> + + +<h1>The PicoLisp Reference</h1> + +<p align=right>(c) Software Lab. Alexander Burger + +<p>This document describes the concepts, data types, and kernel functions of the +<a href="http://software-lab.de/down.html">PicoLisp</a> system. + +<p>This is <i>not</i> 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). + +<p>Please take a look at the <a href="tut.html">PicoLisp Tutorial</a> for an +explanation of some aspects of PicoLisp, and scan through the list of <a +href="faq.html">Frequently Asked Questions (FAQ)</a>. + +<p><ul> +<li><a href="#intro">Introduction</a> +<li><a href="#vm">The PicoLisp Machine</a> + <ul> + <li><a href="#cell">The Cell</a> + <li><a href="#data">Data Types</a> + <ul> + <li><a href="#number">Numbers</a> + <li><a href="#symbol">Symbols</a> + <ul> + <li><a href="#nilSym">NIL</a> + <li><a href="#internal">Internal Symbols</a> + <li><a href="#transient">Transient Symbols</a> + <li><a href="#external">External Symbols</a> + </ul> + <li><a href="#lst">Lists</a> + </ul> + <li><a href="#mem">Memory Management</a> + </ul> +<li><a href="#penv">Programming Environment</a> + <ul> + <li><a href="#invoc">Invocation</a> + <li><a href="#io">Input/Output</a> + <ul> + <li><a href="#num-io">Numbers</a> + <li><a href="#sym-io">Symbols</a> + <ul> + <li><a href="#nilSym-io">NIL</a> + <li><a href="#internal-io">Internal Symbols</a> + <li><a href="#transient-io">Transient Symbols</a> + <li><a href="#external-io">External Symbols</a> + </ul> + <li><a href="#lst-io">Lists</a> + <li><a href="#macro-io">Read-Macros</a> + </ul> + <li><a href="#ev">Evaluation</a> + <li><a href="#int">Interrupt</a> + <li><a href="#errors">Error Handling</a> + <li><a href="#atres">@ Result</a> + <li><a href="#cmp">Comparing</a> + <li><a href="#oop">OO Concepts</a> + <li><a href="#dbase">Database</a> + <ul> + <li><a href="#trans">Transactions</a> + <li><a href="#er">Entities / Relations</a> + </ul> + <li><a href="#pilog">Pilog (PicoLisp Prolog)</a> + <li><a href="#conv">Naming Conventions</a> + <li><a href="#trad">Breaking Traditions</a> + <li><a href="#bugs">Bugs</a> + </ul> +<li><a href="#fun">Function Reference</a> +<li><a href="#down">Download</a> +</ul> + + +<p><hr> +<h2><a name="intro">Introduction</a></h2> + +<p>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. + +<p>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: <i>Form Follows +Function</i>. + +<p>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. + +<p>In a nutshell, emphasis was put on four design objectives. The PicoLisp +system should be + +<p><dl> + +<dt>Simple +<dd>The internal data structure should be as simple as possible. Only one single +data structure is used to build all higher level constructs. + +<dt>Unlimited +<dd>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. + +<dt>Dynamic +<dd>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. + +<dt>Practical +<dd>PicoLisp is not just a toy of theoretical value. It is in use since 1988 in +actual application development, research and production. + +</dl> + + +<p><hr> +<h2><a name="vm">The PicoLisp Machine</a></h2> + +<p>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. + +<p>This is similar to assembly language programming, where the programmer has +complete control over the machine. + + +<p><hr> +<h3><a name="cell">The Cell</a></h3> + +<p>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": + +<pre><code> + +-----+-----+ + | CAR | CDR | + +-----+-----+ +</code></pre> + +<p>A cell is a pair of 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. + +<p>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 a pointer size of typically 4 bytes, each cell has a size of 8 bytes. +Therefore, the pointer to a cell must point to an 8-byte boundary, and its +bit-representation will look like: + +<pre><code> + xxxxxxxxxxxxxxxxxxxxxxxxxxxxx000 +</code></pre> + +<p>(the <code>'x'</code> means "don't care"). For the individual data types, the +pointer is adjusted to point to other parts of a cell, in effect setting some of +the lower three bits to non-zero values. These bits are then used by the +interpreter to determine the data type. + +<p>In any case, bit(0) - the least significant of these bits - is reserved as a +mark bit for garbage collection. + +<p>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). + + +<p><hr> +<h3><a name="data">Data Types</a></h3> + +<p>On the virtual machine level, PicoLisp supports + +<p><ul> +<li>three base data types: Numbers, Symbols and Cons Pairs (Lists) +<li>the three scope variations of symbols: Internal, Transient and External +<li>and the special symbol <code>NIL</code>. +</ul> + +<p>They are all built from the single cell data structure, and all runtime data +cannot consist of any other types than these three. + +<p>The following diagram shows the complete data type hierarchy, consisting of +the three base types and the symbol variations: + +<pre><code> + cell + | + +--------+--------+ + | | | + Number Symbol List + | + | + +--------+--------+--------+ + | | | | + NIL Internal Transient External +</code></pre> + + +<p><hr> +<h4><a name="number">Numbers</a></h4> + +<p>A number can represent a signed integral value of arbitrary size. The CARs of +one or more cells hold the number's "digits" (each in the machine's word size), +to store the number's binary representation. + +<pre><code> + Number + | + V + +-----+-----+ +-----+-----+ +-----+-----+ + |'DIG'| ---+---> |'DIG'| ---+---> |'DIG'| / | + +-----+-----+ +-----+-----+ +-----+-----+ +</code></pre> + +<p>The first cell holds the least significant digit. The least significant bit +of that digit represents the sign. + +<p>The pointer to a number points into the middle of the CAR, with an offset of +2 from the cell's start address. Therefore, the bit pattern of a number will be: + +<pre><code> + xxxxxxxxxxxxxxxxxxxxxxxxxxxxx010 +</code></pre> + +<p>Thus, a number is recognized by the interpreter when bit(1) is non-zero. + + +<p><hr> +<h4><a name="symbol">Symbols</a></h4> + +<p>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: + +<pre><code> + Symbol + | + V + +-----+-----+ + | / | VAL | + +-----+-----+ +</code></pre> + +<p>That is, the symbol's tail is empty (points to <code>NIL</code>, as indicated +by the '/' character). + +<p>The pointer to a symbol points to the CDR of the cell, with an offset of 4 +from the cell's start address. Therefore, the bit pattern of a symbol will be: + +<pre><code> + xxxxxxxxxxxxxxxxxxxxxxxxxxxxx100 +</code></pre> + +<p>Thus, a symbol is recognized by the interpreter when bit(2) is non-zero. + +<p>A property is a key-value-pair, represented as a cell in the symbol's tail. +This is called a "property list". The property list may be terminated by a +number representing the symbol's name. In the following example, a symbol with +the name <code>"abc"</code> has three properties: + +<pre><code> + Symbol + | + V + +-----+-----+ + | | | VAL | + +--+--+-----+ + | tail + | + V name + +-----+-----+ +-----+-----+ +-----+-----+ +-----+-----+ + | | | ---+---> | KEY | ---+---> | | | ---+---> |'cba'| / | + +--+--+-----+ +-----+-----+ +--+--+-----+ +-----+-----+ + | | + V V + +-----+-----+ +-----+-----+ + | VAL | KEY | | VAL | KEY | + +-----+-----+ +-----+-----+ +</code></pre> + +<p>Each property in a symbol's tail is either a symbol (then it represents a +boolean value), or a cell 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. + +<p>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 +three 8-bit-bytes per character. The first byte of the first character is stored +in the lowest 8 bits of the number. + +<p>All symbols have the above structure, but depending on scope and +accessibility there are actually four types of symbols: <code><a +href="#nilSym">NIL</a></code>, <a href="#internal">internal</a>, <a +href="#transient">transient</a> and <a href="#external">external</a> symbols. + + +<p><hr> +<h5><a name="nilSym">NIL</a></h5> + +<p><code>NIL</code> is a special symbol which exists exactly once in the whole +system. It is used + +<p><ul> +<li>as an end-of-list marker +<li>to represent the empty list +<li>to represent the boolean value "false" +<li>to represent a string of length zero +<li>to represent the value "Not a Number" +<li>as the root of all class hierarchies +</ul> + +<p>For that, <code>NIL</code> has a special structure: + +<pre><code> + NIL: / + | + V + +-----+-----+-----+-----+ + | / | / | / | / | + +-----+--+--+-----+-----+ +</code></pre> + +<p>The reason for that structure is <code>NIL</code>'s dual nature both as a +symbol and as a list: + +<p><ul> +<li>As a symbol, it should give <code>NIL</code> for its VAL, and be without +properties + +<li>For the empty list, <code>NIL</code> should give <code>NIL</code> both for +its CAR and for its CDR + +</ul> + +<p>These requirements are fulfilled by the above structure. + + +<p><hr> +<h5><a name="internal">Internal Symbols</a></h5> + +<p>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. + +<p>There cannot be two different internal symbols with the same name. + +<p>Initially, a new internal symbol's VAL is <code>NIL</code>. + + +<p><hr> +<h5><a name="transient">Transient Symbols</a></h5> + +<p>Transient symbols are only interned into a 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. + +<p>Transient symbols are used + +<p><ul> +<li>as text strings + +<li>as identifiers with a limited access scope (like, for example, +<code>static</code> identifiers in the C language family) + +<li>as anonymous, dynamically created objects (without a name) + +</ul> + +<p>Initially, a new transient symbol's VAL is that symbol itself. + +<p>A transient symbol without a name can be created with the <code><a +href="refB.html#box">box</a></code> or <code><a +href="refN.html#new">new</a></code> functions. + + +<p><hr> +<h5><a name="external">External Symbols</a></h5> + +<p>External symbols reside in a database file (or a similar resources (see +<code><a href="refE.html#*Ext">*Ext</a></code>)), and are loaded into memory - +and written back to the file - dynamically as needed, and transparent to the +programmer. + +<p>The interpreter recognizes external symbols internally by an additional tag +bit in the tail structure. + +<p>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. + +<p>Initially, a new external symbol's VAL is <code>NIL</code>, unless otherwise +specified at creation time. + + +<p><hr> +<h4><a name="lst">Lists</a></h4> + +<p>A list is a sequence of one or more cells, holding numbers, symbols, or +lists. Lists are used in PicoLisp to emulate composite data structures like +arrays, trees, stacks or queues. + +<p>In contrast to lists, numbers and symbols are collectively called "Atoms". + +<p>Typically, the CDR of each cell in a list points to the following cell, +except for the last cell which points <code>NIL</code>. If, however, the CDR of +the last cell points to an atom, that cell is called a "dotted pair" (because of +its I/O syntax with a dot '.' between the two values). + + +<p><hr> +<h3><a name="mem">Memory Management</a></h3> + +<p>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. + +<p>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. + + +<p><hr> +<h2><a name="penv">Programming Environment</a></h2> + +<p>Lisp was chosen as the programming language, because of its clear and simple +structure. + +<p>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 + +<p><ul> +<li>Dynamic data types and structures +<li>Formal equivalence of code and data +<li>Functional programming style +<li>An interactive environment +</ul> + +<p>In the following, some concepts and peculiarities of the PicoLisp language +and environment are described. + + +<p><hr> +<h3><a name="invoc">Invocation</a></h3> + +<p>When PicoLisp is invoked from the command line, an arbitrary number of +arguments may follow the command name. + +<p>By default, each argument is the name of a file to be executed by the +interpreter. If, however, the argument's first character is a hyphen '-', then +the rest of that argument is taken as a Lisp function call (without the +surrounding parentheses). A hyphen by itself as an argument stops evaluation of +the rest of the command line (it may be processed later using the <code><a +href="refA.html#argv">argv</a></code> and <code><a +href="refO.html#opt">opt</a></code> functions). This mechanism corresponds to +calling <code>(<a href="refL.html#load">load</a> T)</code>. + +<p>As a convention, PicoLisp source files have the extension "<code>.l</code>". + +<p>Note that the PicoLisp executable itself does not expect or accept any +command line flags or options. They are reserved for application programs. + +<p>The simplest and shortest invocation of PicoLisp does nothing, and exits +immediately by calling <code><a href="refB.html#bye">bye</a></code>: + +<pre><code> +$ bin/picolisp -bye +$ +</code></pre> + +<p>In interactive mode, the PicoLisp interpreter (see <code><a +href="refL.html#load">load</a></code>) will also exit when an empty line is +entered: + +<pre><code> +$ bin/picolisp +: # Typed ENTER +$ +</code></pre> + +<p>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: + +<pre><code> +$ bin/picolisp lib.l ext.l +</code></pre> + +<p>The recommended way, however, is to call the "p" 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 <code>main</code>, your invocation +would look like: + +<pre><code> +$ ./p myProject.l -main +</code></pre> + +<p>For interactive development and debugging it is recommended also to load +"dbg.l" (or use './dbg' instead of './p'), to get the vi-style command line +editor, single-stepping, tracing and other debugging utilities. + +<pre><code> +$ ./dbg myProject.l -main +</code></pre> + +<p>In any case, the directory part of the first file name supplied on the +command line (normally, the path to "lib.l") is remembered internally as the +<u>PicoLisp Home Directory</u>. This path is later automatically substituted for +any leading "<code>@</code>" character in file name arguments to I/O functions +(see <code><a href="refP.html#path">path</a></code>). + + +<p><hr> +<h3><a name="io">Input/Output</a></h3> + +<p>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. + +<p>In normal operation, the PicoLisp interpreter continuously 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. + +<p>Comments can be embedded in the input stream with the hash <code>#</code> +character. Everything up to the end of that line will be ignored by the reader. + +<pre><code> +: (* 1 2 3) # This is a comment +-> 6 +</code></pre> + +<p>A comment spanning several lines may be enclosed between <code>#{</code> and +<code>}#</code>. + + +<p>Here is the I/O syntax for the individual PicoLisp data types: + + +<p><hr> +<h4><a name="num-io">Numbers</a></h4> + +<p>A number consists of an arbitrary number of digits (<code>'0'</code> through +<code>'9'</code>), optionally preceded by a sign character (<code>'+'</code> or +<code>'-'</code>). Legal number input is: + +<pre><code> +: 7 +-> 7 +: -12345678901245678901234567890 +-> -12345678901245678901234567890 +</code></pre> + +<p>Fixed-point numbers can be input by embedding a decimal point +<code>'.'</code>, and setting the global variable <code><a +href="refS.html#*Scl">*Scl</a></code> appropriately: + +<pre><code> +: *Scl +-> 0 + +: 123.45 +-> 123 +: 456.78 +-> 457 + +: (setq *Scl 3) +-> 3 +: 123.45 +-> 123450 +: 456.78 +-> 456780 +</code></pre> + +<p>Thus, fixed-point input simply scales the number to an integer value +corresponding to the number of digits in <code><a +href="refS.html#*Scl">*Scl</a></code>. + +<p>Formatted output of scaled fixed-point values can be done with the <code><a +href="refF.html#format">format</a></code> function: + +<pre><code> +: (format 1234567890 2) +-> "12345678.90" +: (format 1234567890 2 "." ",") +-> "12,345,678.90" +</code></pre> + + +<p><hr> +<h4><a name="sym-io">Symbols</a></h4> + +<p>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). + +<p>In general, symbol names are case-sensitive. <code>car</code> is not the same +as CAR. + + +<p><hr> +<h5><a name="nilSym-io">NIL</a></h5> + +<p>Besides for standard normal form, <code>NIL</code> is also recognized as +<code>()</code>, <code>[]</code> or <code>""</code>. + +<pre><code> +: NIL +-> NIL +: () +-> NIL +: "" +-> NIL +</code></pre> + +<p>Output will always appear as <code>NIL</code>. + + +<p><hr> +<h5><a name="internal-io">Internal Symbols</a></h5> + +<p>Internal symbol names can consist of any printable (non-whitespace) +character, except for the following meta characters: + +<pre><code> + " ' ( ) , [ ] ` ~ { } +</code></pre> + +<p>It is possible, though, to include these special characters into symbol names +by escaping them with a backslash '<code>\</code>'. + +<p>The dot '<code>.</code>' has a dual nature. It is a meta character when +standing alone, denoting a <a href="#dotted">dotted pair</a>, but can otherwise +be used in symbol names. + +<p>As a rule, anything not recognized by the reader as another data type will be +returned as an internal symbol. + + +<p><hr> +<h5><a name="transient-io">Transient Symbols</a></h5> + +<p>In an interactive environment (console), transient symbols should appear as +an <u>underlined</u> sequence of characters. Where this is not possible (e.g. +for representation in files), or inconvenient (while editing), double quotes +'<code>"</code>' are used instead of underlining. + +<p>The underlining of transient symbols is controlled by the global variable +<code><a href="refT.html#*Tsm">*Tsm</a></code>, and can be switched off +completely with + +<pre><code> +: (off *Tsm) +</code></pre> + +<p>Keyboard input of transient symbols is always via the double quote key. + +<p>A transient symbol may be used (and, in double quote representation, also +look) like a string constant in other languages. However, it is a real symbol, +and may be assigned a value or a function definition, and properties. + +<p>Initially, a transient symbol's value is that symbol itself, so that it does +not need to be quoted for evaluation: + +<pre><code> +: <u>This is a string</u> # "This is a string" if *Tsm is off +-> <u>This is a string</u> +</code></pre> + +<p>However, care must be taken when assigning a value to a transient symbol. +This may cause unexpected behavior: + +<pre><code> +: (setq <u>This is a string</u> 12345) # (setq "This is a string" 12345) +-> 12345 +: <u>This is a string</u> +-> 12345 +</code></pre> + +<p>The name of a transient symbol can contain any character except zero. A +double quote character can be escaped with a backslash '<code>\</code>', and a +backslash itself has to be escaped with another backslash. Control characters +can be written with a preceding hat '<code>^</code>' character. + +<pre><code> +: <u>We^Ird\\Str\"ing</u> +-> <u>We^Ird\\Str"ing</u> +: (chop @) +-> (<u>W</u> <u>e</u> <u>^I</u> <u>r</u> <u>d</u> <u>\\</u> <u>S</u> <u>t</u> <u>r</u> <u>"</u> <u>i</u> <u>n</u> <u>g</u>) +</code></pre> + +<p>The index for transient symbols is cleared automatically before and after +<code><a href="refL.html#load">load</a></code>ing a source file, or it can be +reset explicitly with the <code><a href="ref_.html#====">====</a></code> +function. With that mechanism, it is possible to create symbols with a local +access scope, not accessible from other parts of the program. + +<p>A special case of transient symbols are <i>anonymous symbols</i>. These are +symbols without name (see <code><a href="refB.html#box">box</a></code>, <code><a +href="refB.html#box?">box?</a></code> or <code><a +href="refN.html#new">new</a></code>). They print as a dollar sign +(<code>$</code>) followed by a decimal digit string (actually their machine +address). + +<p>To allow an easier copy/paste of the examples, most of the documentation uses +the double quote notation for transient symbols. + + +<p><hr> +<h5><a name="external-io">External Symbols</a></h5> + +<p>External symbol names are surrounded by braces (<code>'{'</code> and +<code>'}'</code>). The characters of the symbol's name itself identify the +physical location of the external object. This is + +<ul> +<li>in the 32-bit version: The number of the database file, and - separated by a +hyphen - the starting block in the database file. Both numbers are encoded in +base-64 notation (characters '<code>0</code>' through '<code>9</code>', +'<code>:</code>', '<code>;</code>', '<code>A</code>' through '<code>Z</code>' +and '<code>a</code>' through '<code>z</code>'). + +<li>in the 64-bit version: The number of the database file minus 1 in "hax" +notation (i.e. hexadecimal/alpha notation, where '@' is zero, 'A' is 1 and 'O' +is 15 (from "alpha" to "omega")), immediately followed (without a hyphen) the +starting block in octal ('0' through '7'). + +</ul> + +<p>In both cases, the database file (and possibly the hypen) are omitted for the +first (default) file. + +<p><hr> +<h4><a name="lst-io">Lists</a></h4> + +<p>Lists are surrounded by parentheses (<code>'('</code> and <code>')'</code>). + +<p><code>(A)</code> is a list consisting of a single cell, with the symbol +<code>A</code> in its CAR, and <code>NIL</code> in its CDR. + +<p><code>(A B C)</code> is a list consisting of three cells, with the symbols +<code>A</code>, <code>B</code> and <code>C</code> respectively in their CAR, and +<code>NIL</code> in the last cell's CDR. + +<p><a name="dotted"><code>(A . B)</code></a> is a "dotted pair", a list +consisting of a single cell, with the symbol <code>A</code> in its CAR, and +<code>B</code> in its CDR. + +<p>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. + +<pre><code> +: (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 .) +</code></pre> + +<p>A similar result can be achieved with the function <code><a +href="refC.html#circ">circ</a></code>. Such lists must be used with care, +because many functions won't terminate or will crash when given such a list. + + +<p><hr> +<h4><a name="macro-io">Read-Macros</a></h4> + +<p>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 <code>eval</code> in the main loop. + +<p>The most prominent read-macro in Lisp is the single quote character +<code>'</code>, which expands to a call of the <code><a +href="refQ.html#quote">quote</a></code> function. Note that the single quote +character is also printed instead of the full function name. + +<pre><code> +: '(a b c) +-> (a b c) +: '(quote . a) +-> 'a +: (cons 'quote 'a) # (quote . a) +-> 'a +: (list 'quote 'a) # (quote a) +-> '(a) +</code></pre> + +<p>A comma (<code>,</code>) will cause the reader to collect the following data +item into an <code><a href="refI.html#idx">idx</a></code> tree in the global +variable <code><a href="refU.html#*Uni">*Uni</a></code>, and to return a +previously inserted equal item if present. This makes it possible to create a +unique list of references to data which do normally not follow the rules of +pointer equality. + +<p>A single backquote character <code>`</code> will cause the reader to evaluate +the following expression, and return the result. + +<pre><code> +: '(a `(+ 1 2 3) z) +-> (a 6 z) +</code></pre> + +<p>A tilde character <code>~</code> inside a list will cause the reader to +evaluate the following expression, and splice the result into the list. + +<pre><code> +: '(a b c ~(list 'd 'e 'f) g h i) +-> (a b c d e f g h i) +</code></pre> + +<p>Brackets (<code>'['</code> and <code>']'</code>) can be used as super +parentheses. A closing bracket will match the innermost opening bracket, or all +currently open parentheses. + +<pre><code> +: '(a (b (c (d] +-> (a (b (c (d)))) +: '(a (b [c (d])) +-> (a (b (c (d)))) +</code></pre> + +<p>Finally, reading the sequence '<code>{}</code>' will result in a new +anonymous symbol with value <code>NIL</code>, equivalent to a call to <code><a +href="refB.html#box">box</a></code> without arguments. + +<pre><code> +: '({} {} {}) +-> ($134599965 $134599967 $134599969) +: (mapcar val @) +-> (NIL NIL NIL) +</code></pre> + + +<p><hr> +<h3><a name="ev">Evaluation</a></h3> + +<p>PicoLisp tries to evaluate any expression encountered in the read-eval-print +loop. Basically, it does so by applying the following three rules: + +<p><ul> +<li>A number evaluates to itself. + +<li>A symbol evaluates to its value (VAL). + +<li>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. + +</ul> + +<pre><code> +: 1234 +-> 1234 # Number evaluates to itself +: *Pid +-> 22972 # Symbol evaluates to its VAL +: (+ 1 2 3) +-> 6 # List is evaluated as a function call +</code></pre> + +<p>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: + +<pre><code> +: (1 2 3 4 5 6) +-> (1 2 3 4 5 6) +</code></pre> + +<p>This is not really a function call but just a convenience to avoid having to +quote simple data lists. + +<p>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. + +<p>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 + +<p><dl> +<dt>either +<dd>a <u>number</u>. 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. +<code>quote</code>) or evaluate only some of their arguments (e.g. +<code>setq</code>). + +<dt>or +<dd>a <u>lambda expression</u>. 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. + +</dl> + +<p>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 <code>*</code> in: + +<pre><code> +: (* 1 2 3) # Call the function '*' +-> 6 +</code></pre> + +<p>Inspecting the VAL of <code>*</code>, however, gives + +<pre><code> +: * # Get the VAL of the symbol '*' +-> 67291944 +</code></pre> + +<p>The VAL of <code>*</code> is a number. In fact, it is the numeric +representation of a C-function pointer, i.e. a pointer to executable code. This +is the case for all built-in functions of PicoLisp. + +<p>Other functions in turn are written as Lisp expressions: + +<pre><code> +: (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))) +</code></pre> + +<p>The VAL of <code>foo</code> is a list. It is the list that was assigned to +<code>foo</code> with the <code>de</code> function. It would be perfectly legal +to use <code>setq</code> instead of <code>de</code>: + +<pre><code> +: (setq foo '((X Y) (* (+ X Y) (+ X Y)))) +-> ((X Y) (* (+ X Y) (+ X Y))) +: (foo 2 3) +-> 25 +</code></pre> + +<p>If the VAL of <code>foo</code> were another symbol, that symbol's VAL would +be used instead to search for an executable function. + +<p>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. + +<pre><code> +: ((intern (pack "c" "a" "r")) (1 2 3)) +-> 1 +</code></pre> + +<p>Here, the <code>intern</code> function returns the symbol <code>car</code> +whose VAL is used then. It is also legal, though quite dangerous, to use the +code-pointer directly: + +<pre><code> +: car +-> 67306152 +: ((* 2 33653076) (1 2 3)) +-> 1 +</code></pre> + +<p>When an executable function is defined in Lisp itself, we call it a <a +name="lambda"><u>lambda expression</u></a>. 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: + +<p><dl> + +<dt>When the CAR is a list of symbols +<dd>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. + +<dt>Otherwise, when the CAR is the symbol <code>@</code> +<dd>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 <code><a href="refA.html#args">args</a></code>, +<code><a href="refN.html#next">next</a></code>, <code><a +href="refA.html#arg">arg</a></code> and <code><a +href="refR.html#rest">rest</a></code> functions. This allows to define functions +with a variable number of evaluated arguments. + +<dt>Otherwise, when the CAR is a single symbol +<dd>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. + +</dl> + +<p>In all cases, the return value is the result of the last expression in the +body. + +<pre><code> +: (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 +</code></pre> + +<pre><code> +: (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 +</code></pre> + +<pre><code> +: (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 +</code></pre> + +<p>Note that these forms can also be combined. For example, to evaluate only the +first two arguments, bind the results to <code>X</code> and <code>Y</code>, and +bind all other arguments (unevaluated) to <code>Z</code>: + +<pre><code> +: (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))) # two arguments are evaluated +</code></pre> + +<p>Or, a single argument followed by a variable number of arguments: + +<pre><code> +: (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 arg +11 +-> 11 +</code></pre> + +<p>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 +<code>NIL</code>. + + +<p><hr> +<h3><a name="int">Interrupt</a></h3> + +<p>During the evaluation of an expression, the PicoLisp interpreter can be +interrupted at any time by hitting <code>Ctrl-C</code>. It will then enter the +breakpoint routine, as if <code><a href="ref_.html#!">!</a></code> were called. + +<p>Hitting ENTER at that point will continue evaluation, while <code>(<a +href="refQ.html#quit">quit</a>)</code> will abort evaluation and return the +interpreter to the top level. See also <code><a +href="refD.html#debug">debug</a></code>, <code><a +href="refE.html#e">e</a></code>, <code><a href="ref_.html#^">^</a></code> and +<code><a href="refD.html#*Dbg">*Dbg</a></code> + + +<p><hr> +<h3><a name="errors">Error Handling</a></h3> + +<p>When a runtime error occurs, execution is stopped and an error handler is +entered. + +<p>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 <code><a +href="refM.html#*Msg">*Msg</a></code>, and the location of the error in <code><a +href="ref_.html#^">^</a></code>. If the VAL of the global <code><a +href="refE.html#*Err">*Err</a></code> is non-<code>NIL</code> it is executed as +a <code>prg</code> body. If the standard input is from a terminal, a +read-eval-print loop (with a question mark "<code>?</code>" as prompt) is +entered (the loop is exited when an empty line is input). Then all pending +<code><a href="refF.html#finally">finally</a></code> 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. + +<pre><code> +: (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 +: +</code></pre> + +<p>Errors can be caught with <code><a href="refC.html#catch">catch</a></code>, +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 <code>NIL</code>) is returned. + + +<p><hr> +<h3><a name="atres">@ Result</a></h3> + +<p>In certain situations, the result of the last evaluation is stored in the VAL +of the symbol <code>@</code>. This can be very convenient, because it often +makes the assignment to temporary variables unnecessary. + +<p><dl> + +<dt><code><a href="refL.html#load">load</a></code> +<dd>In read-eval loops, the last three results which were printed at the console +are available in <code>@@@</code>, <code>@@</code> and <code>@</code>, in that +order (i.e the latest result is in <code>@</code>). + +<pre><code> +: (+ 1 2 3) +-> 6 +: (/ 128 4) +-> 32 +: (- @ @@) # Subtract the last two results +-> 26 +</code></pre> + +<p><dt>Flow functions +<dd>Flow- and logic-functions store the result of their controlling expression - +respectively non-<code>NIL</code> results of their conditional expression - in +<code>@</code>. + +<pre><code> +: (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) +</code></pre> + +<p>Functions with controlling expressions are + <a href="refC.html#case">case</a>, + <a href="refP.html#prog1">prog1</a>, + <a href="refP.html#prog2">prog2</a>, +and the bodies of <code><a href="refR.html#*Run">*Run</a></code> tasks. + +<p>Functions with conditional expressions are + <a href="refA.html#and">and</a>, + <a href="refC.html#cond">cond</a>, + <a href="refD.html#do">do</a>, + <a href="refF.html#for">for</a>, + <a href="refI.html#if">if</a>, + <a href="refI.html#if2">if2</a>, + <a href="refI.html#ifn">ifn</a>, + <a href="refL.html#loop">loop</a>, + <a href="refN.html#nand">nand</a>, + <a href="refN.html#nond">nond</a>, + <a href="refN.html#nor">nor</a>, + <a href="refN.html#not">not</a>, + <a href="refO.html#or">or</a>, + <a href="refS.html#state">state</a>, + <a href="refU.html#unless">unless</a>, + <a href="refU.html#until">until</a>, + <a href="refW.html#when">when</a> and + <a href="refW.html#while">while</a>. + +</dl> + +<p><code>@</code> is generally local to functions and methods, its value is +automatically saved upon function entry and restored at exit. + + +<p><hr> +<h3><a name="cmp">Comparing</a></h3> + +<p>In PicoLisp, it is legal to compare data items of arbitrary type. Any two +items are either + +<p><dl> + +<dt>Identical +<dd>They are the same memory object (pointer equality). For example, two +internal symbols with the same name are identical. In the 64-bit version, also +short numbers (up to 60 bits) are pointer-equal. + +<dt>Equal +<dd>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. + +<dt>Or they have a well-defined ordinal relationship +<dd>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, +<code>NIL</code> is always less than anything else, and <code>T</code> is always +greater than anything else. + +</dl> + +<p>To demonstrate this, <code><a href="refS.html#sort">sort</a></code> a list of +mixed data types: + +<pre><code> +: (sort '("abc" T (d e f) NIL 123 DEF)) +-> (NIL 123 DEF "abc" (d e f) T) +</code></pre> + +<p>See also <code><a href="refM.html#max">max</a></code>, <code><a +href="refM.html#min">min</a></code>, <code><a +href="refR.html#rank">rank</a></code>, <code><a href="ref_.html#<"><</a></code>, +<code><a href="ref_.html#=">=</a></code>, <code><a +href="ref_.html#>">></a></code> etc. + + +<p><hr> +<h3><a name="oop">OO Concepts</a></h3> + +<p>PicoLisp comes with built-in object oriented extensions. There seems to be a +common agreement upon three criteria for object orientation: + +<p><dl> +<dt>Encapsulation +<dd>Code and data are encapsulated into <u>objects</u>, giving them both a +<u>behavior</u> and a <u>state</u>. Objects communicate by sending and receiving +<u>messages</u>. + +<dt>Inheritance +<dd>Objects are organized into <u>classes</u>. The behavior of an object is +inherited from its class(es) and superclass(es). + +<dt>Polymorphism +<dd>Objects of different classes may behave differently in response to the same +message. For that, classes may define different methods for each message. + +</dl> + +<p>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). + +<p>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. + +<p>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 <code><a +href="refE.html#extra">extra</a></code> and <code><a +href="refS.html#super">super</a></code> functions. + +<p>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! + +<p>While a method body is being executed, the global variable <code><a +href="refT.html#This">This</a></code> is set to the current object, allowing +the use of the short-cut property functions <code><a +href="ref_.html#=:">=:</a></code>, <code><a href="ref_.html#:">:</a></code> +and <code><a href="ref_.html#::">::</a></code>. + + +<p><hr> +<h3><a name="dbase">Database</a></h3> + +<p>On the lowest level, a PicoLisp database is just a collection of <a +href="#external">external symbols</a>. They reside in a database file, and are +dynamically swapped in and out of memory. Only one database can be open at a +time (<code><a href="refP.html#pool">pool</a></code>). + +<p>In addition, further external symbols can be specified to originate from +arbitrary sources via the <code><a href="refE.html#*Ext">*Ext</a></code> +mechanism. + +<p>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 <code><a +href="refC.html#commit">commit</a></code> is called. Alternatively, all +modifications since the last call to <code>commit</code> can be discarded by +calling <code><a href="refR.html#rollback">rollback</a></code>. + +<p><hr> +<h4><a name="trans">Transactions</a></h4> + +<p>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 <code>(<a +href="refD.html#dbSync">dbSync</a>)</code>, and closed by calling <code>(<a +href="refC.html#commit">commit</a> 'upd)</code>. Short transactions, involving +only a single DB operation, are available in functions like <code><a +href="refN.html#new!">new!</a></code> and methods like <code><a +href="refE.html#entityMesssages">put!></a></code> (by convention with an +exclamation mark), which implicitly call <code>(dbSync)</code> and <code>(commit +'upd)</code> themselves. + +<p>A transaction proceeds through five phases: + +<p><ol> +<li><code><a href="refD.html#dbSync">dbSync</a></code> waits to get a <code><a +href="refL.html#lock">lock</a></code> on the root object <code><a +href="refD.html#*DB">*DB</a></code>. Other processes continue reading and +writing meanwhile. + +<li><code><a href="refD.html#dbSync">dbSync</a></code> calls <code><a +href="refS.html#sync">sync</a></code> to synchronize with changes from other +processes. We hold the shared lock, but other processes may continue reading. + +<li>We make modifications to the internal state of external symbols with +<code><a href="refE.html#entityMesssages">put>, set>, lose></a></code> etc. We - +and also other processes - can still read the DB. + +<li>We call <code>(<a href="refC.html#commit">commit</a> 'upd)</code>. +<code>commit</code> obtains an exclusive lock (no more read operations by other +processes), writes an optional transaction log, and then all modified symbols. +As <code><a href="refU.html#upd">upd</a></code> is passed to 'commit', other +processes synchronize with these changes. + +<li>Finally, all locks are released by 'commit' + +</ol> + +<p><hr> +<h4><a name="er">Entities / Relations</a></h4> + +<p>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 <u>index</u>. + +<p>For the most part, other symbols in the database are objects derived from the +<code><a href="refE.html#+Entity">+Entity</a></code> class. + +<p>Entities depend on objects of the <code><a +href="refR.html#+relation">+relation</a></code> 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. + +<p>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 <code><a href="refE.html#+Entity">+Entity</a></code> class, relations are defined - in addition to +the method definitions of a normal class - with the <code><a +href="refR.html#rel">rel</a></code> function. Predefined relation classes +include + +<p><ul> +<li>Primitive types like + <dl> + <dt><code><a href="refS.html#+Symbol">+Symbol</a></code> + <dd>Symbolic data + <dt><code><a href="refS.html#+String">+String</a></code> + <dd>Strings (just a general case of symbols) + <dt><code><a href="refN.html#+Number">+Number</a></code> + <dd>Integers and fixed-point numbers + <dt><code><a href="refD.html#+Date">+Date</a></code> + <dd>Calendar date values, represented by a number + <dt><code><a href="refT.html#+Time">+Time</a></code> + <dd>Time-of-the-day values, represented by a number + <dt><code><a href="refB.html#+Blob">+Blob</a></code> + <dd>"Binary large objects" stored in separate files + </dl> +<li>Object-to-object relations + <dl> + <dt><code><a href="refL.html#+Link">+Link</a></code> + <dd>A reference to some other entity + <dt><code><a href="refH.html#+Hook">+Hook</a></code> + <dd>A reference to an entity holding object-local index trees + <dt><code><a href="refJ.html#+Joint">+Joint</a></code> + <dd>A bi-directional reference to some other entity + </dl> +<li>Container prefix classes like + <dl> + <dt><code><a href="refL.html#+List">+List</a></code> + <dd>A list of any of the other primitive or object relation types + <dt><code><a href="refB.html#+Bag">+Bag</a></code> + <dd>A list containing a mixture of any of the other types + </dl> +<li>Index prefix classes + <dl> + <dt><code><a href="refR.html#+Ref">+Ref</a></code> + <dd>An index with other primitives or entities as key + <dt><code><a href="refK.html#+Key">+Key</a></code> + <dd>A unique index with other primitives or entities as key + <dt><code><a href="refI.html#+Idx">+Idx</a></code> + <dd>A full-text index, typically for strings + <dt><code><a href="refS.html#+Sn">+Sn</a></code> + <dd>Tolerant index, using a modified Soundex-Algorithm + </dl> +<li>Booleans + <dl> + <dt><code><a href="refB.html#+Bool">+Bool</a></code> + <dd><code>T</code> or <code>NIL</code> + </dl> +<li>And a catch-all class + <dl> + <dt><code><a href="refA.html#+Any">+Any</a></code> + <dd>Not specified, may be any of the above relations + </dl> +</ul> + + +<p><hr> +<h3><a name="pilog">Pilog (PicoLisp Prolog)</a></h3> + +<p>A declarative language is built on top of PicoLisp, that has the semantics of +Prolog, but uses the syntax of Lisp. + +<p>For an explanation of Prolog's declarative programming style, an introduction +like "Programming in Prolog" by Clocksin/Mellish (Springer-Verlag 1981) is +recommended. + +<p>Facts and rules can be declared with the <code><a +href="refB.html#be">be</a></code> function. For example, a Prolog fact +'<code>likes(john,mary).</code>' is written in Pilog as: + +<pre><code> +(be likes (John Mary)) +</code></pre> + +<p>and a rule '<code>likes(john,X) :- likes(X,wine), likes(X,food).</code>' is +in Pilog: + +<pre><code> +(be likes (John @X) (likes @X wine) (likes @X food)) +</code></pre> + +<p>As in Prolog, the difference between facts and rules is that the latter ones +have conditions, and usually contain variables. + +<p>A variable in Pilog is any symbol starting with an at-mark character +("<code>@</code>"). The symbol <code>@</code> itself can be used as an anonymous +variable: It will match during unification, but will not be bound to the matched +values. + +<p>The <i>cut</i> operator of Prolog (usually written as an exclamation mark +(<code>!</code>)) is the symbol <code>T</code> in Pilog. + +<p>An interactive query can be done with the <code><a +href="ref_.html#?">?</a></code> function: + +<pre><code> +(? (likes John @X)) +</code></pre> + +<p>This will print all solutions, waiting for user input after each line. If a +non-empty line (not just a ENTER key, but for example a dot (<code>.</code>) +followed by ENTER) is typed, it will terminate. + +<p>Pilog can be called from Lisp and vice versa: + +<ul> + +<li>The interface from Lisp is via the functions <code><a +href="refG.html#goal">goal</a></code> (prepare a query from Lisp data) and +<code><a href="refP.html#prove">prove</a></code> (return an association list of +successful bindings), and the application level functions <code><a +href="refP.html#pilog">pilog</a></code> and <code><a +href="refS.html#solve">solve</a></code>. + +<li>When the CAR of a Pilog clause is a Pilog variable, the CDR is executed as a +Lisp expression and the result unified with that variable. + +<li>Within such a Lisp expression in a Pilog clause, the current bindings of +Pilog variables can be accessed with the <code><a +href="ref_.html#->">-&gt</a></code> function. + +</ul> + +<p><hr> +<h3><a name="conv">Naming Conventions</a></h3> + +<p>It was necessary to introduce - and adhere to - a set of conventions for +PicoLisp symbol names. Because all (internal) symbols have a global scope (there +are no packages or name spaces), 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. + +<p>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: + +<p><ul> +<li>Global variables start with an asterisk "<code>*</code>" +<li>Functions and other global symbols start with a lower case letter +<li>Locally bound symbols start with an upper case letter +<li>Local functions start with an underscore "<code>_</code>" +<li>Classes start with a plus-sign "<code>+</code>", where the first letter + <ul> + <li>is in lower case for abstract classes + <li>and in upper case for normal classes + </ul> +<li>Methods end with a right arrow "<code>></code>" +<li>Class variables may be indicated by an upper case letter +</ul> + +<p>For historical reasons, the global constant symbols <code>T</code> and +<code>NIL</code> do not obey these rules, and are written in upper case. + +<p>For example, a local variable could easily overshadow a function definition: + +<pre><code> +: (de max-speed (car) + (.. (get car 'speeds) ..) ) +-> max-speed +</code></pre> + +<p>Inside the body of <code>max-speed</code> (and all other functions called +during that execution) the kernel function <code>car</code> is redefined to some +other value, and will surely crash if something like <code>(car Lst)</code> is +executed. Instead, it is safe to write: + +<pre><code> +: (de max-speed (Car) # 'Car' with upper case first letter + (.. (get Car 'speeds) ..) ) +-> max-speed +</code></pre> + +<p>Note that there are also some strict naming rules (as opposed to the +voluntary conventions) that are required by the corresponding kernel +functionalities, like: + +<p><ul> +<li>Transient symbols are enclosed in double quotes (see <a +href="#transient-io">Transient Symbols</a>) <li>External symbols are enclosed in +braces (see <a href="#external-io">External Symbols</a>) <li>Pattern-Wildcards +start with an at-mark "<code>@</code>" (see <a href="refM.html#match">match</a> +and <a href="refF.html#fill">fill</a>) <li>Symbols referring to a shared library +contain a colon "<code>lib:sym</code>" </ul> + +<p>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. + + +<p><hr> +<h3><a name="trad">Breaking Traditions</a></h3> + +<p>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: + +<p><dl> + +<dt>Case Sensitivity +<dd>PicoLisp distinguishes between upper case and lower case characters in +symbol names. Thus, <code>CAR</code> and <code>car</code> are different symbols, +which was not the case in traditional Lisp systems. + +<dt><code>QUOTE</code> +<dd>In traditional Lisp, the <code>QUOTE</code> function returns its +<i>first</i> unevaluated argument. In PicoLisp, on the other hand, +<code>quote</code> returns <i>all</i> (unevaluated) argument(s). + +<dt><code>LAMBDA</code> +<dd>The <code>LAMBDA</code> function, in some way at the heart of traditional +Lisp, is completely missing (and <code>quote</code> is used instead). + +<dt><code>PROG</code> +<dd>The <code>PROG</code> function of traditional Lisp, with its GOTO and ENTER +functionality, is also missing. PicoLisp's <code>prog</code> function is just a +simple sequencer (as <code>PROGN</code> in some Lisps). + +<dt>Function/Value +<dd>In PicoLisp, a symbol cannot have a value <i>and</i> a function definition +at the same time. Though this is a disadvantage at first sight, it allows a +completely uniform handling of functional data. + +</dl> + + +<p><hr> +<h3><a name="bugs">Bugs</a></h3> + +<p>The names of the symbols <code>T</code> and <code>NIL</code> violate the <a +href="#conv">naming conventions</a>. They are global symbols, and should +therefore start with an asterisk "<code>*</code>". It is too easy to bind them +to some other value by mistake: + +<pre><code> +(de foo (R S T) + ... +</code></pre> + +<p>However, <code><a href="refL.html#lint">lint</a></code> will issue a warning +in such a case. + + +<p><hr> +<h2><a name="fun">Function Reference</a></h2> + +<p>This section provides a reference manual for the kernel functions, and some +extensions. See the thematically grouped list of indexes below. + +<p>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: + +<p>The primary data types: + +<p><ul> +<li><code>num</code> - Number +<li><code>sym</code> - Symbol +<li><code>lst</code> - List +</ul> + +<p>Other (derived) data types + +<p><ul> +<li><code>any</code> - Anything: Any primary data type +<li><code>flg</code> - Flag: Boolean value (<code>NIL</code> or non-<code>NIL</code>) +<li><code>cnt</code> - A count or a small number +<li><code>dat</code> - Date: Days since first of March, in the year 0 A.D. +<li><code>tim</code> - Time: Seconds since midnight +<li><code>obj</code> - Object/Class: A symbol with methods and/or classes +<li><code>var</code> - Variable: Either a symbol or a cell +<li><code>exe</code> - Executable: A list as executable expression (<code>eval</code>) +<li><code>prg</code> - Prog-Body: A list of executable expressions (<code>run</code>) +<li><code>fun</code> - Function: Either a number (code-pointer), a symbol (message) or a list (lambda) +<li><code>msg</code> - Message: A symbol sent to an object (to invoke a method) +<li><code>cls</code> - Class: A symbol defined as an object's class +<li><code>typ</code> - Type: A list of <code>cls</code> symbols +<li><code>pat</code> - Pattern: A symbol whose name starts with an at-mark "<code>@</code>" +<li><code>pid</code> - Process ID: A number, the ID of a Unix process +<li><code>tree</code> - Database index tree specification +<li><code>hook</code> - Database hook object +</ul> + +<p> +<a href="refA.html">A</a> +<a href="refB.html">B</a> +<a href="refC.html">C</a> +<a href="refD.html">D</a> +<a href="refE.html">E</a> +<a href="refF.html">F</a> +<a href="refG.html">G</a> +<a href="refH.html">H</a> +<a href="refI.html">I</a> +<a href="refJ.html">J</a> +<a href="refK.html">K</a> +<a href="refL.html">L</a> +<a href="refM.html">M</a> +<a href="refN.html">N</a> +<a href="refO.html">O</a> +<a href="refP.html">P</a> +<a href="refQ.html">Q</a> +<a href="refR.html">R</a> +<a href="refS.html">S</a> +<a href="refT.html">T</a> +<a href="refU.html">U</a> +<a href="refV.html">V</a> +<a href="refW.html">W</a> +<a href="refX.html">X</a> +<a href="refY.html">Y</a> +<a href="refZ.html">Z</a> +<a href="ref_.html">Other</a> + +<p><dl> + +<dt>Symbol Functions +<dd><code> + <a href="refN.html#new">new</a> + <a href="refS.html#sym">sym</a> + <a href="refS.html#str">str</a> + <a href="refC.html#char">char</a> + <a href="refN.html#name">name</a> + <a href="refS.html#sp?">sp?</a> + <a href="refP.html#pat?">pat?</a> + <a href="refF.html#fun?">fun?</a> + <a href="refA.html#all">all</a> + <a href="refI.html#intern">intern</a> + <a href="refE.html#extern">extern</a> + <a href="ref_.html#====">====</a> + <a href="refQ.html#qsym">qsym</a> + <a href="refL.html#loc">loc</a> + <a href="refB.html#box?">box?</a> + <a href="refS.html#str?">str?</a> + <a href="refE.html#ext?">ext?</a> + <a href="refT.html#touch">touch</a> + <a href="refZ.html#zap">zap</a> + <a href="refL.html#length">length</a> + <a href="refS.html#size">size</a> + <a href="refF.html#format">format</a> + <a href="refC.html#chop">chop</a> + <a href="refP.html#pack">pack</a> + <a href="refG.html#glue">glue</a> + <a href="refP.html#pad">pad</a> + <a href="refA.html#align">align</a> + <a href="refC.html#center">center</a> + <a href="refT.html#text">text</a> + <a href="refW.html#wrap">wrap</a> + <a href="refP.html#pre?">pre?</a> + <a href="refS.html#sub?">sub?</a> + <a href="refL.html#low?">low?</a> + <a href="refU.html#upp?">upp?</a> + <a href="refL.html#lowc">lowc</a> + <a href="refU.html#uppc">uppc</a> + <a href="refF.html#fold">fold</a> + <a href="refV.html#val">val</a> + <a href="refG.html#getd">getd</a> + <a href="refS.html#set">set</a> + <a href="refS.html#setq">setq</a> + <a href="refD.html#def">def</a> + <a href="refD.html#de">de</a> + <a href="refD.html#dm">dm</a> + <a href="refR.html#recur">recur</a> + <a href="refU.html#undef">undef</a> + <a href="refR.html#redef">redef</a> + <a href="refD.html#daemon">daemon</a> + <a href="refP.html#patch">patch</a> + <a href="refX.html#xchg">xchg</a> + <a href="refO.html#on">on</a> + <a href="refO.html#off">off</a> + <a href="refO.html#onOff">onOff</a> + <a href="refZ.html#zero">zero</a> + <a href="refO.html#one">one</a> + <a href="refD.html#default">default</a> + <a href="refE.html#expr">expr</a> + <a href="refS.html#subr">subr</a> + <a href="refL.html#let">let</a> + <a href="refL.html#let?">let?</a> + <a href="refU.html#use">use</a> + <a href="refA.html#accu">accu</a> + <a href="refP.html#push">push</a> + <a href="refP.html#push1">push1</a> + <a href="refP.html#pop">pop</a> + <a href="refC.html#cut">cut</a> + <a href="refD.html#del">del</a> + <a href="refQ.html#queue">queue</a> + <a href="refF.html#fifo">fifo</a> + <a href="refI.html#idx">idx</a> + <a href="refL.html#lup">lup</a> + <a href="refC.html#cache">cache</a> + <a href="refL.html#locale">locale</a> + <a href="refD.html#dirname">dirname</a> +</code> + +<dt>Property Access +<dd><code> + <a href="refP.html#put">put</a> + <a href="refG.html#get">get</a> + <a href="refP.html#prop">prop</a> + <a href="ref_.html#;">;</a> + <a href="ref_.html#=:">=:</a> + <a href="ref_.html#:">:</a> + <a href="ref_.html#::">::</a> + <a href="refP.html#putl">putl</a> + <a href="refG.html#getl">getl</a> + <a href="refW.html#wipe">wipe</a> + <a href="refM.html#meta">meta</a> +</code> + +<dt>Predicates +<dd><code> + <a href="refA.html#atom">atom</a> + <a href="refP.html#pair">pair</a> + <a href="refL.html#lst?">lst?</a> + <a href="refN.html#num?">num?</a> + <a href="refS.html#sym?">sym?</a> + <a href="refF.html#flg?">flg?</a> + <a href="refS.html#sp?">sp?</a> + <a href="refP.html#pat?">pat?</a> + <a href="refF.html#fun?">fun?</a> + <a href="refB.html#box?">box?</a> + <a href="refS.html#str?">str?</a> + <a href="refE.html#ext?">ext?</a> + <a href="refB.html#bool">bool</a> + <a href="refN.html#not">not</a> + <a href="ref_.html#==">==</a> + <a href="refN.html#n==">n==</a> + <a href="ref_.html#=">=</a> + <a href="ref_.html#<>"><&gt</a> + <a href="ref_.html#=0">=0</a> + <a href="ref_.html#=T">=T</a> + <a href="refN.html#n0">n0</a> + <a href="refN.html#nT">nT</a> + <a href="ref_.html#<">&lt;</a> + <a href="ref_.html#<=">&lt;=</a> + <a href="ref_.html#>">&gt;</a> + <a href="ref_.html#>=">&gt;=</a> + <a href="refM.html#match">match</a> +</code> + +<dt>Arithmetics +<dd><code> + <a href="ref_.html#+">+</a> + <a href="ref_.html#-">-</a> + <a href="ref_.html#*">*</a> + <a href="ref_.html#/">/</a> + <a href="ref_.html#%">%</a> + <a href="ref_.html#*/">*/</a> + <a href="ref_.html#**">**</a> + <a href="refI.html#inc">inc</a> + <a href="refD.html#dec">dec</a> + <a href="ref_.html#>>">>></a> + <a href="refL.html#lt0">lt0</a> + <a href="refG.html#ge0">ge0</a> + <a href="refG.html#gt0">gt0</a> + <a href="refA.html#abs">abs</a> + <a href="refB.html#bit?">bit?</a> + <a href="ref_.html#&">&</a> + <a href="ref_.html#|">|</a> + <a href="refX.html#x|">x|</a> + <a href="refS.html#sqrt">sqrt</a> + <a href="refS.html#seed">seed</a> + <a href="refR.html#rand">rand</a> + <a href="refM.html#max">max</a> + <a href="refM.html#min">min</a> + <a href="refL.html#length">length</a> + <a href="refS.html#size">size</a> + <a href="refA.html#accu">accu</a> + <a href="refF.html#format">format</a> + <a href="refP.html#pad">pad</a> + <a href="refO.html#oct">oct</a> + <a href="refH.html#hex">hex</a> + <a href="refF.html#fmt64">fmt64</a> + <a href="refM.html#money">money</a> +</code> + +<dt>List Processing +<dd><code> + <a href="refC.html#car">car</a> + <a href="refC.html#cdr">cdr</a> + <a href="refC.html#caar">caar</a> + <a href="refC.html#cadr">cadr</a> + <a href="refC.html#cdar">cdar</a> + <a href="refC.html#cddr">cddr</a> + <a href="refC.html#caaar">caaar</a> + <a href="refC.html#caadr">caadr</a> + <a href="refC.html#cadar">cadar</a> + <a href="refC.html#caddr">caddr</a> + <a href="refC.html#cdaar">cdaar</a> + <a href="refC.html#cdadr">cdadr</a> + <a href="refC.html#cddar">cddar</a> + <a href="refC.html#cdddr">cdddr</a> + <a href="refC.html#cadddr">cadddr</a> + <a href="refC.html#cddddr">cddddr</a> + <a href="refN.html#nth">nth</a> + <a href="refC.html#con">con</a> + <a href="refC.html#cons">cons</a> + <a href="refC.html#conc">conc</a> + <a href="refC.html#circ">circ</a> + <a href="refR.html#rot">rot</a> + <a href="refL.html#list">list</a> + <a href="refN.html#need">need</a> + <a href="refR.html#range">range</a> + <a href="refF.html#full">full</a> + <a href="refM.html#make">make</a> + <a href="refM.html#made">made</a> + <a href="refC.html#chain">chain</a> + <a href="refL.html#link">link</a> + <a href="refY.html#yoke">yoke</a> + <a href="refC.html#copy">copy</a> + <a href="refM.html#mix">mix</a> + <a href="refA.html#append">append</a> + <a href="refD.html#delete">delete</a> + <a href="refD.html#delq">delq</a> + <a href="refR.html#replace">replace</a> + <a href="refI.html#insert">insert</a> + <a href="refR.html#remove">remove</a> + <a href="refP.html#place">place</a> + <a href="refS.html#strip">strip</a> + <a href="refS.html#split">split</a> + <a href="refR.html#reverse">reverse</a> + <a href="refF.html#flip">flip</a> + <a href="refT.html#trim">trim</a> + <a href="refC.html#clip">clip</a> + <a href="refH.html#head">head</a> + <a href="refT.html#tail">tail</a> + <a href="refS.html#stem">stem</a> + <a href="refF.html#fin">fin</a> + <a href="refL.html#last">last</a> + <a href="refM.html#member">member</a> + <a href="refM.html#memq">memq</a> + <a href="refM.html#mmeq">mmeq</a> + <a href="refS.html#sect">sect</a> + <a href="refD.html#diff">diff</a> + <a href="refI.html#index">index</a> + <a href="refO.html#offset">offset</a> + <a href="refA.html#assoc">assoc</a> + <a href="refA.html#asoq">asoq</a> + <a href="refR.html#rank">rank</a> + <a href="refS.html#sort">sort</a> + <a href="refU.html#uniq">uniq</a> + <a href="refG.html#group">group</a> + <a href="refL.html#length">length</a> + <a href="refS.html#size">size</a> + <a href="refV.html#val">val</a> + <a href="refS.html#set">set</a> + <a href="refX.html#xchg">xchg</a> + <a href="refP.html#push">push</a> + <a href="refP.html#push1">push1</a> + <a href="refP.html#pop">pop</a> + <a href="refC.html#cut">cut</a> + <a href="refQ.html#queue">queue</a> + <a href="refF.html#fifo">fifo</a> + <a href="refI.html#idx">idx</a> + <a href="refB.html#balance">balance</a> + <a href="refG.html#get">get</a> + <a href="refF.html#fill">fill</a> + <a href="refA.html#apply">apply</a> +</code> + +<dt>Control Flow +<dd><code> + <a href="refL.html#load">load</a> + <a href="refA.html#args">args</a> + <a href="refN.html#next">next</a> + <a href="refA.html#arg">arg</a> + <a href="refR.html#rest">rest</a> + <a href="refP.html#pass">pass</a> + <a href="refQ.html#quote">quote</a> + <a href="refA.html#as">as</a> + <a href="refP.html#pid">pid</a> + <a href="refL.html#lit">lit</a> + <a href="refE.html#eval">eval</a> + <a href="refR.html#run">run</a> + <a href="refM.html#macro">macro</a> + <a href="refC.html#curry">curry</a> + <a href="refD.html#def">def</a> + <a href="refD.html#de">de</a> + <a href="refD.html#dm">dm</a> + <a href="refR.html#recur">recur</a> + <a href="refR.html#recurse">recurse</a> + <a href="refU.html#undef">undef</a> + <a href="refB.html#box">box</a> + <a href="refN.html#new">new</a> + <a href="refT.html#type">type</a> + <a href="refI.html#isa">isa</a> + <a href="refM.html#method">method</a> + <a href="refM.html#meth">meth</a> + <a href="refS.html#send">send</a> + <a href="refT.html#try">try</a> + <a href="refS.html#super">super</a> + <a href="refE.html#extra">extra</a> + <a href="refW.html#with">with</a> + <a href="refB.html#bind">bind</a> + <a href="refJ.html#job">job</a> + <a href="refL.html#let">let</a> + <a href="refL.html#let?">let?</a> + <a href="refU.html#use">use</a> + <a href="refA.html#and">and</a> + <a href="refO.html#or">or</a> + <a href="refN.html#nand">nand</a> + <a href="refN.html#nor">nor</a> + <a href="refX.html#xor">xor</a> + <a href="refB.html#bool">bool</a> + <a href="refN.html#not">not</a> + <a href="refN.html#nil">nil</a> + <a href="refT.html#t">t</a> + <a href="refP.html#prog">prog</a> + <a href="refP.html#prog1">prog1</a> + <a href="refP.html#prog2">prog2</a> + <a href="refI.html#if">if</a> + <a href="refI.html#if2">if2</a> + <a href="refI.html#ifn">ifn</a> + <a href="refW.html#when">when</a> + <a href="refU.html#unless">unless</a> + <a href="refC.html#cond">cond</a> + <a href="refN.html#nond">nond</a> + <a href="refC.html#case">case</a> + <a href="refS.html#state">state</a> + <a href="refW.html#while">while</a> + <a href="refU.html#until">until</a> + <a href="refL.html#loop">loop</a> + <a href="refD.html#do">do</a> + <a href="refA.html#at">at</a> + <a href="refF.html#for">for</a> + <a href="refC.html#catch">catch</a> + <a href="refT.html#throw">throw</a> + <a href="refF.html#finally">finally</a> + <a href="ref_.html#!">!</a> + <a href="refE.html#e">e</a> + <a href="ref_.html#$">$</a> + <a href="refS.html#sys">sys</a> + <a href="refC.html#call">call</a> + <a href="refT.html#tick">tick</a> + <a href="refI.html#ipid">ipid</a> + <a href="refO.html#opid">opid</a> + <a href="refK.html#kill">kill</a> + <a href="refQ.html#quit">quit</a> + <a href="refT.html#task">task</a> + <a href="refF.html#fork">fork</a> + <a href="refP.html#pipe">pipe</a> + <a href="refL.html#later">later</a> + <a href="refT.html#timeout">timeout</a> + <a href="refA.html#abort">abort</a> + <a href="refB.html#bye">bye</a> +</code> + +<dt>Mapping +<dd><code> + <a href="refA.html#apply">apply</a> + <a href="refP.html#pass">pass</a> + <a href="refM.html#maps">maps</a> + <a href="refM.html#map">map</a> + <a href="refM.html#mapc">mapc</a> + <a href="refM.html#maplist">maplist</a> + <a href="refM.html#mapcar">mapcar</a> + <a href="refM.html#mapcon">mapcon</a> + <a href="refM.html#mapcan">mapcan</a> + <a href="refF.html#filter">filter</a> + <a href="refE.html#extract">extract</a> + <a href="refS.html#seek">seek</a> + <a href="refF.html#find">find</a> + <a href="refP.html#pick">pick</a> + <a href="refC.html#cnt">cnt</a> + <a href="refS.html#sum">sum</a> + <a href="refM.html#maxi">maxi</a> + <a href="refM.html#mini">mini</a> + <a href="refF.html#fish">fish</a> + <a href="refB.html#by">by</a> +</code> + +<dt>Input/Output +<dd><code> + <a href="refP.html#path">path</a> + <a href="refI.html#in">in</a> + <a href="refI.html#ipid">ipid</a> + <a href="refO.html#out">out</a> + <a href="refO.html#opid">opid</a> + <a href="refP.html#pipe">pipe</a> + <a href="refC.html#ctl">ctl</a> + <a href="refA.html#any">any</a> + <a href="refS.html#sym">sym</a> + <a href="refS.html#str">str</a> + <a href="refL.html#load">load</a> + <a href="refH.html#hear">hear</a> + <a href="refT.html#tell">tell</a> + <a href="refK.html#key">key</a> + <a href="refP.html#poll">poll</a> + <a href="refP.html#peek">peek</a> + <a href="refC.html#char">char</a> + <a href="refS.html#skip">skip</a> + <a href="refE.html#eol">eol</a> + <a href="refE.html#eof">eof</a> + <a href="refF.html#from">from</a> + <a href="refT.html#till">till</a> + <a href="refL.html#line">line</a> + <a href="refF.html#format">format</a> + <a href="refS.html#scl">scl</a> + <a href="refR.html#read">read</a> + <a href="refP.html#print">print</a> + <a href="refP.html#println">println</a> + <a href="refP.html#printsp">printsp</a> + <a href="refP.html#prin">prin</a> + <a href="refP.html#prinl">prinl</a> + <a href="refM.html#msg">msg</a> + <a href="refS.html#space">space</a> + <a href="refB.html#beep">beep</a> + <a href="refT.html#tab">tab</a> + <a href="refF.html#flush">flush</a> + <a href="refR.html#rewind">rewind</a> + <a href="refR.html#rd">rd</a> + <a href="refP.html#pr">pr</a> + <a href="refW.html#wr">wr</a> + <a href="refR.html#rpc">rpc</a> + <a href="refW.html#wait">wait</a> + <a href="refS.html#sync">sync</a> + <a href="refE.html#echo">echo</a> + <a href="refI.html#info">info</a> + <a href="refF.html#file">file</a> + <a href="refD.html#dir">dir</a> + <a href="refL.html#lines">lines</a> + <a href="refO.html#open">open</a> + <a href="refC.html#close">close</a> + <a href="refP.html#port">port</a> + <a href="refL.html#listen">listen</a> + <a href="refA.html#accept">accept</a> + <a href="refH.html#host">host</a> + <a href="refC.html#connect">connect</a> + <a href="refU.html#udp">udp</a> + <a href="refS.html#script">script</a> + <a href="refO.html#once">once</a> + <a href="refR.html#rc">rc</a> + <a href="refA.html#acquire">acquire</a> + <a href="refR.html#release">release</a> + <a href="refP.html#pretty">pretty</a> + <a href="refP.html#pp">pp</a> + <a href="refS.html#show">show</a> + <a href="refV.html#view">view</a> + <a href="refH.html#here">here</a> + <a href="refP.html#prEval">prEval</a> + <a href="refM.html#mail">mail</a> +</code> + +<dt>Object Orientation +<dd><code> + <a href="refC.html#*Class">*Class</a> + <a href="refC.html#class">class</a> + <a href="refD.html#dm">dm</a> + <a href="refR.html#rel">rel</a> + <a href="refV.html#var">var</a> + <a href="refV.html#var:">var:</a> + <a href="refN.html#new">new</a> + <a href="refT.html#type">type</a> + <a href="refI.html#isa">isa</a> + <a href="refM.html#method">method</a> + <a href="refM.html#meth">meth</a> + <a href="refS.html#send">send</a> + <a href="refT.html#try">try</a> + <a href="refO.html#object">object</a> + <a href="refE.html#extend">extend</a> + <a href="refS.html#super">super</a> + <a href="refE.html#extra">extra</a> + <a href="refW.html#with">with</a> + <a href="refT.html#This">This</a> + <a href="refC.html#can">can</a> + <a href="refD.html#dep">dep</a> +</code> + +<dt>Database +<dd><code> + <a href="refP.html#pool">pool</a> + <a href="refJ.html#journal">journal</a> + <a href="refI.html#id">id</a> + <a href="refS.html#seq">seq</a> + <a href="refL.html#lieu">lieu</a> + <a href="refL.html#lock">lock</a> + <a href="refC.html#commit">commit</a> + <a href="refR.html#rollback">rollback</a> + <a href="refM.html#mark">mark</a> + <a href="refF.html#free">free</a> + <a href="refD.html#dbck">dbck</a> + <a href="refD.html#dbs">dbs</a> + <a href="refD.html#dbs+">dbs+</a> + <a href="refD.html#db:">db:</a> + <a href="refT.html#tree">tree</a> + <a href="refD.html#db">db</a> + <a href="refA.html#aux">aux</a> + <a href="refC.html#collect">collect</a> + <a href="refG.html#genKey">genKey</a> + <a href="refU.html#useKey">useKey</a> + <a href="refR.html#+relation">+relation</a> + <a href="refA.html#+Any">+Any</a> + <a href="refB.html#+Bag">+Bag</a> + <a href="refB.html#+Bool">+Bool</a> + <a href="refN.html#+Number">+Number</a> + <a href="refD.html#+Date">+Date</a> + <a href="refT.html#+Time">+Time</a> + <a href="refS.html#+Symbol">+Symbol</a> + <a href="refS.html#+String">+String</a> + <a href="refL.html#+Link">+Link</a> + <a href="refJ.html#+Joint">+Joint</a> + <a href="refB.html#+Blob">+Blob</a> + <a href="refH.html#+Hook">+Hook</a> + <a href="refI.html#+index">+index</a> + <a href="refK.html#+Key">+Key</a> + <a href="refR.html#+Ref">+Ref</a> + <a href="refR.html#+Ref2">+Ref2</a> + <a href="refI.html#+Idx">+Idx</a> + <a href="refS.html#+Sn">+Sn</a> + <a href="refF.html#+Fold">+Fold</a> + <a href="refA.html#+Aux">+Aux</a> + <a href="refD.html#+Dep">+Dep</a> + <a href="refL.html#+List">+List</a> + <a href="refN.html#+Need">+Need</a> + <a href="refM.html#+Mis">+Mis</a> + <a href="refA.html#+Alt">+Alt</a> + <a href="refB.html#blob">blob</a> + <a href="refD.html#dbSync">dbSync</a> + <a href="refN.html#new!">new!</a> + <a href="refS.html#set!">set!</a> + <a href="refP.html#put!">put!</a> + <a href="refI.html#inc!">inc!</a> + <a href="refB.html#blob!">blob!</a> + <a href="refU.html#upd">upd</a> + <a href="refR.html#rel">rel</a> + <a href="refR.html#request">request</a> + <a href="refO.html#obj">obj</a> + <a href="refF.html#fmt64">fmt64</a> + <a href="refR.html#root">root</a> + <a href="refF.html#fetch">fetch</a> + <a href="refS.html#store">store</a> + <a href="refC.html#count">count</a> + <a href="refL.html#leaf">leaf</a> + <a href="refM.html#minKey">minKey</a> + <a href="refM.html#maxKey">maxKey</a> + <a href="refI.html#init">init</a> + <a href="refS.html#step">step</a> + <a href="refS.html#scan">scan</a> + <a href="refI.html#iter">iter</a> + <a href="refP.html#prune">prune</a> + <a href="refZ.html#zapTree">zapTree</a> + <a href="refC.html#chkTree">chkTree</a> + <a href="refD.html#db/3">db/3</a> + <a href="refD.html#db/4">db/4</a> + <a href="refD.html#db/5">db/5</a> + <a href="refV.html#val/3">val/3</a> + <a href="refL.html#lst/3">lst/3</a> + <a href="refM.html#map/3">map/3</a> + <a href="refI.html#isa/2">isa/2</a> + <a href="refS.html#same/3">same/3</a> + <a href="refB.html#bool/3">bool/3</a> + <a href="refR.html#range/3">range/3</a> + <a href="refH.html#head/3">head/3</a> + <a href="refF.html#fold/3">fold/3</a> + <a href="refP.html#part/3">part/3</a> + <a href="refT.html#tolr/3">tolr/3</a> + <a href="refS.html#select/3">select/3</a> + <a href="refR.html#remote/2">remote/2</a> +</code> + +<dt>Pilog +<dd><code> + <a href="refP.html#prove">prove</a> + <a href="ref_.html#->">-&gt</a> + <a href="refU.html#unify">unify</a> + <a href="refB.html#be">be</a> + <a href="refR.html#repeat">repeat</a> + <a href="refA.html#asserta">asserta</a> + <a href="refA.html#assertz">assertz</a> + <a href="refR.html#retract">retract</a> + <a href="refR.html#rules">rules</a> + <a href="refG.html#goal">goal</a> + <a href="refF.html#fail">fail</a> + <a href="refP.html#pilog">pilog</a> + <a href="refS.html#solve">solve</a> + <a href="refQ.html#query">query</a> + <a href="ref_.html#?">?</a> + <a href="refR.html#repeat/0">repeat/0</a> + <a href="refF.html#fail/0">fail/0</a> + <a href="refT.html#true/0">true/0</a> + <a href="refN.html#not/1">not/1</a> + <a href="refC.html#call/1">call/1</a> + <a href="refO.html#or/2">or/2</a> + <a href="refN.html#nil/1">nil/1</a> + <a href="refE.html#equal/2">equal/2</a> + <a href="refD.html#different/2">different/2</a> + <a href="refA.html#append/3">append/3</a> + <a href="refM.html#member/2">member/2</a> + <a href="refD.html#delete/3">delete/3</a> + <a href="refP.html#permute/2">permute/2</a> + <a href="refU.html#uniq/2">uniq/2</a> + <a href="refA.html#asserta/1">asserta/1</a> + <a href="refA.html#assertz/1">assertz/1</a> + <a href="refR.html#retract/1">retract/1</a> + <a href="refC.html#clause/2">clause/2</a> + <a href="refS.html#show/1">show/1</a> + <a href="refD.html#db/3">db/3</a> + <a href="refD.html#db/4">db/4</a> + <a href="refD.html#db/5">db/5</a> + <a href="refV.html#val/3">val/3</a> + <a href="refL.html#lst/3">lst/3</a> + <a href="refM.html#map/3">map/3</a> + <a href="refI.html#isa/2">isa/2</a> + <a href="refS.html#same/3">same/3</a> + <a href="refB.html#bool/3">bool/3</a> + <a href="refR.html#range/3">range/3</a> + <a href="refH.html#head/3">head/3</a> + <a href="refF.html#fold/3">fold/3</a> + <a href="refP.html#part/3">part/3</a> + <a href="refT.html#tolr/3">tolr/3</a> + <a href="refS.html#select/3">select/3</a> + <a href="refR.html#remote/2">remote/2</a> +</code> + +<dt>Debugging +<dd><code> + <a href="refP.html#pretty">pretty</a> + <a href="refP.html#pp">pp</a> + <a href="refS.html#show">show</a> + <a href="refL.html#loc">loc</a> + <a href="refD.html#*Dbg">*Dbg</a> + <a href="refD.html#doc">doc</a> + <a href="refM.html#more">more</a> + <a href="refD.html#depth">depth</a> + <a href="refW.html#what">what</a> + <a href="refW.html#who">who</a> + <a href="refC.html#can">can</a> + <a href="refD.html#dep">dep</a> + <a href="refD.html#debug">debug</a> + <a href="refD.html#d">d</a> + <a href="refU.html#unbug">unbug</a> + <a href="refU.html#u">u</a> + <a href="refV.html#vi">vi</a> + <a href="refL.html#ld">ld</a> + <a href="refT.html#trace">trace</a> + <a href="refU.html#untrace">untrace</a> + <a href="refT.html#traceAll">traceAll</a> + <a href="refP.html#proc">proc</a> + <a href="refH.html#hd">hd</a> + <a href="refB.html#bench">bench</a> + <a href="refE.html#edit">edit</a> + <a href="refL.html#lint">lint</a> + <a href="refL.html#lintAll">lintAll</a> + <a href="refS.html#select">select</a> + <a href="refU.html#update">update</a> +</code> + +<dt>System Functions +<dd><code> + <a href="refC.html#cmd">cmd</a> + <a href="refA.html#argv">argv</a> + <a href="refO.html#opt">opt</a> + <a href="refV.html#version">version</a> + <a href="refG.html#gc">gc</a> + <a href="refR.html#raw">raw</a> + <a href="refA.html#alarm">alarm</a> + <a href="refP.html#protect">protect</a> + <a href="refH.html#heap">heap</a> + <a href="refE.html#env">env</a> + <a href="refU.html#up">up</a> + <a href="refD.html#date">date</a> + <a href="refT.html#time">time</a> + <a href="refU.html#usec">usec</a> + <a href="refS.html#stamp">stamp</a> + <a href="refD.html#dat$">dat$</a> + <a href="ref_.html#$dat">$dat</a> + <a href="refD.html#datSym">datSym</a> + <a href="refD.html#datStr">datStr</a> + <a href="refS.html#strDat">strDat</a> + <a href="refE.html#expDat">expDat</a> + <a href="refD.html#day">day</a> + <a href="refW.html#week">week</a> + <a href="refU.html#ultimo">ultimo</a> + <a href="refT.html#tim$">tim$</a> + <a href="ref_.html#$tim">$tim</a> + <a href="refT.html#telStr">telStr</a> + <a href="refE.html#expTel">expTel</a> + <a href="refL.html#locale">locale</a> + <a href="refA.html#allowed">allowed</a> + <a href="refA.html#allow">allow</a> + <a href="refP.html#pwd">pwd</a> + <a href="refC.html#cd">cd</a> + <a href="refC.html#chdir">chdir</a> + <a href="refC.html#ctty">ctty</a> + <a href="refI.html#info">info</a> + <a href="refD.html#dir">dir</a> + <a href="refD.html#dirname">dirname</a> + <a href="refE.html#errno">errno</a> + <a href="refN.html#native">native</a> + <a href="refC.html#call">call</a> + <a href="refT.html#tick">tick</a> + <a href="refK.html#kill">kill</a> + <a href="refQ.html#quit">quit</a> + <a href="refT.html#task">task</a> + <a href="refF.html#fork">fork</a> + <a href="refF.html#forked">forked</a> + <a href="refP.html#pipe">pipe</a> + <a href="refT.html#timeout">timeout</a> + <a href="refM.html#mail">mail</a> + <a href="refT.html#test">test</a> + <a href="refB.html#bye">bye</a> +</code> + +<dt>Globals +<dd><code> + <a href="#nilSym">NIL</a> + <a href="refO.html#*OS">*OS</a> + <a href="refD.html#*DB">*DB</a> + <a href="refT.html#T">T</a> + <a href="refS.html#*Solo">*Solo</a> + <a href="refP.html#*PPid">*PPid</a> + <a href="refP.html#*Pid">*Pid</a> + <a href="ref_.html#@">@</a> + <a href="ref_.html#@@">@@</a> + <a href="ref_.html#@@@">@@@</a> + <a href="refT.html#This">This</a> + <a href="refD.html#*Dbg">*Dbg</a> + <a href="refZ.html#*Zap">*Zap</a> + <a href="refS.html#*Scl">*Scl</a> + <a href="refC.html#*Class">*Class</a> + <a href="refD.html#*Dbs">*Dbs</a> + <a href="refR.html#*Run">*Run</a> + <a href="refR.html#*Hup">*Hup</a> + <a href="refS.html#*Sig1">*Sig1</a> + <a href="refS.html#*Sig2">*Sig2</a> + <a href="ref_.html#^">^</a> + <a href="refE.html#*Err">*Err</a> + <a href="refM.html#*Msg">*Msg</a> + <a href="refU.html#*Uni">*Uni</a> + <a href="refL.html#*Led">*Led</a> + <a href="refT.html#*Tsm">*Tsm</a> + <a href="refA.html#*Adr">*Adr</a> + <a href="refA.html#*Allow">*Allow</a> + <a href="refF.html#*Fork">*Fork</a> + <a href="refB.html#*Bye">*Bye</a> +</code> + +</dl> + +<p><hr> +<h2><a name="down">Download</a></h2> + +<p>The <code>PicoLisp</code> system can be downloaded from the <a +href="http://software-lab.de/down.html">PicoLisp Download</a> page. + +</body> +</html> diff --git a/doc/refA.html b/doc/refA.html @@ -0,0 +1,567 @@ +<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.0 Transitional//EN" "http://www.w3.org/TR/1998/REC-html40-19980424/loose.dtd"> +<html lang="en"> +<head> +<meta http-equiv="Content-Type" content="text/html; charset=utf-8"> +<title>A</title> +<link rel="stylesheet" href="doc.css" type="text/css"> +</head> +<body> + +<h1>A</h1> + +<dl> + +<dt><a name="*Adr"><code>*Adr</code></a> +<dd>A global variable holding the IP address of last recently accepted client. +See also <code><a href="refL.html#listen">listen</a></code> and <code><a +href="refA.html#accept">accept</a></code>. + +<pre><code> +: *Adr +-> "127.0.0.1" +</code></pre> + +<dt><a name="*Allow"><code>*Allow</code></a> +<dd>A global variable holding allowed access patterns. If its value is +non-<code>NIL</code>, it should contain a list where the CAR is an <code><a +href="refI.html#idx">idx</a></code> tree of allowed items, and the CDR a list of +prefix strings. See also <code><a href="refA.html#allow">allow</a></code>, +<code><a href="refA.html#allowed">allowed</a></code> and <code><a +href="refP.html#pre?">pre?</a></code>. + +<pre><code> +: (allowed ("app/" "img/") # Initialize + "@start" "@stop" "favicon.ico" "lib.css" "@psh" ) +-> NIL +: (allow "@myFoo") # additional item +-> "@myFoo" +: (allow "myDir/" T) # additional prefix +-> "myDir/" + +: *Allow +-> (("@stop" ("@psh" ("@myFoo") "@start") "favicon.ico" NIL "lib.css") "app/" "img/" "myDir/") + +: (idx *Allow) # items +-> ("@myFoo" "@psh" "@start" "@stop" "favicon.ico" "lib.css") +: (cdr *Allow) # prefixes +-> ("app/" "img/" "myDir/") +</code></pre> + +<dt><a name="+Alt"><code>+Alt</code></a> +<dd>Prefix class specifying an alternative class for a <code><a +href="refR.html#+relation">+relation</a></code>. This allows indexes or other +side effects to be maintained in a class different from the current one. See +also <code><a href="ref.html#dbase">Database</a></code>. + +<pre><code> +(class +EuOrd +Ord) # EU-specific order subclass +(rel nr (+Alt +Key +Number) +XyOrd) # Maintain the key in the +XyOrd index +</code></pre> + +<dt><a name="+Any"><code>+Any</code></a> +<dd>Class for unspecified relations, a subclass of <code><a +href="refR.html#+relation">+relation</a></code>. 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 <code><a +href="ref.html#dbase">Database</a></code>. + +<p>In the following example <code>+Any</code> is used simply for the reason that +there is no direct way to specify dotted pairs: + +<pre><code> +(rel loc (+Any)) # Locale, e.g. ("DE" . "de") +</code></pre> + +<dt><a name="+Aux"><code>+Aux</code></a> +<dd>Prefix class maintaining auxiliary keys for <code><a +href="refR.html#+relation">+relation</a></code>s, in addition to <code><a +href="refR.html#+Ref">+Ref</a></code> or <code><a +href="refI.html#+Idx">+Idx</a></code> 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 <code><a href="refA.html#aux">aux</a></code> and <code><a +href="ref.html#dbase">Database</a></code>. + +<pre><code> +(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 +</code></pre> + +<dt><a name="abort"><code>(abort 'cnt . prg) -> any</code></a> +<dd>Aborts the execution of <code>prg</code> if it takes longer than +<code>cnt</code> seconds, and returns <code>NIL</code>. Otherwise, the result of +<code>prg</code> is returned. <code><a href="refA.html#alarm">alarm</a></code> +is used internally, so care must be taken not to interfer with other calls to +<code>alarm</code>. + +<pre><code> +: (abort 20 (in Sock (rd))) # Wait maximally 20 seconds for socket data +</code></pre> + +<dt><a name="abs"><code>(abs 'num) -> num</code></a> +<dd>Returns the absolute value of the <code>num</code> argument. + +<pre><code> +: (abs -7) +-> 7 +: (abs 7) +-> 7 +</code></pre> + +<dt><a name="accept"><code>(accept 'cnt) -> cnt | NIL</code></a> +<dd>Accepts a connection on descriptor <code>cnt</code> (as received by <code><a +href="refP.html#port">port</a></code>), and returns the new socket descriptor +<code>cnt</code>. The global variable <code>*Adr</code> is set to the IP address +of the client. See also <code><a href="refL.html#listen">listen</a></code>, +<code><a href="refC.html#connect">connect</a></code> and <code><a +href="refA.html#*Adr">*Adr</a></code>. + +<pre><code> +: (setq *Socket + (accept (port 6789)) ) # Accept connection at port 6789 +-> 4 +</code></pre> + +<dt><a name="accu"><code>(accu 'var 'any 'num)</code></a> +<dd>Accumulates <code>num</code> into a sum, using the key <code>any</code> in +an association list stored in <code>var</code>. See also <code><a +href="refA.html#assoc">assoc</a></code>. + +<pre><code> +: (off Sum) +-> NIL +: (accu 'Sum 'a 1) +-> (a . 1) +: (accu 'Sum 'a 5) +-> 6 +: (accu 'Sum 22 100) +-> (22 . 100) +: Sum +-> ((22 . 100) (a . 6)) +</code></pre> + +<dt><a name="acquire"><code>(acquire 'sym) -> flg</code></a> +<dd>Tries to acquire the mutex represented by the file <code>sym</code>, by +obtaining an exclusive lock on that file with <code><a +href="refC.html#ctl">ctl</a></code>, 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 <code><a +href="refR.html#release">release</a></code>, <code><a +href="refP.html#*Pid">*Pid</a></code> and <code><a +href="refR.html#rc">rc</a></code>. + +<pre><code> +: (acquire "sema1") +-> 28255 +</code></pre> + +<dt><a name="alarm"><code>(alarm 'cnt . prg) -> cnt</code></a> +<dd>Sets an alarm timer scheduling <code>prg</code> to be executed after +<code>cnt</code> seconds, and returns the number of seconds remaining until any +previously scheduled alarm was due to be delivered. Calling <code>(alarm +0)</code> will cancel an alarm. + +<pre><code> +: (prinl (tim$ (time) T)) (alarm 10 (prinl (tim$ (time) T))) +16:36:14 +-> 0 +: 16:36:24 + +: (alarm 10 (bye 0)) +-> 0 +$ +</code></pre> + +<dt><a name="align"><code>(align 'cnt 'any) -> sym</code></a> +<dt><code>(align 'lst 'any ..) -> sym</code> +<dd>Returns a transient symbol with all <code>any</code> arguments <code><a +href="refP.html#pack">pack</a></code>ed in an aligned format. In the first form, +<code>any</code> will be left-aligned if <code>cnt</code> ist negative, +otherwise right-aligned. In the second form, all <code>any</code> arguments are +packed according to the numbers in <code>lst</code>. See also <code><a +href="refT.html#tab">tab</a></code>, <code><a +href="refC.html#center">center</a></code> and <code><a +href="refW.html#wrap">wrap</a></code>. + +<pre><code> +: (align 4 "a") +-> " a" +: (align -4 12) +-> "12 " +: (align (4 4 4) "a" 12 "b") +-> " a 12 b" +</code></pre> + +<dt><a name="all"><code>(all ['T | '0]) -> lst</code></a> +<dd>Returns a new list of all <a href="ref.html#internal">internal</a> symbols +in the system (if called without arguments, or with <code>NIL</code>). Otherwise +(if the argument is <code>T</code>), all current <a +href="ref.html#transient">transient</a> symbols are returned. Else all current +<a href="ref.html#external">external</a> symbols are returned. + +<pre><code> +: (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 ... +</code></pre> + +<dt><a name="allow"><code>(allow 'sym ['flg]) -> sym</code></a> +<dd>Maintains an index structure of allowed access patterns in the global +variable <code><a href="refA.html#*Allow">*Allow</a></code>. If the value of +<code>*Allow</code> is non-<code>NIL</code>, <code>sym</code> is added to the +<code><a href="refI.html#idx">idx</a></code> tree in the CAR of +<code>*Allow</code> (if <code>flg</code> is <code>NIL</code>), or to the list of +prefix strings (if <code>flg</code> is non-<code>NIL</code>). See also <code><a +href="refA.html#allowed">allowed</a></code>. + +<pre><code> +: *Allow +-> (("@stop" ("@psh" NIL "@start") "favicon.ico" NIL "lib.css") "app/" "img/") +: (allow "@myFoo") # additionally allowed item +-> "@myFoo" +: (allow "myDir/" T) # additionally allowed prefix +-> "myDir/" +</code></pre> + +<dt><a name="allowed"><code>(allowed lst [sym ..])</code></a> +<dd>Creates an index structure of allowed access patterns in the global variable +<code><a href="refA.html#*Allow">*Allow</a></code>. <code>lst</code> should +consist of prefix strings (to be checked at runtime with <code><a +href="refP.html#pre?">pre?</a></code>), and the <code>sym</code> arguments +should specify the initially allowed items. See also <code><a +href="refA.html#allow">allow</a></code>. + +<pre><code> +: (allowed ("app/" "img/") # allowed prefixes + "@start" "@stop" "favicon.ico" "lib.css" "@psh" ) # allowed items +-> NIL +</code></pre> + +<dt><a name="and"><code>(and 'any ..) -> any</code></a> +<dd>Logical AND. The expressions <code>any</code> are evaluated from left to +right. If <code>NIL</code> is encountered, <code>NIL</code> is returned +immediately. Else the result of the last expression is returned. + +<pre><code> +: (and (= 3 3) (read)) +abc # User input +-> abc +: (and (= 3 4) (read)) +-> NIL +</code></pre> + +<dt><a name="any"><code>(any 'sym) -> any</code></a> +<dd>Parses <code>any</code> from the name of <code>sym</code>. This is the +reverse operation of <code><a href="refS.html#sym">sym</a></code>. See also +<code><a href="refS.html#str">str</a></code>. + +<pre><code> +: (any "(a b # Comment^Jc d)") +-> (a b c d) +: (any "\"A String\"") +-> "A String" +</code></pre> + +<dt><a name="append"><code>(append 'lst ..) -> lst</code></a> +<dd>Appends all argument lists. See also <code><a +href="refC.html#conc">conc</a></code>, <code><a +href="refI.html#insert">insert</a></code>, <code><a +href="refD.html#delete">delete</a></code> and <code><a +href="refR.html#remove">remove</a></code>. + +<pre><code> +: (append '(a b c) (1 2 3)) +-> (a b c 1 2 3) +: (append (1) (2) (3) 4) +-> (1 2 3 . 4) +</code></pre> + +<dt><a name="append/3"><code>append/3</code></a> +<dd><a href="ref.html#pilog">Pilog</a> predicate that succeeds if appending the +first two list arguments is equal to the third argument. See also <code><a +href="refA.html#append">append</a></code> and <code><a +href="refM.html#member/2">member/2</a></code>. + +<pre><code> +: (? (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 +</code></pre> + +<dt><a name="apply"><code>(apply 'fun 'lst ['any ..]) -> any</code></a> +<dd>Applies <code>fun</code> to <code>lst</code>. If additional <code>any</code> +arguments are given, they are applied as leading elements of <code>lst</code>. +<code>(apply 'fun 'lst 'any1 'any2)</code> is equivalent to <code>(apply 'fun +(cons 'any1 'any2 'lst))</code>. + +<pre><code> +: (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 +</code></pre> + +<dt><a name="arg"><code>(arg ['cnt]) -> any</code></a> +<dd>Can only be used inside functions with a variable number of arguments (with +<code>@</code>). If <code>cnt</code> is not given, the value that was returned +from the last call to <code>next</code>) is returned. Otherwise, the +<code>cnt</code>'th remaining argument is returned. See also <code><a +href="refA.html#args">args</a></code>, <code><a +href="refN.html#next">next</a></code>, <code><a +href="refR.html#rest">rest</a></code> and <code><a +href="refP.html#pass">pass</a></code>. + +<pre><code> +: (de foo @ (println (next) (arg))) # Print argument twice +-> foo +: (foo 123) +123 123 +-> 123 +: (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 +</code></pre> + +<dt><a name="args"><code>(args) -> flg</code></a> +<dd>Can only be used inside functions with a variable number of arguments (with +<code>@</code>). Returns <code>T</code> when there are more arguments to be +fetched from the internal list. See also <code><a +href="refN.html#next">next</a></code>, <code><a +href="refA.html#arg">arg</a></code>, <code><a +href="refR.html#rest">rest</a></code> and <code><a +href="refP.html#pass">pass</a></code>. + +<pre><code> +: (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 +</code></pre> + +<dt><a name="argv"><code>(argv [var ..] [. sym]) -> lst|sym</code></a> +<dd>If called without arguments, <code>argv</code> returns a list of strings +containing all remaining command line arguments. Otherwise, the +<code>var/sym</code> arguments are subsequently bound to the command line +arguments. A hyphen "<code>-</code>" can be used to stop <code>load</code>ing +further arguments. See also <code><a href="refC.html#cmd">cmd</a></code>, +<code><a href="ref.html#invoc">Invocation</a></code> and <code><a +href="refO.html#opt">opt</a></code>. + +<pre><code> +$ ./p -"println 'OK" - abc 123 +OK +: (argv) +-> ("abc" "123") +: (argv A B) +-> "123" +: A +-> "abc" +: B +-> "123" +: (argv . Lst) +-> ("abc" "123") +: Lst +-> ("abc" "123") +</code></pre> + +<dt><a name="as"><code>(as 'any1 . any2) -> any2 | NIL</code></a> +<dd>Returns <code>any2</code> unevaluated when <code>any1</code> evaluates to +non-<code>NIL</code>. Otherwise <code>NIL</code> is returned. <code>(as Flg A B +C)</code> is equivalent to <code>(and Flg '(A B C))</code>. See also <code><a +href="refQ.html#quote">quote</a></code>. + +<pre><code> +: (as (= 3 3) A B C) +-> (A B C) +</code></pre> + +<dt><a name="asoq"><code>(asoq 'any 'lst) -> lst</code></a> +<dd>Searches an association list. Returns the first element from +<code>lst</code> with <code>any</code> as its CAR, or <code>NIL</code> if no +match is found. <code><a href="ref_.html#==">==</a></code> is used for +comparison (pointer equality). See also <code><a +href="refA.html#assoc">assoc</a></code>, <code><a +href="refD.html#delq">delq</a></code>, <code><a +href="refM.html#memq">memq</a></code>, <code><a +href="refM.html#mmeq">mmeq</a></code> and <a href="ref.html#cmp">Comparing</a>. + +<pre><code> +: (asoq 999 '((999 1 2 3) (b . 7) ("ok" "Hello"))) +-> NIL +: (asoq 'b '((999 1 2 3) (b . 7) ("ok" "Hello"))) +-> (b . 7) +</code></pre> + +<dt><a name="asserta"><code>(asserta 'lst) -> lst</code></a> +<dd>Inserts a new <a href="ref.html#pilog">Pilog</a> fact or rule before all +other rules. See also <code><a href="refB.html#be">be</a></code>, <code><a +href="refA.html#assertz">assertz</a></code> and <code><a +href="refR.html#retract">retract</a></code>. + +<pre><code> +: (be a (2)) # Define two facts +-> a +: (be a (3)) +-> a + +: (asserta '(a (1))) # Insert new fact in front +-> (((1)) ((2)) ((3))) + +: (? (a @N)) # Query + @N=1 + @N=2 + @N=3 +-> NIL +</code></pre> + +<dt><a name="asserta/1"><code>asserta/1</code></a> +<dd><a href="ref.html#pilog">Pilog</a> predicate that inserts a new fact or rule +before all other rules. See also <code><a +href="refA.html#asserta">asserta</a></code>, <code><a +href="refA.html#assertz/1">assertz/1</a></code> and <code><a +href="refR.html#retract/1">retract/1</a></code>. + +<pre><code> +: (? (asserta (a (2)))) +-> T +: (? (asserta (a (1)))) +-> T +: (rules 'a) +1 (be a (1)) +2 (be a (2)) +-> a +</code></pre> + +<dt><a name="assertz"><code>(assertz 'lst) -> lst</code></a> +<dd>Appends a new <a href="ref.html#pilog">Pilog</a> fact or rule behind all +other rules. See also <code><a href="refB.html#be">be</a></code>, <code><a +href="refA.html#asserta">asserta</a></code> and <code><a +href="refR.html#retract">retract</a></code>. + +<pre><code> +: (be a (1)) # Define two facts +-> a +: (be a (2)) +-> a + +: (assertz '(a (3))) # Append new fact at the end +-> (((1)) ((2)) ((3))) + +: (? (a @N)) # Query + @N=1 + @N=2 + @N=3 +-> NIL +</code></pre> + +<dt><a name="assertz/1"><code>assertz/1</code></a> +<dd><a href="ref.html#pilog">Pilog</a> predicate that appends a new fact or rule +behind all other rules. See also <code><a +href="refA.html#assertz">assertz</a></code>, <code><a +href="refA.html#asserta/1">asserta/1</a></code> and <code><a +href="refR.html#retract/1">retract/1</a></code>. + +<pre><code> +: (? (assertz (a (1)))) +-> T +: (? (assertz (a (2)))) +-> T +: (rules 'a) +1 (be a (1)) +2 (be a (2)) +-> a +</code></pre> + +<dt><a name="assoc"><code>(assoc 'any 'lst) -> lst</code></a> <dd>Searches an +association list. Returns the first element from <code>lst</code> with its CAR +equal to <code>any</code>, or <code>NIL</code> if no match is found. See also +<code><a href="refA.html#asoq">asoq</a></code>. + +<pre><code> +: (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 +</code></pre> + +<dt><a name="at"><code>(at '(cnt1 . cnt2) . prg) -> any</code></a> +<dd>Increments <code>cnt1</code> (destructively), and returns <code>NIL</code> +when it is less than <code>cnt2</code>. Otherwise, <code>cnt1</code> is reset to +zero and <code>prg</code> is executed. Returns the result of <code>prg</code>. + +<pre><code> +: (do 11 (prin ".") (at (0 . 3) (prin "!"))) +...!...!...!..-> NIL +</code></pre> + +<dt><a name="atom"><code>(atom 'any) -> flg</code></a> +<dd>Returns <code>T</code> when the argument <code>any</code> is an atom (a +number or a symbol). See also <code><a href="refP.html#pair">pair</a></code>. + +<pre><code> +: (atom 123) +-> T +: (atom 'a) +-> T +: (atom NIL) +-> T +: (atom (123)) +-> NIL +</code></pre> + +<dt><a name="aux"><code>(aux 'var 'cls ['hook] 'any ..) -> sym</code></a> +<dd>Returns a database object of class <code>cls</code>, where the value for +<code>var</code> corresponds to <code>any</code> and the following arguments. +<code>var</code>, <code>cls</code> and <code>hook</code> should specify a +<code><a href="refT.html#tree">tree</a></code> for <code>cls</code> or one of +its superclasses, for a relation with auxiliary keys. For multi-key accesses, +<code>aux</code> is simlar to - but faster than - <code>db</code>, because it +can use a single tree access. See also <code><a +href="refD.html#db">db</a></code>, <code><a +href="refC.html#collect">collect</a></code>, <code><a +href="refF.html#fetch">fetch</a></code>, <code><a +href="refI.html#init">init</a></code>, <code><a +href="refS.html#step">step</a></code> and <code><a +href="refA.html#+Aux">+Aux</a></code>. + +<pre><code> +(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) ) +</code></pre> + +</dl> + +</body> +</html> diff --git a/doc/refB.html b/doc/refB.html @@ -0,0 +1,319 @@ +<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.0 Transitional//EN" "http://www.w3.org/TR/1998/REC-html40-19980424/loose.dtd"> +<html lang="en"> +<head> +<meta http-equiv="Content-Type" content="text/html; charset=utf-8"> +<title>B</title> +<link rel="stylesheet" href="doc.css" type="text/css"> +</head> +<body> + +<h1>B</h1> + +<dl> + +<dt><a name="*Blob"><code>*Blob</code></a> +<dd>A global variable holding the pathname of the database blob directory. See +also <code><a href="refB.html#blob">blob</a></code>. + +<pre><code> +: *Blob +-> "blob/app/" +</code></pre> + +<dt><a name="*Bye"><code>*Bye</code></a> +<dd>A global variable holding a (possibly empty) <code>prg</code> body, to be +executed just before the termination of the PicoLisp interpreter. See also +<code><a href="refB.html#bye">bye</a></code> and <code><a +href="refT.html#tmp">tmp</a></code>. + +<pre><code> +: (push1 '*Bye '(call 'rm "myfile.tmp")) # Remove a temporary file +-> (call 'rm "myfile.tmp") +</code></pre> + +<dt><a name="+Bag"><code>+Bag</code></a> +<dd>Class for a list of arbitrary relations, a subclass of <code><a +href="refR.html#+relation">+relation</a></code>. Objects of that class maintain +a list of heterogeneous relations. Typically used in combination with the +<code><a href="refL.html#+List">+List</a></code> prefix class, to maintain small +two-dimensional tables within oubjects. See also <code><a +href="ref.html#dbase">Database</a></code>. + +<pre><code> +(rel pos (+List +Bag) # Positions + ((+Ref +Link) NIL (+Item)) # Item + ((+Number) 2) # Price + ((+Number)) # Quantity + ((+String)) # Memo text + ((+Number) 2) ) # Total amount +</code></pre> + +<dt><a name="+Blob"><code>+Blob</code></a> +<dd>Class for blob relations, a subclass of <code><a +href="refR.html#+relation">+relation</a></code>. 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 +<code><a href="refB.html#*Blob">*Blob</a></code> variable. See also <code><a +href="ref.html#dbase">Database</a></code>. + +<pre><code> +(rel jpg (+Blob)) # Picture +</code></pre> + +<dt><a name="+Bool">+Bool<code></code></a> +<dd>Class for boolean relations, a subclass of <code><a +href="refR.html#+relation">+relation</a></code>. Objects of that class expect +either <code>T</code> or <code>NIL</code> as value (though, as always, only +non-<code>NIL</code> will be physically stored in objects). See also <code><a +href="ref.html#dbase">Database</a></code>. + +<pre><code> +(rel ok (+Ref +Bool)) # Indexed flag +</code></pre> + +<dt><a name="balance"><code>(balance 'var 'lst ['flg])</code></a> +<dd>Builds a balanced binary <code><a href="refI.html#idx">idx</a></code> tree +in <code>var</code>, from the sorted list in <code>lst</code>. Normally (if +random or, in the worst case, ordered data) are inserted with <code>idx</code>, +the tree will not be balanced. But if <code>lst</code> is properly sorted, its +contents will be inserted in an optimally balanced way. If <code>flg</code> is +non-<code>NIL</code>, the index tree will be augmented instead of being +overwritten. See also <code><a href="ref.html#cmp">Comparing</a></code> and +<code><a href="refS.html#sort">sort</a></code>. + +<pre><code> +# 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 + +# 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) +</code></pre> + +<dt><a name="be"><code>(be sym . any) -> sym</code></a> +<dd>Declares a <a href="ref.html#pilog">Pilog</a> fact or rule for the +<code>sym</code> argument, by concatenating the <code>any</code> argument to the +<code>T</code> property of <code>sym</code>. See also <code><a +href="refA.html#asserta">asserta</a></code>, <code><a +href="refA.html#assertz">assertz</a></code>, <code><a +href="refR.html#retract">retract</a></code>, <code><a +href="refG.html#goal">goal</a></code> and <code><a +href="refP.html#prove">prove</a></code>. + +<pre><code> +: (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))) +: (? (likes John @X)) + @X=Mary +-> NIL +</code></pre> + +<dt><a name="beep"><code>(beep) -> any</code></a> +<dd>Send the bell character to the console. See also <code><a +href="refP.html#prin">prin</a></code> and <code><a +href="refC.html#char">char</a></code>. + +<pre><code> +: (beep) +-> "^G" +</code></pre> + +<dt><a name="bench"><code>(bench . prg) -> any</code></a> +<dd>Benchmarks <code>prg</code>, by printing the time it took to execute, and +returns the result. See also <code><a href="refU.html#usec">usec</a></code>. + +<pre><code> +: (bench (wait 2000)) +1.996 sec +-> NIL +</code></pre> + +<dt><a name="bind"><code>(bind 'sym|lst . prg) -> any</code></a> +<dd>Binds value(s) to symbol(s). The first argument must evaluate to a symbol, +or a list of symbols or symbol-value pairs. The values of these symbols are +saved (and the symbols bound to the values in the case of pairs), +<code>prg</code> is executed, then the symbols are restored to their original +values. During execution of <code>prg</code>, the values of the symbols can be +temporarily modified. The return value is the result of <code>prg</code>. See +also <code><a href="refL.html#let">let</a></code>, <code><a +href="refJ.html#job">job</a></code> and <code><a +href="refU.html#use">use</a></code>. + +<pre><code> +: (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 +</code></pre> + +<dt><a name="bit?"><code>(bit? 'num ..) -> num | NIL</code></a> +<dd>Returns the first <code>num</code> argument when all bits which are 1 in the +first argument are also 1 in all following arguments. When one of those +arguments evaluates to <code>NIL</code>, it is returned immediately. See also +<code><a href="ref_.html#&">&</a></code>, <code><a +href="ref_.html#|">|</a></code> and <code><a href="refX.html#x|">x|</a></code>. + +<pre><code> +: (bit? 7 15 255) +-> 7 +: (bit? 1 3) +-> 1 +: (bit? 1 2) +-> NIL +</code></pre> + +<dt><a name="blob"><code>(blob 'obj 'sym) -> sym</code></a> +<dd>Returns the blob file name for <code>var</code> in <code>obj</code>. See +also <code><a href="refB.html#*Blob">*Blob</a></code>, <code><a +href="refB.html#blob!">blob!</a></code> and <code><a +href="refP.html#pack">pack</a></code>. + +<pre><code> +: (show (db 'nr '+Item 1)) +{3-1} (+Item) + jpg + pr 29900 + inv 100 + sup {2-1} + nm "Main Part" + nr 1 +-> {3-1} +: (blob '{3-1} 'jpg) +-> "blob/app/3/-/1.jpg" +</code></pre> + +<dt><a name="blob!"><code>(blob! 'obj 'sym 'file)</code></a> +<dd>Stores the contents of <code>file</code> in a <code><a +href="refB.html#blob">blob</a></code>. See also <code><a +href="refE.html#entityMesssages">put!></a></code>. + +<pre><code> +(blob! *ID 'jpg "picture.jpg") +</code></pre> + +<dt><a name="bool"><code>(bool 'any) -> flg</code></a> +<dd>Returns <code>T</code> when the argument <code>any</code> is +non-<code>NIL</code>. This function is only needed when <code>T</code> is +strictly required for a "true" condition (Usually, any non-<code>NIL</code> +value is considered to be "true"). See also <code><a +href="refF.html#flg?">flg?</a></code>. + +<pre><code> +: (and 3 4) +-> 4 +: (bool (and 3 4)) +-> T +</code></pre> + +<dt><a name="bool/3"><code>bool/3</code></a> +<dd><a href="ref.html#pilog">Pilog</a> predicate that succeeds if the first +argument has the same truth value as the result of applying the <code><a +href="refG.html#get">get</a></code> algorithm to the following arguments. +Typically used as filter predicate in <code><a +href="refS.html#select/3">select/3</a></code> database queries. See also +<code><a href="refB.html#bool">bool</a></code>, <code><a +href="refI.html#isa/2">isa/2</a></code>, <code><a +href="refS.html#same/3">same/3</a></code>, <code><a +href="refR.html#range/3">range/3</a></code>, <code><a +href="refH.html#head/3">head/3</a></code>, <code><a +href="refF.html#fold/3">fold/3</a></code>, <code><a +href="refP.html#part/3">part/3</a></code> and <code><a +href="refT.html#tolr/3">tolr/3</a></code>. + +<pre><code> +: (? @OK NIL # Find orders where the 'ok' flag is not set + (db nr +Ord @Ord) + (bool @OK @Ord ok) ) + @OK=NIL @Ord={3-7} +-> NIL +</code></pre> + +<dt><a name="box"><code>(box 'any) -> sym</code></a> +<dd>Creates and returns a new anonymous symbol. The initial value is set to the +<code>any</code> argument. See also <code><a href="refN.html#new">new</a></code> +and <code><a href="refB.html#box?">box?</a></code>. + +<pre><code> +: (show (box '(A B C))) +$134425627 (A B C) +-> $134425627 +</code></pre> + +<dt><a name="box?"><code>(box? 'any) -> sym | NIL</code></a> +<dd>Returns the argument <code>any</code> when it is an anonymous symbol, +otherwise <code>NIL</code>. See also <code><a +href="refB.html#box">box</a></code>, <code><a +href="refS.html#str?">str?</a></code> and <code><a +href="refE.html#ext?">ext?</a></code>. + +<pre><code> +: (box? (new)) +-> $134563468 +: (box? 123) +-> NIL +: (box? 'a) +-> NIL +: (box? NIL) +-> NIL +</code></pre> + +<dt><a name="by"><code>(by 'fun1 'fun2 'lst ..) -> lst</code></a> +<dd>Applies <code>fun1</code> to each element of <code>lst</code>. When +additional <code>lst</code> arguments are given, their elements are also passed +to <code>fun1</code>. Each result of <code>fun1</code> is CONSed with its +corresponding argument form the original <code>lst</code>, and collected into a +list which is passed to <code>fun2</code>. For the list returned from +<code>fun2</code>, the CAR elements returned by <code>fun1</code> are +(destructively) removed from each element. + +<pre><code> +: (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)) +</code></pre> + +<dt><a name="bye"><code>(bye 'cnt|NIL)</code></a> +<dd>Executes all pending <code><a href="refF.html#finally">finally</a></code> +expressions, closes all open files, executes the <code>VAL</code> of the global +variable <code><a href="refB.html#*Bye">*Bye</a></code> (should be a +<code>prg</code>), flushes standard output, and then exits the PicoLisp +interpreter. The process return value is <code>cnt</code>, or 0 if the argument +is missing or <code>NIL</code>. + +<pre><code> +: (setq *Bye '((println 'OK) (println 'bye))) +-> ((println 'OK) (println 'bye)) +: (bye) +OK +bye +$ +</code></pre> + +</dl> + +</body> +</html> diff --git a/doc/refC.html b/doc/refC.html @@ -0,0 +1,657 @@ +<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.0 Transitional//EN" "http://www.w3.org/TR/1998/REC-html40-19980424/loose.dtd"> +<html lang="en"> +<head> +<meta http-equiv="Content-Type" content="text/html; charset=utf-8"> +<title>C</title> +<link rel="stylesheet" href="doc.css" type="text/css"> +</head> +<body> + +<h1>C</h1> + +<dl> + +<dt><a name="*Class"><code>*Class</code></a> +<dd>A global variable holding the current class. See also <code><a +href="ref.html#oop">OO Concepts</a></code>, <code><a +href="refC.html#class">class</a></code>, <code><a +href="refE.html#extend">extend</a></code>, <code><a +href="refD.html#dm">dm</a></code> and <code><a +href="refV.html#var">var</a></code> and <code><a +href="refR.html#rel">rel</a></code>. + +<pre><code> +: (class +Test) +-> +Test +: *Class +-> +Test +</code></pre> + +<dt><a name="cache"><code>(cache 'var 'sym . prg) -> any</code></a> +<dd>Speeds up some calculations, by holding previously calculated results in an +<code><a href="refI.html#idx">idx</a></code> tree structure. <code>sym</code> +must be a transient symbol representing a unique key for the argument(s) to the +calculation. + +<pre><code> +: (de fibonacci (N) + (cache '*Fibonacci (format N) + (if (> 2 N) + 1 + (+ + (fibonacci (dec N)) + (fibonacci (- N 2)) ) ) ) ) +-> fibonacci +: (fibonacci 22) +-> 28657 +: (fibonacci 10000) +-> 5443837311356528133873426099375038013538 ... # (2090 digits) +</code></pre> + +<dt><a name="call"><code>(call 'any ..) -> flg</code></a> +<dd>Calls an external system command. The <code>any</code> arguments specify the +command and its arguments. Returns <code>T</code> if the command was executed +successfully. + +<pre><code> +: (when (call 'test "-r" "file.l") # Test if file exists and is readable + (load "file.l") # Load it + (call 'rm "file.l") ) # Remove it +</code></pre> + +<dt><a name="call/1"><code>call/1</code></a> +<dd><a href="ref.html#pilog">Pilog</a> predicate that succeeds if the argument +term can be proven. + +<pre><code> +: (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 change (you are a computer) @Z)) +-> NIL +: (? (mapcar change (you are a computer) @Z) T) +-> NIL +: (? (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)) + ... +</code></pre> + +<dt><a name="can"><code>(can 'msg) -> lst</code></a> +<dd>Returns a list of all classes that accept the message <code>msg</code>. See +also <code><a href="ref.html#oop">OO Concepts</a></code>, <code><a +href="refC.html#class">class</a></code>, <code><a +href="refD.html#dep">dep</a></code>, <code><a +href="refW.html#what">what</a></code> and <code><a +href="refW.html#who">who</a></code>. + +<pre><code> +: (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 +</code></pre> + +<dt><a name="car"><code>(car 'var) -> any</code></a> +<dd>List access: Returns the value of <code>var</code> if it is a symbol, or the +first element if it is a list. See also <code><a +href="refC.html#cdr">cdr</a></code> and <code><a +href="refC.html#cXr">c..r</a></code>. + +<pre><code> +: (car (1 2 3 4 5 6)) +-> 1 +</code></pre> + +<dt><a name="cXr"><code>(c[ad]*ar 'var) -> any</code></a> +<dt><code>(c[ad]*dr 'lst) -> any</code> +<dd>List access shortcuts. Combinations of the <code><a +href="refC.html#car">car</a></code> and <code><a +href="refC.html#cdr">cdr</a></code> functions, with up to four letters 'a' and +'d'. + +<pre><code> +: (cdar '((1 . 2) . 3)) +-> 2 +</code></pre> + +<dt><a name="case"><code>(case 'any (any1 . prg1) (any2 . prg2) ..) -> any</code></a> +<dd>Multi-way branch: <code>any</code> is evaluated and compared to the CAR +elements <code>anyN</code> of each clause. If one of them is a list, +<code>any</code> is in turn compared to all elements of that list. +<code>T</code> is a catch-all for any value. If a comparison succeeds, +<code>prgN</code> is executed, and the result returned. Otherwise +<code>NIL</code> is returned. See also <code><a +href="refS.html#state">state</a></code>. + +<pre><code> +: (case (char 66) ("A" (+ 1 2 3)) (("B" "C") "Bambi") ("D" (* 1 2 3))) +-> "Bambi" +</code></pre> + +<dt><a name="catch"><code>(catch 'any . prg) -> any</code></a> +<dd>Sets up the environment for a non-local jump which may be caused by <code><a +href="refT.html#throw">throw</a></code> or by a runtime error. If +<code>any</code> is an atom, it is used by <code>throw</code> as a jump label +(with <code>T</code> being a catch-all for any label), and a <code>throw</code> +called during the execution of <code>prg</code> will immediately return the +thrown value. Otherwise, <code>any</code> should be a list of strings, to catch +any error whose message contains one of these strings, and this will immediately +return the matching string. If neither <code>throw</code> nor an error occurs, +the result of <code>prg</code> is returned. See also <code><a +href="refF.html#finally">finally</a></code>, <code><a +href="refQ.html#quit">quit</a></code> and +<code><a href="ref.html#errors">Error Handling</a></code>. + +<pre><code> +: (catch 'OK (println 1) (throw 'OK 999) (println 2)) +1 +-> 999 +: (catch '("No such file") (in "doesntExist" (foo))) +-> "No such file" +</code></pre> + +<dt><a name="cd"><code>(cd 'any) -> sym</code></a> +<dd>Changes the current directory to <code>any</code>. The old directory is +returned on success, otherwise <code>NIL</code>. See also <code><a +href="refD.html#dir">dir</a></code> and <code><a +href="refP.html#pwd">pwd</a></code>. + +<pre><code> +: (when (cd "lib") + (println (sum lines (dir))) + (cd @) ) +10955 +</code></pre> + +<dt><a name="cdr"><code>(cdr 'lst) -> any</code></a> +<dd>List access: Returns all but the first element of <code>lst</code>. See also +<code><a href="refC.html#car">car</a></code> and <code><a +href="refC.html#cXr">c..r</a></code>. + +<pre><code> +: (cdr (1 2 3 4 5 6)) +-> (2 3 4 5 6) +</code></pre> + +<dt><a name="center"><code>(center 'cnt|lst 'any ..) -> sym</code></a> +<dd>Returns a transient symbol with all <code>any</code> arguments <code><a +href="refP.html#pack">pack</a></code>ed in a centered format. Trailing blanks +are omitted. See also <code><a href="refA.html#align">align</a></code>, <code><a +href="refT.html#tab">tab</a></code> and <code><a +href="refW.html#wrap">wrap</a></code>. + +<pre><code> +: (center 4 12) +-> " 12" +: (center 4 "a") +-> " a" +: (center 7 "a") +-> " a" +: (center (3 3 3) "a" "b" "c") +-> " a b c" +</code></pre> + +<dt><a name="chain"><code>(chain 'lst ..) -> lst</code></a> +<dd>Concatenates (destructively) one or several new list elements +<code>lst</code> to the end of the list in the current <code><a +href="refM.html#make">make</a></code> environment. This operation is efficient +also for long lists, because a pointer to the last element of the result list is +maintained. <code>chain</code> returns the last linked argument. See also +<code><a href="refL.html#link">link</a></code>, <code><a +href="refY.html#yoke">yoke</a></code> and <code><a +href="refM.html#made">made</a></code>. + +<pre><code> +: (make (chain (list 1 2 3) NIL (cons 4)) (chain (list 5 6))) +-> (1 2 3 4 5 6) +</code></pre> + +<dt><a name="char"><code>(char) -> sym</code></a> +<dt><code>(char 'cnt) -> sym</code> +<dt><code>(char T) -> sym</code> +<dt><code>(char 'sym) -> cnt</code> +<dd>When called without arguments, the next character from the current input +stream is returned as a single-character transient symbol, or <code>NIL</code> +upon end of file. When called with a number <code>cnt</code>, a character with +the corresponding unicode value is returned. As a special case, <code>T</code> +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 <code>sym</code>, the numeric unicode value of the first character of the +name of that symbol is returned. See also <code><a +href="refP.html#peek">peek</a></code>, <code><a +href="refS.html#skip">skip</a></code>, <code><a +href="refK.html#key">key</a></code>, <code><a +href="refL.html#line">line</a></code>, <code><a +href="refT.html#till">till</a></code> and <code><a +href="refE.html#eof">eof</a></code>. + +<pre><code> +: (char) # Read character from console +A # (typed 'A' and a space/return) +-> "A" +: (char 100) # Convert unicode to symbol +-> "d" +: (char T) # Special case, catch all +-> # (not printable) +: (char "d") # Convert symbol to unicode +-> 100 +</code></pre> + +<dt><a name="chdir"><code>(chdir 'any . prg) -> any</code></a> +<dd>Changes the current directory to <code>any</code> with <code><a +href="refC.html#cd">cd</a></code> during the execution of <code>prg</code>. Then +the previous directory will be restored and the result of <code>prg</code> +returned. See also <code><a href="refD.html#dir">dir</a></code> and <code><a +href="refP.html#pwd">pwd</a></code>. + +<pre><code> +: (pwd) +-> "/usr/abu/pico" +: (chdir "src" (pwd)) +-> "/usr/abu/pico/src" +: (pwd) +-> "/usr/abu/pico" +</code></pre> + +<dt><a name="chkTree"><code>(chkTree 'sym ['fun]) -> num</code></a> +<dd>Checks a database tree node (and recursively all sub-nodes) for consistency. +Returns the total number of nodes checked. Optionally, <code>fun</code> is +called with the key and value of each node, and should return <code>NIL</code> +for failure. See also <code><a href="refT.html#tree">tree</a></code> and +<code><a href="refR.html#root">root</a></code>. + +<pre><code> +: (show *DB '+Item) +{C} NIL + sup (7 . {7-3}) + nr (7 . {7-1}) # 7 nodes in the 'nr' tree, base node is {7-1} + pr (7 . {7-4}) + nm (77 . {7-6}) +-> {C} +: (chkTree '{7-1}) # Check that node +-> 7 +</code></pre> + +<dt><a name="chop"><code>(chop 'any) -> lst</code></a> +<dd>Returns <code>any</code> as a list of single-character strings. If +<code>any</code> is <code>NIL</code> or a symbol with no name, <code>NIL</code> +is returned. A list argument is returned unchanged. + +<pre><code> +: (chop 'car) +-> ("c" "a" "r") +: (chop "Hello") +-> ("H" "e" "l" "l" "o") +</code></pre> + +<dt><a name="circ"><code>(circ 'any ..) -> lst</code></a> +<dd>Produces a circular list of all <code>any</code> arguments by <code><a +href="refC.html#cons">cons</a></code>ing them to a list and then connecting the +CDR of the last cell to the first cell. See also <code><a +href="refL.html#list">list</a></code>. + +<pre><code> +: (circ 'a 'b 'c) +-> (a b c .) +</code></pre> + +<dt><a name="class"><code>(class sym . typ) -> obj</code></a> +<dd>Defines <code>sym</code> as a class with the superclass(es) +<code>typ</code>. As a side effect, the global variable <code><a +href="refC.html#*Class">*Class</a></code> is set to <code>obj</code>. See also +<code><a href="refE.html#extend">extend</a></code>, <code><a +href="refD.html#dm">dm</a></code>, <code><a href="refV.html#var">var</a></code>, +<code><a href="refR.html#rel">rel</a></code>, <code><a +href="refT.html#type">type</a></code>, <code><a +href="refI.html#isa">isa</a></code> and <code><a +href="refO.html#object">object</a></code>. + +<pre><code> +: (class +A +B +C +D) +-> +A +: +A +-> (+B +C +D) +: (dm foo> (X) (bar X)) +-> foo> +: +A +-> ((foo> (X) (bar X)) +B +C +D) +</code></pre> + +<dt><a name="clause/2"><code>clause/2</code></a> +<dd><a href="ref.html#pilog">Pilog</a> predicate that succeeds if the first +argument is a predicate which has the second argument defined as a clause. + +<pre><code> +: (? (clause append ((NIL @X @X)))) +-> T + +: (? (clause append @C)) + @C=((NIL @X @X)) + @C=(((@A . @X) @Y (@A . @Z)) (append @X @Y @Z)) +-> NIL +</code></pre> + +<dt><a name="clip"><code>(clip 'lst) -> lst</code></a> +<dd>Returns a copy of <code>lst</code> with all white space characters or +<code>NIL</code> elements removed from both sides. See also <code><a +href="refT.html#trim">trim</a></code>. + +<pre><code> +: (clip '(NIL 1 NIL 2 NIL)) +-> (1 NIL 2) +: (clip '(" " a " " b " ")) +-> (a " " b) +</code></pre> + +<dt><a name="close"><code>(close 'cnt) -> cnt | NIL</code></a> +<dd>Closes a file descriptor <code>cnt</code>, and returns it when successful. +Should not be called inside an <code><a href="refO.html#out">out</a></code> body +for that descriptor. See also <code><a href="refO.html#open">open</a></code>, +<code><a href="refL.html#listen">listen</a></code> and <code><a +href="refC.html#connect">connect</a></code>. + +<pre><code> +: (close 2) # Close standard error +-> 2 +</code></pre> + +<dt><a name="cmd"><code>(cmd ['any]) -> sym</code></a> +<dd>When called without an argument, the name of the command that invoked the +picolisp interpreter is returned. Otherwise, the command name is set to +<code>any</code>. Setting the name may not work on some operating systems. Note +that the new name must not be longer than the original one. See also <code><a +href="refA.html#argv">argv</a></code> and <code><a +href="ref.html#invoc">Invocation</a></code>. + +<pre><code> +$ ./dbg +: (cmd) +-> "./bin/picolisp" +: (cmd "!/bin/picolust") +-> "!/bin/picolust" +: (cmd) +-> "!/bin/picolust" +</code></pre> + +<dt><a name="cnt"><code>(cnt 'fun 'lst ..) -> cnt</code></a> +<dd>Applies <code>fun</code> to each element of <code>lst</code>. When +additional <code>lst</code> arguments are given, their elements are also passed +to <code>fun</code>. Returns the count of non-<code>NIL</code> values returned +from <code>fun</code>. + +<pre><code> +: (cnt cdr '((1 . T) (2) (3 4) (5))) +-> 2 +</code></pre> + +<dt><a name="collect"><code>(collect 'var 'cls ['hook] ['any|beg ['end [var ..]]])</code></a> +<dd>Returns a list of all database objects of class <code>cls</code>, where the +values for the <code>var</code> arguments correspond to the <code>any</code> +arguments, or where the values for the <code>var</code> arguments are in the +range <code>beg</code> .. <code>end</code>. <code>var</code>, <code>cls</code> +and <code>hook</code> should specify a <code><a +href="refT.html#tree">tree</a></code> for <code>cls</code> or one of its +superclasses. If additional <code>var</code> arguments are given, the final +values for the result list are obtained by applying the <code><a +href="refG.html#get">get</a></code> algorithm. See also <code><a +href="refD.html#db">db</a></code>, <code><a href="refA.html#aux">aux</a></code>, +<code><a href="refF.html#fetch">fetch</a></code>, <code><a +href="refI.html#init">init</a></code> and <code><a +href="refS.html#step">step</a></code>. + +<pre><code> +: (collect 'nr '+Item) +-> ({3-1} {3-2} {3-3} {3-4} {3-5} {3-6} {3-8}) +: (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") +-> ({3-1}) +</code></pre> + +<dt><a name="commit"><code>(commit ['any] [exe1] [exe2]) -> T</code></a> +<dd>Closes a transaction, by writing all new or modified external symbols to, +and removing all deleted external symbols from the database. When +<code>any</code> is given, it is implicitly sent (with all modified objects) via +the <code><a href="refT.html#tell">tell</a></code> mechanism to all family +members. If <code>exe1</code> or <code>exe2</code> are given, they are executed +as pre- or post-expressions while the database is <code><a +href="refL.html#lock">lock</a></code>ed and <code><a +href="refP.html#protect">protect</a></code>ed. See also <code><a +href="refR.html#rollback">rollback</a></code>. + +<pre><code> +: (pool "db") +-> T +: (put '{1} 'str "Hello") +-> "Hello" +: (commit) +-> T +</code></pre> + +<dt><a name="con"><code>(con 'lst 'any) -> any</code></a> +<dd>Connects <code>any</code> to the first cell of <code>lst</code>, by +(destructively) storing <code>any</code> in the CDR of <code>lst</code>. See +also <code><a href="refC.html#conc">conc</a></code>. + +<pre><code> +: (setq C (1 . a)) +-> (1 . a) +: (con C '(b c d)) +-> (b c d) +: C +-> (1 b c d) +</code></pre> + +<dt><a name="conc"><code>(conc 'lst ..) -> lst</code></a> +<dd>Concatenates all argument lists (destructively). See also <code><a +href="refA.html#append">append</a></code> and <code><a +href="refC.html#con">con</a></code>. + +<pre><code> +: (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! +</code></pre> + +<dt><a name="cond"><code>(cond ('any1 . prg1) ('any2 . prg2) ..) -> any</code></a> +<dd>Multi-way conditional: If any of the <code>anyN</code> conditions evaluates +to non-<code>NIL</code>, <code>prgN</code> is executed and the result returned. +Otherwise (all conditions evaluate to <code>NIL</code>), <code>NIL</code> is +returned. See also <code><a href="refN.html#nond">nond</a></code>, <code><a +href="refI.html#if">if</a></code>, <code><a href="refI.html#if2">if2</a></code> +and <code><a href="refW.html#when">when</a></code>. + +<pre><code> +: (cond + ((= 3 4) (println 1)) + ((= 3 3) (println 2)) + (T (println 3)) ) +2 +-> 2 +</code></pre> + +<dt><a name="connect"><code>(connect 'any 'cnt) -> cnt | NIL</code></a> +<dd>Tries to establish a TCP/IP connection to a server listening at host +<code>any</code>, port <code>cnt</code>. <code>any</code> may be either a +hostname or a standard internet address in numbers-and-dots notation. Returns a +socket descriptor <code>cnt</code>, or <code>NIL</code> if the connection cannot +be established. See also <code><a href="refL.html#listen">listen</a></code>. + +<pre><code> +: (connect "localhost" 4444) +-> 3 +</code></pre> + +<dt><a name="cons"><code>(cons 'any ['any ..]) -> lst</code></a> +<dd>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. <code>(cons 'a 'b 'c 'd)</code> is equivalent to <code>(cons +'a (cons 'b (cons 'c 'd)))</code>. See also <code><a +href="refL.html#list">list</a></code>. + +<pre><code> +: (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) +</code></pre> + +<dt><a name="copy"><code>(copy 'any) -> any</code></a> +<dd>Copies the argument <code>any</code>. For lists, the top level cells are +copied, while atoms are returned unchanged. + +<pre><code> +: (=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 +</code></pre> + +<dt><a name="count"><code>(count 'tree) -> num</code></a> +<dd>Returns the number of nodes in a database tree. See also <code><a +href="refT.html#tree">tree</a></code> and <code><a +href="refR.html#root">root</a></code>. + +<pre><code> +: (count (tree 'nr '+Item)) +-> 7 +</code></pre> + +<dt><a name="ctl"><code>(ctl 'sym . prg) -> any</code></a> +<dd>Waits until a write (exclusive) lock (or a read (shared) lock if the first +character of <code>sym</code> is "<code>+</code>") can be set on the file +<code>sym</code>, then executes <code>prg</code> and releases the lock. If the +files does not exist, it will be created. When <code>sym</code> is +<code>NIL</code>, a shared lock is tried on the current innermost I/O channel, +and when it is <code>T</code>, an exclusive lock is tried instead. See also +<code><a href="refI.html#in">in</a></code>, <code><a +href="refP.html#pipe">pipe</a></code> and <code><a +href="refO.html#out">out</a></code>. + +<pre><code> +$ echo 9 >count # Write '9' to file "count" +$ ./dbg +: (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 +</code></pre> + +<dt><a name="ctty"><code>(ctty 'sym|pid) -> flg</code></a> +<dd>When called with a symbolic argument, <code>ctty</code> changes the current +TTY device to <code>sym</code>. Otherwise, the local console is prepared for +serving the PicoLisp process with the process ID <code>pid</code>. See also +<code><a href="refR.html#raw">raw</a></code>. + +<pre><code> +: (ctty "/dev/tty") +-> T +</code></pre> + +<dt><a name="curry"><code>(curry lst . fun) -> fun</code></a> +<dd>Builds a new function from the list of symbols <code>lst</code> and the +functional expression <code>fun</code>. Each member in <code>lst</code> that is +a <code><a href="refP.html#pat?">pat?</a></code> symbol is substituted inside +<code>fun</code> by its value. All other symbols in <code>lst</code> are +collected into a <code><a href="refJ.html#job">job</a></code> environment. + +<pre><code> +: (de multiplier (@X) + (curry (@X) (N) (* @X N)) ) +-> multiplier +: (multiplier 7) +-> ((N) (* 7 N)) +: ((multiplier 7) 3)) +-> 21 + +: (let (N1 0 N2 1) + (def 'fiboCounter + (curry (N1 N2) (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 +</code></pre> + +<dt><a name="cut"><code>(cut 'cnt 'var) -> lst</code></a> +<dd>Pops the first <code>cnt</code> elements (CAR) from the stack in +<code>var</code>. See also <code><a href="refP.html#pop">pop</a></code> and +<code><a href="refD.html#del">del</a></code>. + +<pre><code> +: (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) +</code></pre> + +</dl> + +</body> +</html> diff --git a/doc/refD.html b/doc/refD.html @@ -0,0 +1,748 @@ +<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.0 Transitional//EN" "http://www.w3.org/TR/1998/REC-html40-19980424/loose.dtd"> +<html lang="en"> +<head> +<meta http-equiv="Content-Type" content="text/html; charset=utf-8"> +<title>D</title> +<link rel="stylesheet" href="doc.css" type="text/css"> +</head> +<body> + +<h1>D</h1> + +<dl> + +<dt><a name="*DB"><code>*DB</code></a> +<dd>A global constant holding the external symbol <code>{1}</code>, the database +root. All transient 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 <code>*DB</code> to <code>NIL</code> and restores its value +after collection, thus disposing of all external symbols not currently used in +the program). + +<pre><code> +: (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} +</code></pre> + +<dt><a name="*Dbg"><code>*Dbg</code></a> +<dd>A boolean variable indicating "debug mode". When non-<code>NIL</code>, the +<code><a href="ref_.html#$">$</a></code> (tracing) and <code><a +href="ref_.html#!">!</a></code> (breakpoint) functions are enabled, and the +current line number and file name will be stored in symbol properties by +<code><a href="refD.html#de">de</a></code>, <code><a +href="refD.html#def">def</a></code> and <code><a +href="refD.html#dm">dm</a></code>. See also <code><a +href="refD.html#debug">debug</a></code>, <code><a +href="refT.html#trace">trace</a></code> and <code><a +href="refL.html#lint">lint</a></code>. + +<pre><code> +: (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 +</code></pre> + +<dt><a name="*Dbs"><code>*Dbs</code></a> +<dd>A global variable holding a list of numbers (block size scale factors, as +needed by <code><a href="refP.html#pool">pool</a></code>). It is typically set +by <code><a href="refD.html#dbs">dbs</a></code> +and <code><a href="refD.html#dbs+">dbs+</a></code>. + +<pre><code> +: *Dbs +-> (1 2 1 0 2 3 3 3) +</code></pre> + +<dt><a name="+Date"><code>+Date</code></a> +<dd>Class for calender dates (as calculated by <code><a +href="refD.html#date">date</a></code>), a subclass of <code><a +href="refN.html#+Number">+Number</a></code>. See also <code><a +href="ref.html#dbase">Database</a></code>. + +<pre><code> +(rel dat (+Ref +Date)) # Indexed date +</code></pre> + +<dt><a name="+Dep"><code>+Dep</code></a> +<dd>Prefix class for maintaining depenencies between <code><a +href="refR.html#+relation">+relation</a></code>s. Expects a list of (symbolic) +attributes that depend on this relation. Whenever this relations is cleared +(receives a value of <code>NIL</code>, or the whole entity is deleted with +<code>lose&gt;</code>), the dependent relations will also be cleared, triggering +all required side-effects. See also <code><a +href="ref.html#dbase">Database</a></code>. + +<p>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: + +<pre><code> +(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 +</code></pre> + +<dt><a name="d"><code>(d) -> T</code></a> +<dd>Inserts <code><a href="ref_.html#!">!</a></code> breakpoints into all +subexpressions of the current breakpoint. Typically used when single-stepping a +function or method with <code><a href="refD.html#debug">debug</a></code>. See +also <code><a href="refU.html#u">u</a></code> and <code><a +href="refU.html#unbug">unbug</a></code>. + +<pre><code> +! (d) # Debug subexpression(s) at breakpoint +-> T +</code></pre> + +<dt><a name="daemon"><code>(daemon 'sym . prg) -> fun</code></a> +<dt><code>(daemon '(sym . cls) . prg) -> fun</code> +<dt><code>(daemon '(sym sym2 [. cls]) . prg) -> fun</code> +<dd>Inserts <code>prg</code> in the beginning of the function (first form), the +method body of <code>sym</code> in <code>cls</code> (second form) or in the +class obtained by <code><a href="refG.html#get">get</a></code>ing +<code>sym2</code> from <code><a href="refC.html#*Class">*Class</a></code> (or +<code>cls</code> if given) (third form). Built-in functions (C-function pointer) +are automatically converted to Lisp expressions. See also <code><a +href="refE.html#expr">expr</a></code>, <code><a +href="refP.html#patch">patch</a></code> and <code><a +href="refR.html#redef">redef</a></code>. + +<pre><code> +: (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 +</code></pre> + +<dt><a name="dat$"><code>(dat$ 'dat ['sym]) -> sym</code></a> +<dd>Formats a <code><a href="refD.html#date">date</a></code> <code>dat</code> in +ISO format, with an optional delimiter character <code>sym</code>. See also +<code><a href="ref_.html#$dat">$dat</a></code>, <code><a +href="refT.html#tim$">tim$</a></code>, <code><a +href="refD.html#datStr">datStr</a></code> and <code><a +href="refD.html#datSym">datSym</a></code>. + +<pre><code> +: (dat$ (date)) +-> "20070601" +: (dat$ (date) "-") +-> "2007-06-01" +</code></pre> + +<dt><a name="datStr"><code>(datStr 'dat ['flg]) -> sym</code></a> +<dd>Formats a <code><a href="refD.html#date">date</a></code> according to the +current <code><a href="refL.html#locale">locale</a></code>. If <code>flg</code> +is non-<code>NIL</code>, the year will be formatted modulo 100. See also +<code><a href="refD.html#dat$">dat$</a></code>, <code><a +href="refD.html#datSym">datSym</a></code>, <code><a +href="refS.html#strDat">strDat</a></code>, <code><a +href="refE.html#expDat">expDat</a></code>, <code><a +href="refE.html#expTel">expTel</a></code> and <code><a +href="refD.html#day">day</a></code>. + +<pre><code> +: (datStr (date)) +-> "2007-06-01" +: (locale "DE" "de") +-> NIL +: (datStr (date)) +-> "01.06.2007" +: (datStr (date) T) +-> "01.06.07" +</code></pre> + +<dt><a name="datSym"><code>(datSym 'dat) -> sym</code></a> +<dd>Formats a <code><a href="refD.html#date">date</a></code> <code>dat</code> in +in symbolic format (DDmmmYY). See also <code><a +href="refD.html#dat$">dat$</a></code> and <code><a +href="refD.html#datStr">datStr</a></code>. + +<pre><code> +: (datSym (date)) +-> "01jun07" +</code></pre> + +<dt><a name="date"><code>(date ['T]) -> dat</code></a> +<dt><code>(date 'dat) -> (y m d)</code> +<dt><code>(date 'y 'm 'd) -> dat | NIL</code> +<dt><code>(date '(y m d)) -> dat | NIL</code> +<dd>Calculates a (gregorian) calendar date, represented as the number of days +since first of March in the year 0. When called without arguments, the current +date is returned. When called with a <code>T</code> argument, the current +Coordinated Universal Time (UTC) is returned. When called with a single number +<code>dat</code>, 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 +<code>NIL</code> if they do not represent a legal date). See also <code><a +href="refT.html#time">time</a></code>, <code><a +href="ref_.html#$dat">$dat</a></code>, <code><a +href="refD.html#dat$">dat$</a></code>, <code><a +href="refD.html#datSym">datSym</a></code>, <code><a +href="refD.html#datStr">datStr</a></code>, <code><a +href="refS.html#strDat">strDat</a></code>, <code><a +href="refE.html#expDat">expDat</a></code>, <code><a +href="refD.html#day">day</a></code>, <code><a +href="refW.html#week">week</a></code> and <code><a +href="refU.html#ultimo">ultimo</a></code>. + +<pre><code> +: (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 +</code></pre> + +<dt><a name="day"><code>(day 'dat ['lst]) -> sym</code></a> +<dd>Returns the name of the day for a given <code><a +href="refD.html#date">date</a></code> <code>dat</code>, in the language of the +current <code><a href="refL.html#locale">locale</a></code>. If <code>lst</code> +is given, it should be a list of alternative weekday names. See also <code><a +href="refW.html#week">week</a></code>, <code><a +href="refD.html#datStr">datStr</a></code> and <code><a +href="refS.html#strDat">strDat</a></code>. + +<pre><code> +: (day (date)) +-> "Friday" +: (locale "DE" "de") +-> NIL +: (day (date)) +-> "Freitag" +: (day (date) '("Mo" "Tu" "We" "Th" "Fr" "Sa" "Su")) +-> "Fr" +</code></pre> + +<dt><a name="db"><code>(db 'var 'cls ['hook] 'any ['var 'any ..]) -> sym | NIL</code></a> +<dd>Returns a database object of class <code>cls</code>, where the values for +the <code>var</code> arguments correspond to the <code>any</code> arguments. If +a matching object cannot be found, <code>NIL</code> is returned. +<code>var</code>, <code>cls</code> and <code>hook</code> should specify a +<code><a href="refT.html#tree">tree</a></code> for <code>cls</code> or one of +its superclasses. See also <code><a href="refA.html#aux">aux</a></code>, +<code><a href="refC.html#collect">collect</a></code>, <code><a +href="refR.html#request">request</a></code>, <code><a +href="refF.html#fetch">fetch</a></code>, <code><a +href="refI.html#init">init</a></code> and <code><a +href="refF.html#step">step</a></code>. + +<pre><code> +: (db 'nr '+Item 1) +-> {3-1} +: (db 'nm '+Item "Main Part") +-> {3-1} +</code></pre> + +<dt><a name="db/3"><code>db/3</code></a> +<dt><a name="db/4"><code>db/4</code></a> +<dt><a name="db/5"><code>db/5</code></a> +<dd><a href="ref.html#pilog">Pilog</a> database predicate that returns objects +matching the given key/value (and optional hook) relation. The relation should +be of type <code><a href="refI.html#+index">+index</a></code>. For the key +pattern applies: + +<p><ul> +<li>a symbol (string) returns all entries which start with that string +<li>other atoms (numbers, external symbols) match as they are +<li>cons pairs constitute a range, returning objects + <ul> + <li>in increasing order if the CDR is greater than the CAR + <li>in decreasing order otherwise + </ul> +<li>other lists are matched for <code><a href="refA.html#+Aux">+Aux</a></code> +key combinations +</ul> + +<p>The optional hook can be supplied as the third argument. See also <code><a +href="refS.html#select/3">select/3</a></code> and <code><a +href="refR.html#remote/2">remote/2</a></code>. + +<pre><code> +: (? (db nr +Item @Item)) # No value given + @Item={3-1} + @Item={3-2} + @Item={3-3} + @Item={3-4} + @Item={3-5} + @Item={3-6} +-> NIL + +: (? (db nr +Item 2 @Item)) # Get item no. 2 + @Item={3-2} +-> NIL + +: (? (db nm +Item Spare @Item) (show @Item)) # Search for "Spare.." +{3-2} (+Item) + pr 1250 + inv 100 + sup {2-2} + nm "Spare Part" + nr 2 + @Item={3-2} +-> NIL +</code></pre> + +<dt><a name="db:"><code>(db: cls ..) -> num</code></a> +<dd>Returns the database file number for objects of the type given by the +<code>cls</code> argument(s). Needed, for example, for the creation of <code><a +href="refN.html#new">new</a></code> objects. See also <code><a +href="refD.html#dbs">dbs</a></code>. + +<pre><code> +: (db: +Item) +-> 3 +</code></pre> + +<dt><a name="dbSync"><code>(dbSync) -> flg</code></a> +<dd>Starts a database transaction, by trying to obtain a <code><a +href="refL.html#lock">lock</a></code> on the database root object <code><a +href="refD.html#*DB">*DB</a></code>, and then calling <code><a +href="refS.html#sync">sync</a></code> to synchronize with possible changes from +other processes. When all desired modifications to external symbols are done, +<code>(<a href="refC.html#commit">commit</a> 'upd)</code> should be called. See +also <code><a href="ref.html#dbase">Database</a></code>. + +<pre><code> +(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 +</code></pre> + +<dt><a name="dbck"><code>(dbck ['cnt] 'flg) -> any</code></a> +<dd>Performs a low-level integrity check of the current (or <code>cnt</code>'th) +database file, and returns <code>NIL</code> (or the number of blocks and symbols +if <code>flg</code> is non-<code>NIL</code>) 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 <code><a +href="refR.html#rollback">rollback</a></code> is done before <code><a +href="refC.html#commit">commit</a></code>ing newly allocated (<code><a +href="refN.html#new">new</a></code>) external symbols) are appended to the free +list. + +<pre><code> +: (pool "db") +-> T +: (dbck) +-> NIL +</code></pre> + +<dt><a name="dbs"><code>(dbs . lst)</code></a> +<dd>Initializes the global variable <code><a +href="refD.html#*Dbs">*Dbs</a></code>. Each element in <code>lst</code> has a +number in its CAR (the block size scale factor of a database file, to be stored +in <code>*Dbs</code>). 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 <code><a +href="refD.html#dbs+">dbs+</a></code> and <code><a +href="refP.html#pool">pool</a></code>. + +<pre><code> +(dbs + (1 +Role +User +Sal) # (1 . 128) + (2 +CuSu) # (2 . 256) + (1 +Item +Ord) # (3 . 128) + (0 +Pos) # (4 . 64) + (2 (+Role nm) (+User nm) (+Sal nm)) # (5 . 256) + (4 (+CuSu nr plz tel mob)) # (6 . 1024) + (4 (+CuSu nm)) # (7 . 1024) + (4 (+CuSu ort)) # (8 . 1024) + (4 (+Item nr sup pr)) # (9 . 1024) + (4 (+Item nm)) # (10 . 1024) + (4 (+Ord nr dat cus)) # (11 . 1024) + (4 (+Pos itm)) ) # (12 . 1024) + +: *Dbs +-> (1 2 1 0 2 4 4 4 4 4 4 4) +: (get '+Item 'Dbf) +-> (3 . 128) +: (get '+Item 'nr 'dbf) +-> (9 . 1024) +</code></pre> + +<dt><a name="dbs+"><code>(dbs+ 'num . lst)</code></a> +<dd>Extends the list of database sizes stored in <code><a +href="refD.html#*Dbs">*Dbs</a></code>. <code>num</code> is the initial offset +into the list. See also <code><a href="refD.html#dbs">dbs</a></code>. + +<pre><code> +(dbs+ 9 + (1 +NewCls) # (9 . 128) + (3 (+NewCls nr nm)) ) # (10 . 512) +</code></pre> + +<dt><a name="de"><code>(de sym . any) -> sym</code></a> +<dd>Assigns a definition to the <code>sym</code> argument, by setting its +<code>VAL</code> to the <code>any</code> argument. If the symbol has already +another value, a "redefined" message is issued. When the value of the global +variable <a href="refD.html#*Dbg">*Dbg</a> is non-<code>NIL</code>, the current +line number and file name (if any) are stored in the <code>*Dbg</code> property +of <code>sym</code>. <code>de</code> is the standard way to define a function. +See also <code><a href="refD.html#def">def</a></code>, <code><a +href="refD.html#dm">dm</a></code> and <code><a +href="refU.html#undef">undef</a></code>. + +<pre><code> +: (de foo (X Y) (* X (+ X Y))) # Define a function +-> foo +: (foo 3 4) +-> 21 + +: (de *Var . 123) # Define a variable value +: *Var +-> 123 +</code></pre> + +<dt><a name="debug"><code>(debug 'sym) -> T</code></a> +<dt><code>(debug 'sym 'cls) -> T</code> +<dt><code>(debug '(sym . cls)) -> T</code> +<dd>Inserts a <code><a href="ref_.html#!">!</a></code> breakpoint function call +at the beginning and all top-level expressions of the function or method body of +<code>sym</code>, to allow a stepwise execution. Typing <code>(<a +href="refD.html#d">d</a>)</code> at a breakpoint will also debug the current +subexpression, and <code>(<a href="refE.html#e">e</a>)</code> will evaluate the +current subexpression. The current subexpression is stored in the global +variable <code><a href="ref_.html#^">^</a></code>. See also <code><a +href="refU.html#unbug">unbug</a></code>, <code><a +href="refD.html#*Dbg">*Dbg</a></code>, <code><a +href="refT.html#trace">trace</a></code> and <code><a +href="refL.html#lint">lint</a></code>. + +<pre><code> +: (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 +</code></pre> + +<dt><a name="dec"><code>(dec 'num) -> num</code></a> +<dt><code>(dec 'var ['num]) -> num</code> +<dd>The first form returns the value of <code>num</code> decremented by 1. The +second form decrements the <code>VAL</code> of <code>var</code> by 1, or by +<code>num</code>. If the first argument is <code>NIL</code>, it is returned +immediately. <code>(dec 'num)</code> is equivalent to <code>(- 'num 1)</code> +and <code>(dec 'var)</code> is equivalent to <code>(set 'var (- var 1))</code>. +See also <code><a href="refI.html#inc">inc</a></code> and <code><a +href="ref_.html#-">-</a></code>. + +<pre><code> +: (dec -1) +-> -2 +: (dec 7) +-> 6 +: (setq N 7) +-> 7 +: (dec 'N) +-> 6 +: (dec 'N 3) +-> 3 +</code></pre> + +<dt><a name="def"><code>(def 'sym 'any) -> sym</code></a> +<dt><code>(def 'sym1 'sym2 'any) -> sym1</code> +<dd>The first form assigns a definition to the first <code>sym</code> argument, +by setting its <code>VAL</code>'s to <code>any</code>. The second form defines a +property value <code>any</code> for the first argument's <code>sym2</code> key. +If any of these values existed and was changed in the process, a "redefined" +message is issued. When the value of the global variable <a +href="refD.html#*Dbg">*Dbg</a> is non-<code>NIL</code>, the current line number +and file name (if any) are stored in the <code>*Dbg</code> property of +<code>sym</code>. See also <code><a href="refD.html#de">de</a></code> and +<code><a href="refD.html#dm">dm</a></code>. + +<pre><code> +: (def 'b '((X Y) (* X (+ X Y)))) +-> b +: (def 'b 999) +# b redefined +-> b +</code></pre> + +<dt><a name="default"><code>(default var 'any ..) -> any</code></a> +<dd>Stores new values <code>any</code> in the <code>var</code> arguments only if +their current values are <code>NIL</code>. Otherwise, their values are left +unchanged. <code>default</code> is used typically in functions to initialize +optional arguments. + +<pre><code> +: (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) +</code></pre> + +<dt><a name="del"><code>(del 'any 'var) -> lst</code></a> +<dd>Deletes <code>any</code> from the list in the value of <code>var</code>, and +returns the remaining list. <code>(del 'any 'var)</code> is equivalent to +<code>(set 'var (delete 'any var))</code>. See also <code><a +href="refD.html#delete">delete</a></code>, <code><a +href="refC.html#cut">cut</a></code> and <code><a +href="refP.html#pop">pop</a></code>. + +<pre><code> +: (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) +</code></pre> + +<dt><a name="delete"><code>(delete 'any 'lst) -> lst</code></a> +<dd>Deletes <code>any</code> from <code>lst</code>. If <code>any</code> is +contained more than once in <code>lst</code>, only the first occurrence is +deleted. See also <code><a href="refD.html#delq">delq</a></code>, <code><a +href="refR.html#remove">remove</a></code> and <code><a +href="refI.html#insert">insert</a></code>. + +<pre><code> +: (delete 2 (1 2 3)) +-> (1 3) +: (delete (3 4) '((1 2) (3 4) (5 6) (3 4))) +-> ((1 2) (5 6) (3 4)) +</code></pre> + +<dt><a name="delete/3"><code>delete/3</code></a> +<dd><a href="ref.html#pilog">Pilog</a> predicate that succeeds if deleting the +first argument from the list in the second argument is equal to the third +argument. See also <code><a href="refD.html#delete">delete</a></code> and +<code><a href="refM.html#member/2">member/2</a></code>. + +<pre><code> +: (? (delete b (a b c) @X)) + @X=(a c) +-> NIL +</code></pre> + +<dt><a name="delq"><code>(delq 'any 'lst) -> lst</code></a> +<dd>Deletes <code>any</code> from <code>lst</code>. If <code>any</code> is +contained more than once in <code>lst</code>, only the first occurrence is +deleted. <code><a href="ref_.html#==">==</a></code> is used for comparison +(pointer equality). See also <code><a href="refD.html#delete">delete</a></code>, +<code><a href="refA.html#asoq">asoq</a></code>, <code><a +href="refM.html#memq">memq</a></code>, <code><a +href="refM.html#mmeq">mmeq</a></code> and <a href="ref.html#cmp">Comparing</a>. + +<pre><code> +: (delq 'b '(a b c)) +-> (a c) +: (delq (2) (1 (2) 3)) +-> (1 (2) 3) +</code></pre> + +<dt><a name="dep"><code>(dep 'cls) -> cls</code></a> +<dd>Displays the "dependencies" of <code>cls</code>, i.e. the tree of +superclasses and the tree of subclasses. See also <code><a +href="ref.html#oop">OO Concepts</a></code>, <code><a +href="refC.html#class">class</a></code> and <code><a +href="refC.html#can">can</a></code>. + +<pre><code> +: (dep '+Number) # Dependencies of '+Number' + +relation # Single superclass is '+relation' ++Number + +Date # Subclasses are '+Date' and '+Time' + +Time +-> +Number +</code></pre> + +<dt><a name="depth"><code>(depth 'lst) -> (cnt1 . cnt2)</code></a> +<dd>Returns the maximal (<code>cnt1</code>) and the average (<code>cnt2</code>) +"depth" of a tree structure as maintained by <code><a +href="refI.html#idx">idx</a></code>. See also <code><a +href="refL.html#length">length</a></code> and <code><a +href="refS.html#size">size</a></code>. + +<pre><code> +: (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 +</code></pre> + +<dt><a name="diff"><code>(diff 'lst 'lst) -> lst</code></a> +<dd>Returns the difference of the <code>lst</code> arguments. See also <code><a +href="refS.html#sect">sect</a></code>. + +<pre><code> +: (diff (1 2 3 4 5) (2 4)) +-> (1 3 5) +: (diff (1 2 3) (1 2 3)) +-> NIL +</code></pre> + +<dt><a name="different/2"><code>different/2</code></a> +<dd><a href="ref.html#pilog">Pilog</a> predicate that succeeds if the two +arguments are different. See also <code><a +href="refE.html#equal/2">equal/2</a></code>. + +<pre><code> +: (? (different 3 4)) +-> T +</code></pre> + +<dt><a name="dir"><code>(dir ['any]) -> lst</code></a> +<dd>Returns a list of all filenames in the directory <code>any</code>. Names +starting with a dot '<code>.</code>' are ignored. See also <code><a +href="refC.html#cd">cd</a></code> and <code><a +href="refI.html#info">info</a></code>. + +<pre><code> +: (filter '((F) (tail '(. c) (chop F))) (dir "src/")) +-> ("main.c" "subr.c" "gc.c" "io.c" "big.c" "sym.c" "tab.c" "flow.c" .. +</code></pre> + +<dt><a name="dirname"><code>(dirname 'any) -> sym</code></a> +<dd>Returns the directory part of a path name <code>any</code>. +See also <code><a href="refP.html#path">path</a></code>. + +<pre><code> +: (dirname "a/b/c/d") +-> "a/b/c/" +</code></pre> + +<dt><a name="dm"><code>(dm sym . fun|cls2) -> sym</code></a> +<dt><code>(dm (sym . cls) . fun|cls2) -> sym</code> +<dt><code>(dm (sym sym2 [. cls]) . fun|cls2) -> sym</code> +<dd>Defines a method for the message <code>sym</code> in the current class, +implicitly given by the value of the global variable <code><a +href="refC.html#*Class">*Class</a></code>, or - in the second form - for the +explicitly given class <code>cls</code>. In the third form, the class object is +obtained by <code><a href="refG.html#get">get</a></code>ing <code>sym2</code> +from <code><a href="refC.html#*Class">*Class</a></code> (or <code>cls</code> 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 <code>fun</code> - a +symbol specifying another class <code>cls2</code> is given, the method from that +class is used (explicit inheritance). When the value of the global variable <a +href="refD.html#*Dbg">*Dbg</a> is non-<code>NIL</code>, the current line number +and file name (if any) are stored in the <code>*Dbg</code> property of +<code>sym</code>. See also <code><a href="ref.html#oop">OO Concepts</a></code>, +<code><a href="refD.html#de">de</a></code>, <code><a +href="refU.html#undef">undef</a></code>, <a href="refC.html#class">class</a>, <a +href="refR.html#rel">rel</a>, <a href="refV.html#var">var</a>, <a +href="refM.html#method">method</a>, <a href="refS.html#send">send</a> and <a +href="refT.html#try">try</a>. + +<pre><code> +: (dm start> () + (super) + (mapc 'start> (: fields)) + (mapc 'start> (: arrays)) ) + +: (dm foo> . +OtherClass) # Explicitly inherit 'foo>' from '+OtherClass' +</code></pre> + +<dt><a name="do"><code>(do 'flg|num ['any | (NIL 'any . prg) | (T 'any . prg) ..]) -> any</code></a> +<dd>Counted loop with multiple conditional exits: The body is executed at most +<code>num</code> times (or never (if the first argument is <code>NIL</code>), or +an infinite number of times (if the first argument is <code>T</code>)). If a +clause has <code>NIL</code> or <code>T</code> as its CAR, the clause's second +element is evaluated as a condition and - if the result is <code>NIL</code> or +non-<code>NIL</code>, respectively - the <code>prg</code> is executed and the +result returned. Otherwise (if count drops to zero), the result of the last +expression is returned. See also <code><a href="refL.html#loop">loop</a></code> +and <code><a href="refF.html#for">for</a></code>. + +<pre><code> +: (do 4 (printsp 'OK)) +OK OK OK OK -> OK +: (do 4 (printsp 'OK) (T (= 3 3) (printsp 'done))) +OK done -> done +</code></pre> + +<dt><a name="doc"><code>(doc 'sym1 ['sym2])</code></a> +<dd>Opens a browser, and tries to display the reference documentation for +<code>sym1</code>. <code>sym2</code> may be the name of a browser. If not given, +the value of the environment variable <code>BROWSER</code>, or the +<code>w3m</code> browser is tried. See also <code><a +href="ref.html#fun">Function Reference</a></code> and <code><a +href="refV.html#vi">vi</a></code>. + +<pre><code> +: (doc '+) # Function reference +-> T +: (doc '+relation) # Class reference +-> T +: (doc 'vi "firefox") # Use alternative browser +-> T +</code></pre> + +</dl> + +</body> +</html> diff --git a/doc/refE.html b/doc/refE.html @@ -0,0 +1,486 @@ +<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.0 Transitional//EN" "http://www.w3.org/TR/1998/REC-html40-19980424/loose.dtd"> +<html lang="en"> +<head> +<meta http-equiv="Content-Type" content="text/html; charset=utf-8"> +<title>E</title> +<link rel="stylesheet" href="doc.css" type="text/css"> +</head> +<body> + +<h1>E</h1> + +<dl> + +<dt><a name="*Err"><code>*Err</code></a> +<dd>A global variable holding a (possibly empty) <code>prg</code> body, which +will be executed during error processing. See also <code><a +href="ref.html#errors">Error Handling</a></code>, <code><a +href="refM.html#*Msg">*Msg</a></code> and <code><a +href="ref_.html#^">^</a></code>. + +<pre><code> +: (de *Err (prinl "Fatal error!")) +-> ((prinl "Fatal error!")) +: (/ 3 0) +!? (/ 3 0) +Div/0 +Fatal error! +$ +</code></pre> + +<dt><a name="*Ext"><code>*Ext</code></a> +<dd>A global variable holding a sorted list of cons pairs. The CAR of each pair +specifies an external symbol offset (suitable for <code><a +href="refE.html#ext">ext</a></code>), 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 <code><a href="refG.html#getl">getl</a></code> and <code><a +href="refP.html#putl">putl</a></code>) 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 <code><a +href="refQ.html#qsym">qsym</a></code> and <code><a +href="ref.html#external">external symbols</a></code>. + +<pre><code> +### On the local machine ### +: (setq *Ext # Define extension functions + (mapcar + '((@Host @Ext) + (let Sock NIL + (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) + (out Sock + (pr (eval @)) ) ) ) + (bye) ) # Exit child process + (close Sock) ) ) + (forked) # Close task in children + ... + +</code></pre> + +<dt><a name="+Entity"><code>+Entity</code></a> +<dd>Base class of all database objects. See also <code><a +href="refR.html#+relation">+relation</a></code> and <code><a +href="ref.html#dbase">Database</a></code>. + +<p><a name="entityMesssages">Messages</a> to entity objects include + +<pre><code> +zap> () # Clean up relational structures, for removal from the DB +url> (Tab) # Call the GUI on that object (in optional Tab) +upd> (X Old) # Callback method when object is created/modified/deleted +has> (Var Val) # Check if value is present +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 +</code></pre> + +<dt><a name="e"><code>(e . prg) -> any</code></a> +<dd>Used in a breakpoint. Evaluates <code>prg</code> in the execution +environment, or the currently executed expression if <code>prg</code> is not +given. See also <code><a href="refD.html#debug">debug</a></code>, <code><a +href="ref_.html#!">!</a></code>, <code><a href="ref_.html#^">^</a></code> and +<code><a href="refD.html#*Dbg">*Dbg</a></code>. + +<pre><code> +: (! + 3 4) +(+ 3 4) +! (e) +-> 7 +</code></pre> + +<dt><a name="echo"><code>(echo ['cnt ['cnt]] | ['sym ..]) -> sym</code></a> +<dd>Reads the current input channel, and writes to the current output channel. +If <code>cnt</code> is given, only that many bytes are actually echoed. In case +of two <code>cnt</code> arguments, the first one specifies the number of bytes +to skip in the input stream. Otherwise, if one or more <code>sym</code> +arguments are given, the echo process stops as soon as one of the symbol's names +is encountered in the input stream (in that case, the name will be read (and +that symbol returned), but not written). Returns non-<code>NIL</code> if the +operation was successfully completed. + +<pre><code> +: (in "x.l" (echo)) # Display file on console + .. + +: (out "x2.l" (in "x.l" (echo))) # Copy file "x.l" to "x2.l" +</code></pre> + +<dt><a name="edit"><code>(edit 'sym ..) -> NIL</code></a> +<dd>Edits the value and property list of the argument symbol(s) by calling the +<code>vim</code> editor on a temporary file with these data. When closing the +editor, the modified data are read and stored into the symbol(s). During the +edit session, individual symbols are separated by the pattern +<code>(********)</code>. These separators should not be modified. When moving +the cursor to the beginning of a symbol (no matter if internal, transient or +external), and hitting '<code>K</code>', that symbol is added to the currently +edited symbols. Hitting '<code>Q</code>' will go back one step and return to the +previously edited list of symbols. + +<p><code>edit</code> is especially useful for browsing through the database +(with '<code>K</code>' and '<code>Q</code>'), inspecting external symbols, but +care must be taken when modifying any data as then the <a +href="ref.html#er">entity/relation</a> mechanisms are circumvented, and +<code><a href="refC.html#commit">commit</a></code> has to be called manually if +the changes should be persistent. + +<p>Another typical use case is inserting or removing <code><a +href="ref_.html#!">!</a></code> breakpoints at arbitrary code locations, or +doing other temporary changes to the code for debugging purposes. + +<p>See also <code><a href="refU.html#update">update</a></code> and <code><a +href="refS.html#show">show</a></code>. + +<pre><code> +: (edit (db 'nr '+Item 1)) # Edit a database symbol +### 'vim' shows this ### +{3-1} (+Item) + nr 1 + inv 100 + pr 29900 + sup {2-1} # (+CuSu) + nm "Main Part" + +(********) +### Hitting 'K' on the '{' of '{2-1} ### +{2-1} (+CuSu) + nr 1 + plz "3425" + mob "37 176 86303" + tel "37 4967 6846-0" + fax "37 4967 68462" + nm "Active Parts Inc." + nm2 "East Division" + ort "Freetown" + str "Wildcat Lane" + em "info@api.tld" + +(********) + +{3-1} (+Item) + nr 1 + inv 100 + pr 29900 + sup {2-1} # (+CuSu) + nm "Main Part" + +(********) +### Entering ':q' in vim ### +-> NIL +</code></pre> + +<dt><a name="env"><code>(env ['lst] | ['sym 'val] ..) -> lst</code></a> +<dd>Return a list of symbol-value pairs of all dynamically bound symbols if +called without arguments, or of the symbols in <code>lst</code>, or the +explicitly given <code>sym</code>-<code>val</code> arguments. See also <code><a +href="refB.html#bind">bind</a></code> and <code><a +href="refJ.html#job">job</a></code>. + +<pre><code> +: (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) 'Y 8)) +-> ((Y . 8) (B . 2) (A . 1) (X . 7)) +</code></pre> + +<dt><a name="eof"><code>(eof ['flg]) -> flg</code></a> +<dd>Returns the end-of-file status of the current input channel. If +<code>flg</code> is non-<code>NIL</code>, the channel's status is forced to +end-of-file, so that the next call to <code>eof</code> will return +<code>T</code>, and calls to <code><a href="refC.html#char">char</a></code>, +<code><a href="refP.html#peek">peek</a></code>, <code><a +href="refL.html#line">line</a></code>, <code><a +href="refF.html#from">from</a></code>, <code><a +href="refT.html#till">till</a></code>, <code><a +href="refR.html#read">read</a></code> or <code><a +href="refS.html#skip">skip</a></code> will return <code>NIL</code>. Note that +<code>eof</code> cannot be used with the binary <code><a +href="refR.html#rd">rd</a></code> function. See also <code><a +href="refE.html#eol">eol</a></code>. + +<pre><code> +: (in "file" (until (eof) (println (line T)))) +... +</code></pre> + +<dt><a name="eol"><code>(eol) -> flg</code></a> +<dd>Returns the end-of-line status of the current input channel. +See also <code><a href="refE.html#eof">eof</a></code>. + +<pre><code> +: (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) +</code></pre> + +<dt><a name="equal/2"><code>equal/2</code></a> +<dd><a href="ref.html#pilog">Pilog</a> predicate that succeeds if the two +arguments are equal. See also <code><a href="ref_.html#=">=</a></code>, <code><a +href="refD.html#different/2">different/2</a></code> and <code><a +href="refM.html#member/2">member/2</a></code>. + +<pre><code> +: (? (equal 3 4)) +-> NIL +: (? (equal @N 7)) + @N=7 +-> NIL +</code></pre> + +<dt><a name="errno"><code>(errno) -> cnt</code></a> +<dd>(64-bit version only) Returns the value of the standard I/O 'errno' +variable. + +<pre><code> +: (in "foo") # Produce an error +!? (in "foo") +"foo" -- Open error: No such file or directory +? (errno) +-> 2 # Returned 'ENOENT' +</code></pre> + +<dt><a name="eval"><code>(eval 'any ['cnt ['lst]]) -> any</code></a> +<dd>Evaluates <code>any</code>. Note that because of the standard argument +evaluation, <code>any</code> is actually evaluated twice. If a binding +environment offset <code>cnt</code> is given, the second evaluation takes place +in the corresponding environment, and an optional <code>lst</code> of excluded +symbols can be supplied. See also <code><a href="refR.html#run">run</a></code> +and <code><a href="refU.html#up">up</a></code>. + +<pre><code> +: (eval (list '+ 1 2 3)) +-> 6 +: (setq X 'Y Y 7) +-> 7 +: X +-> Y +: Y +-> 7 +: (eval X) +-> 7 +</code></pre> + +<dt><a name="expDat"><code>(expDat 'sym) -> dat</code></a> +<dd>Expands a <code><a href="refD.html#date">date</a></code> string according to +the current <code><a href="refL.html#locale">locale</a></code> (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. See also <code><a href="refD.html#datStr">datStr</a></code>, <code><a +href="refD.html#day">day</a></code>, <code><a +href="refE.html#expTel">expTel</a></code>. + +<pre><code> +: (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 +</code></pre> + +<dt><a name="expTel"><code>(expTel 'sym) -> sym</code></a> +<dd>Expands a telephone number string. Multiple spaces or hyphens are coalesced. +A leading <code>+</code> or <code>00</code> is removed, a leading <code>0</code> +is replaced with the current country code. Otherwise, <code>NIL</code> is +returned. See also <code><a href="refT.html#telStr">telStr</a></code>, <code><a +href="refE.html#expDat">expDat</a></code> and <code><a +href="refL.html#locale">locale</a></code>. + +<pre><code> +: (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" +</code></pre> + +<dt><a name="expr"><code>(expr 'sym) -> fun</code></a> +<dd>Converts a C-function ("subr") to a Lisp-function. Useful only for normal +functions (i.e. functions that evaluate all arguments). See also <code><a +href="refS.html#subr">subr</a></code>. + +<pre><code> +: car +-> 67313448 +: (expr 'car) +-> (@ (pass $385260187)) +: (car (1 2 3)) +-> 1 +</code></pre> + +<dt><a name="ext"><code>(ext 'cnt . prg) -> any</code></a> +<dd>During the execution of <code>prg</code>, all <code><a +href="ref.html#external">external symbols</a></code> processed by <code><a +href="refR.html#rd">rd</a></code>, <code><a href="refP.html#pr">pr</a></code>, +<code><a href="refR.html#rpc">rpc</a></code> or <code><a +href="refU.html#udp">udp</a></code> are modified by an offset <code>cnt</code> +suitable for mapping via the <code><a href="refE.html#*Ext">*Ext</a></code> +mechanism. All external symbol's file numbers are decremented by +<code>cnt</code> during output, and incremented by <code>cnt</code> during +input. + +<pre><code> +: (out 'a (ext 5 (pr '({6-2} ({8-9} . a) ({7-7} . b))))) +-> ({6-2} ({8-9} . a) ({7-7} . b)) + +: (in 'a (rd)) +-> ({2} ({3-9} . a) ({2-7} . b)) + +: (in 'a (ext 5 (rd))) +-> ({6-2} ({8-9} . a) ({7-7} . b)) +</code></pre> + +<dt><a name="ext?"><code>(ext? 'any) -> sym | NIL</code></a> +<dd>Returns the argument <code>any</code> when it is an existing external +symbol, otherwise <code>NIL</code>. See also <code><a +href="refS.html#sym?">sym?</a></code>, <code><a +href="refB.html#box?">box?</a></code>, <code><a +href="refS.html#str?">str?</a></code>, <code><a +href="refE.html#extern">extern</a></code> and <code><a +href="refL.html#lieu">lieu</a></code>. + +<pre><code> +: (ext? *DB) +-> {1} +: (ext? 'abc) +-> NIL +: (ext? "abc") +-> NIL +: (ext? 123) +-> NIL +</code></pre> + +<dt><a name="extend"><code>(extend cls) -> cls</code></a> +<dd>Extends the class <code>cls</code>, by storing it in the global variable +<code><a href="refC.html#*Class">*Class</a></code>. As a consequence, all +following method, relation and class variable definitions are applied to that +class. See also <code><a href="ref.html#oop">OO Concepts</a></code>, <code><a +href="refC.html#class">class</a></code>, <code><a +href="refD.html#dm">dm</a></code>, <code><a href="refV.html#var">var</a></code>, +<code><a href="refR.html#rel">rel</a></code>, <code><a +href="refT.html#type">type</a></code> and <code><a +href="refI.html#isa">isa</a></code>. + +<pre><code> +</code></pre> + +<dt><a name="extern"><code>(extern 'sym) -> sym | NIL</code></a> +<dd>Creates or finds an external symbol. If a symbol with the name +<code>sym</code> is already extern, it is returned. Otherwise, a new external +symbol is returned. <code>NIL</code> is returned if <code>sym</code> does not +exist in the database. See also <code><a +href="refI.html#intern">intern</a></code> and <code><a +href="refE.html#ext?">ext?</a></code>. + +<pre><code> +: (extern "A1b") +-> {A1b} +: (extern "{A1b}") +-> {A1b} +</code></pre> + +<dt><a name="extra"><code>(extra ['any ..]) -> any</code></a> +<dd>Can only be used inside methods. Sends the current message to the current +object <code>This</code>, 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 <code><a href="ref.html#oop">OO Concepts</a></code>, +<code><a href="refS.html#super">super</a></code>, <code><a +href="refM.html#method">method</a></code>, <code><a +href="refM.html#meth">meth</a></code>, <code><a +href="refS.html#send">send</a></code> and <code><a +href="refT.html#try">try</a></code>. + +<pre><code> +(dm key> (C) # 'key>' method of the '+Uppc' class + (uppc (extra C)) ) # Convert 'key>' of extra classes to upper case +</code></pre> + +<dt><a name="extract"><code>(extract 'fun 'lst ..) -> lst</code></a> +<dd>Applies <code>fun</code> to each element of <code>lst</code>. When +additional <code>lst</code> arguments are given, their elements are also passed +to <code>fun</code>. Returns a list of all non-<code>NIL</code> values returned +by <code>fun</code>. <code>(extract 'fun 'lst)</code> is equivalent to +<code>(mapcar 'fun (filter 'fun 'lst))</code> or, for non-NIL results, to +<code>(mapcan '((X) (and (fun X) (cons @))) 'lst)</code>. See also <code><a +href="refF.html#filter">filter</a></code>, <code><a +href="refF.html#find">find</a></code>, <code><a +href="refP.html#pick">pick</a></code> and <code><a +href="refM.html#mapcan">mapcan</a></code>. + +<pre><code> +: (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) +</code></pre> + +</dl> + +</body> +</html> diff --git a/doc/refF.html b/doc/refF.html @@ -0,0 +1,512 @@ +<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.0 Transitional//EN" "http://www.w3.org/TR/1998/REC-html40-19980424/loose.dtd"> +<html lang="en"> +<head> +<meta http-equiv="Content-Type" content="text/html; charset=utf-8"> +<title>F</title> +<link rel="stylesheet" href="doc.css" type="text/css"> +</head> +<body> + +<h1>F</h1> + +<dl> + +<dt><a name="*Fork"><code>*Fork</code></a> +<dd>A global variable holding a (possibly empty) <code>prg</code> body, to be +executed after a call to <code><a href="refF.html#fork">fork</a></code> in the +child process. + +<pre><code> +: (push '*Fork '(off *Tmp)) # Clear '*Tmp' in child process +-> (off *Tmp) +</code></pre> + +<dt><a name="+Fold"><code>+Fold</code></a> +<dd>Prefix class for maintaining <code><a +href="refF.html#fold">fold</a></code>ed indexes to <code><a +href="refS.html#+String">+String</a></code> relations. Typically used in +combination with the <code><a href="refR.html#+Ref">+Ref</a></code> or <code><a +href="refI.html#+Idx">+Idx</a></code> prefix classes. See also <code><a +href="ref.html#dbase">Database</a></code>. + +<pre><code> +(rel nm (+Fold +Idx +String)) # Item Description +... +(rel tel (+Fold +Ref +String)) # Phone number +</code></pre> + +<dt><a name="fail"><code>(fail) -> lst</code></a> +<dd>Constructs an empty <a href="ref.html#pilog">Pilog</a> query, i.e. a query +that will aways fail. See also <code><a href="refG.html#goal">goal</a></code>. + +<pre><code> +(dm clr> () # Clear query chart in search dialogs + (query> This (fail)) ) +</code></pre> + +<dt><a name="fail/0"><code>fail/0</code></a> +<dd><a href="ref.html#pilog">Pilog</a> predicate that always fails. See also +<code><a href="refT.html#true/0">true/0</a></code>. + +<pre><code> +: (? (fail)) +-> NIL +</code></pre> + +<dt><a name="fetch"><code>(fetch 'tree 'any) -> any</code></a> +<dd>Fetches a value for the key <code>any</code> from a database tree. See also +<code><a href="refT.html#tree">tree</a></code> and <code><a +href="refS.html#store">store</a></code>. + +<pre><code> +: (fetch (tree 'nr '+Item) 2) +-> {3-2} +</code></pre> + +<dt><a name="fifo"><code>(fifo 'var ['any ..]) -> any</code></a> +<dd>Implements a first-in-first-out structure using a circular list. When called +with <code>any</code> arguments, they will be concatenated to end of the +structure. Otherwise, the first element is removed from the structure and +returned. See also <code><a href="refQ.html#queue">queue</a></code>, <code><a +href="refP.html#push">push</a></code>, <code><a +href="refP.html#pop">pop</a></code>, <code><a +href="refR.html#rot">rot</a></code> and <code><a +href="refC.html#circ">circ</a></code>. + +<pre><code> +: (fifo 'X 1) +-> 1 +: (fifo 'X 2 3) +-> 3 +: X +-> (3 1 2 .) +: (fifo 'X) +-> 1 +: (fifo 'X) +-> 2 +: X +-> (3 .) +</code></pre> + +<dt><a name="file"><code>(file) -> (sym1 sym2 . num) | NIL</code></a> +<dd>Returns for the current input channel the path name <code>sym1</code>, the +file name <code>sym2</code>, and the current line number <code>num</code>. If +the current input channel is not a file, <code>NIL</code> is returned. See also +<code><a href="refI.html#info">info</a></code>, <code><a +href="refI.html#in">in</a></code> and <code><a +href="refL.html#load">load</a></code>. + +<pre><code> +: (load (pack (car (file)) "localFile.l")) # Load a file in same directory +</code></pre> + +<dt><a name="fill"><code>(fill 'any ['sym|lst]) -> any</code></a> +<dd>Fills a pattern <code>any</code>, by substituting <code>sym</code>, or all +symbols in <code>lst</code>, or - if no second argument is given - each pattern +symbol in <code>any</code> (see <code><a href="refP.html#pat?">pat?</a></code>), +with its current value. In that case, <code>@</code> itself is not considered a +pattern symbol. See also <code><a href="refM.html#match">match</a></code>. + +<pre><code> +: (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) +</code></pre> + +<dt><a name="filter"><code>(filter 'fun 'lst ..) -> lst</code></a> +<dd>Applies <code>fun</code> to each element of <code>lst</code>. When +additional <code>lst</code> arguments are given, their elements are also passed +to <code>fun</code>. Returns a list of all elements of <code>lst</code> where +<code>fun</code> returned non-<code>NIL</code>. See also <code><a +href="refF.html#fish">fish</a></code>, <code><a +href="refF.html#find">find</a></code>, <code><a +href="refP.html#pick">pick</a></code> and <code><a +href="refE.html#extract">extract</a></code>. + +<pre><code> +: (filter num? (1 A 2 (B) 3 CDE)) +-> (1 2 3) +</code></pre> + +<dt><a name="fin"><code>(fin 'any) -> num|sym</code></a> +<dd>Returns <code>any</code> if it is an atom, otherwise the CDR of its last +cell. See also <code><a href="refL.html#last">last</a></code> and <code><a +href="refT.html#tail">tail</a></code>. + +<pre><code> +: (fin 'a) +-> a +: (fin '(a . b)) +-> b +: (fin '(a b . c)) +-> c +: (fin '(a b c)) +-> NIL +</code></pre> + +<dt><a name="finally"><code>(finally exe . prg) -> any</code></a> +<dd><code>prg</code> is executed, then <code>exe</code> is evaluated, and the +result of <code>prg</code> is returned. <code>exe</code> will also be evaluated +if <code>prg</code> does not terminate normally due to a runtime error or a call +to <code><a href="refT.html#throw">throw</a></code>. See also <code><a +href="refB.html#bye">bye</a></code>, <code><a +href="refC.html#catch">catch</a></code>, <code><a +href="refQ.html#quit">quit</a></code> and <code><a href="ref.html#errors">Error +Handling</a></code>. + +<pre><code> +: (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 +</code></pre> + +<dt><a name="find"><code>(find 'fun 'lst ..) -> any</code></a> +<dd>Applies <code>fun</code> to successive elements of <code>lst</code> until +non-<code>NIL</code> is returned. Returns that element, or <code>NIL</code> if +<code>fun</code> did not return non-<code>NIL</code> for any element of +<code>lst</code>. When additional <code>lst</code> arguments are given, their +elements are also passed to <code>fun</code>. See also <code><a +href="refS.html#seek">seek</a></code>, <code><a +href="refP.html#pick">pick</a></code> and <code><a +href="refF.html#filter">filter</a></code>. + +<pre><code> +: (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 +</code></pre> + +<dt><a name="fish"><code>(fish 'fun 'any) -> lst</code></a> +<dd>Applies <code>fun</code> to each element - and recursively to all sublists - +of <code>lst</code>. Returns a list of all items where <code>fun</code> returned +non-<code>NIL</code>. See also <code><a +href="refF.html#filter">filter</a></code>. + +<pre><code> +: (fish gt0 '(a -2 (1 b (-3 c 2)) 3 d -1)) +-> (1 2 3) +: (fish sym? '(a -2 (1 b (-3 c 2)) 3 d -1)) +-> (a b c d) +</code></pre> + +<dt><a name="flg?"><code>(flg? 'any) -> flg</code></a> +<dd>Returns <code>T</code> when the argument <code>any</code> is either +<code>NIL</code> or <code>T</code>. See also <code><a +href="refB.html#bool">bool</a></code>. <code>(flg? X)</code> is equivalent to +<code>(or (not X) (=T X))</code>. + +<pre><code> +: (flg? (= 3 3)) +-> T +: (flg? (= 3 4)) +-> T +: (flg? (+ 3 4)) +-> NIL +</code></pre> + +<dt><a name="flip"><code>(flip 'lst ['cnt]) -> lst</code></a> +<dd>Returns <code>lst</code> (destructively) reversed. Without the optional +<code>cnt</code> argument, the whole list is flipped, otherwise only the first +<code>cnt</code> elements. See also <code><a +href="refR.html#reverse">reverse</a></code> and <code><a +href="refR.html#rot">rot</a></code>. + +<pre><code> +: (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) +</code></pre> + +<dt><a name="flush"><code>(flush) -> flg</code></a> +<dd>Flushes the current output stream by writing all buffered data. A call to +<code>flush</code> for standard output is done automatically before a call to +<code><a href="refK.html#key">key</a></code>. Returns <code>T</code> when +successful. See also <code><a href="refR.html#rewind">rewind</a></code>. + +<pre><code> +: (flush) +-> T +</code></pre> + +<dt><a name="fmt64"><code>(fmt64 'num) -> sym</code></a> +<dt><code>(fmt64 'sym) -> num</code> +<dd>Converts a number <code>num</code> to a string in base-64 notation, or a +base-64 formatted string to a number. The digits are represented with the +characters <code>0</code> - <code>9</code>, <code>:</code>, <code>;</code>, +<code>A</code> - <code>Z</code> and <code>a</code> - <code>z</code>. This format +is used internally for the names of <code><a +href="ref.html#external-io">external symbols</a></code> in the 32-bit version. +See also <code><a href="refH.html#hax">hax</a></code>, <code><a +href="refH.html#hex">hex</a></code> and <code><a +href="refO.html#oct">oct</a></code>. + +<pre><code> +: (fmt64 9) +-> "9" +: (fmt64 10) +-> ":" +: (fmt64 11) +-> ";" +: (fmt64 12) +-> "A" +: (fmt64 "100") +-> 4096 +</code></pre> + +<dt><a name="fold"><code>(fold 'any ['cnt]) -> sym</code></a> +<dd>Folding to a canonical form: If <code>any</code> is not a symbol, +<code>NIL</code> is returned. Otherwise, a new transient symbol with all digits +and all letters of <code>any</code>, converted to lower case, is returned. If +the <code>cnt</code> argument is given, the result is truncated to that length +(or not truncated if <code>cnt</code> is zero). Otherwise <code>cnt</code> +defaults to 24. See also <code><a href="refL.html#lowc">lowc</a></code>. + +<pre><code> +: (fold " 1A 2-b/3") +-> "1a2b3" +: (fold " 1A 2-B/3" 3) +-> "1a2" +</code></pre> + +<dt><a name="fold/3"><code>fold/3</code></a> +<dd><a href="ref.html#pilog">Pilog</a> predicate that succeeds if the first +argument, after <code><a href="refF.html#fold">fold</a></code>ing it to a +canonical form, is a <i>prefix</i> of the folded string representation of the +result of applying the <code><a href="refG.html#get">get</a></code> algorithm to +the following arguments. Typically used as filter predicate in <code><a +href="refS.html#select/3">select/3</a></code> database queries. See also +<code><a href="refP.html#pre?">pre?</a></code>, <code><a +href="refI.html#isa/2">isa/2</a></code>, <code><a +href="refS.html#same/3">same/3</a></code>, <code><a +href="refB.html#bool/3">bool/3</a></code>, <code><a +href="refR.html#range/3">range/3</a></code>, <code><a +href="refH.html#head/3">head/3</a></code>, <code><a +href="refP.html#part/3">part/3</a></code> and <code><a +href="refT.html#tolr/3">tolr/3</a></code>. + +<pre><code> +: (? + @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={3-1} +-> NIL +</code></pre> + +<dt><a name="for"><code>(for sym 'num ['any | (NIL 'any . prg) | (T 'any . prg) ..]) -> any</code></a> +<dt><code>(for sym|(sym2 . sym) 'lst ['any | (NIL 'any . prg) | (T 'any . prg) ..]) -> any</code> +<dt><code>(for (sym|(sym2 . sym) 'any1 'any2 [. prg]) ['any | (NIL 'any . prg) | (T 'any . prg) ..]) -> any</code> +<dd>Conditional loop with local variable(s) and multiple conditional exits: In +the first form, the value of <code>sym</code> is saved, <code>sym</code> is +bound to <code>1</code>, and the body is executed with increasing values up to +(and including) <code>num</code>. In the second form, the value of +<code>sym</code> is saved, <code>sym</code> is subsequently bound to the +elements of <code>lst</code>, and the body is executed each time. In the third +form, the value of <code>sym</code> is saved, and <code>sym</code> is bound to +<code>any1</code>. If <code>sym2</code> 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 <code>any2</code> evaluates to non-<code>NIL</code>, the +body is repeatedly executed and, if <code>prg</code> is given, <code>sym</code> +is re-bound to the result of its evaluation. If a clause has <code>NIL</code> or +<code>T</code> as its CAR, the clause's second element is evaluated as a +condition and - if the result is <code>NIL</code> or non-<code>NIL</code>, +respectively - the <code>prg</code> is executed and the result returned. If the +body is never executed, <code>NIL</code> is returned. See also <code><a +href="refD.html#do">do</a></code> and <code><a +href="refL.html#loop">loop</a></code>. + +<pre><code> +: (for (N 1 (>= 8 N) (inc N)) (printsp N)) +1 2 3 4 5 6 7 8 -> 8 +: (for (L (1 2 3 4 5 6 7 8) L) (printsp (pop 'L))) +1 2 3 4 5 6 7 8 -> 8 +: (for X (1 a 2 b) (printsp X)) +1 a 2 b -> b +: (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 (I . X) '(a b c d e f) (println I X)) +1 a +2 b +3 c +4 d +5 e +6 f +-> f +</code></pre> + +<dt><a name="fork"><code>(fork) -> pid | NIL</code></a> +<dd>Forks a child process. Returns <code>NIL</code> in the child, and the +child's process ID <code>pid</code> in the parent. In the child, the +<code>VAL</code> of the global variable <code><a +href="refF.html#*Fork">*Fork</a></code> (should be a <code>prg</code>) is +executed. See also <code><a href="refP.html#pipe">pipe</a></code> and <code><a +href="refT.html#tell">tell</a></code>. + +<pre><code> +: (unless (fork) (do 5 (println 'OK) (wait 1000)) (bye)) +-> NIL +OK # Child's output +: OK +OK +OK +OK +</code></pre> + +<dt><a name="forked"><code>(forked)</code></a> +<dd>Installs maintenance code in <code><a +href="refF.html#*Fork">*Fork</a></code> to close server sockets and clean up +<code><a href="refR.html#*Run">*Run</a></code> code in child processes. Should +only be called immediately after <code><a href="refT.html#task">task</a></code>. + +<pre><code> +: (task -60000 60000 (msg 'OK)) # Install timer task +-> (-60000 60000 (msg 'OK)) +: (forked) # No timer in child processes +-> (task -60000) +: *Run +-> ((-60000 56432 (msg 'OK))) +: *Fork +-> ((task -60000) (del '(saveHistory) '*Bye)) +</code></pre> + +<dt><a name="format"><code>(format 'num ['cnt ['sym1 ['sym2]]]) -> sym</code></a> +<dt><code>(format 'sym ['cnt ['sym1 ['sym2]]]) -> num</code> +<dd>Converts a number <code>num</code> to a string, or a string <code>sym</code> +to a number. In both cases, optionally a precision <code>cnt</code>, a +decimal-separator <code>sym1</code> and a thousands-separator <code>sym2</code> +can be supplied. Returns <code>NIL</code> if the conversion is unsuccessful. See +also <code><a href="ref.html#num-io">Numbers</a></code>. + +<pre><code> +: (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 "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 +</code></pre> + +<dt><a name="free"><code>(free 'cnt) -> (sym . lst)</code></a> +<dd>Returns, for the <code>cnt</code>'th database file, the next available +symbol <code>sym</code> (i.e. the first symbol greater than any symbol in the +database), and the list <code>lst</code> of free symbols. See also <code><a +href="refS.html#seq">seq</a></code>, <code><a +href="refZ.html#zap">zap</a></code> and <code><a +href="refD.html#dbck">dbck</a></code>. + +<pre><code> +: (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}) +</code></pre> + +<dt><a name="from"><code>(from 'any ..) -> sym</code></a> +<dd>Skips the current input channel until one of the strings <code>any</code> is +found, and starts subsequent reading from that point. The found <code>any</code> +argument, or <code>NIL</code> (if none is found) is returned. See also <code><a +href="refT.html#till">till</a></code> and <code><a +href="refE.html#echo">echo</a></code>. + +<pre><code> +: (and (from "val='") (till "'" T)) +test val='abc' +-> "abc" +</code></pre> + +<dt><a name="full"><code>(full 'any) -> bool</code></a> +<dd>Returns <code>NIL</code> if <code>any</code> is a non-empty list with at +least one <code>NIL</code> element, otherwise <code>T</code>. <code>(full +X)</code> is equivalent to <code>(not (memq NIL X))</code>. + +<pre><code> +: (full (1 2 3)) +-> T +: (full (1 NIL 3)) +-> NIL +: (full 123) +-> T +</code></pre> + +<dt><a name="fun?"><code>(fun? 'any) -> any</code></a> +<dd>Returns <code>NIL</code> when the argument <code>any</code> 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, <code>T</code> +for a function without arguments, and a single formal parameter or a list of +formal parameters for a function. See also <code><a +href="refG.html#getd">getd</a></code>. + +<pre><code> +: (fun? 1000000000) # Might be a code pointer +-> 1000000000 +: (fun? 100000000000000) # Too big for a code pointer +-> NIL +: (fun? 1000000001) # Cannot be a code pointer (odd) +-> 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 +</code></pre> + +</dl> + +</body> +</html> diff --git a/doc/refG.html b/doc/refG.html @@ -0,0 +1,188 @@ +<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.0 Transitional//EN" "http://www.w3.org/TR/1998/REC-html40-19980424/loose.dtd"> +<html lang="en"> +<head> +<meta http-equiv="Content-Type" content="text/html; charset=utf-8"> +<title>G</title> +<link rel="stylesheet" href="doc.css" type="text/css"> +</head> +<body> + +<h1>G</h1> + +<dl> + +<dt><a name="gc"><code>(gc ['cnt]) -> cnt | NIL</code></a> +<dd>Forces a garbage collection. When <code>cnt</code> is given, so many +megabytes of free cells are reserved, increasing the heap size if necessary. If +<code>cnt</code> is zero, all currently unused heap blocks are purged, +decreasing the heap size if possible. See also <code><a +href="refH.html#heap">heap</a></code>. + +<pre><code> +: (gc) +-> NIL +: (heap) +-> 2 +: (gc 4) +-> 4 +: (heap) +-> 5 +</code></pre> + +<dt><a name="ge0"><code>(ge0 'any) -> num | NIL</code></a> +<dd>Returns <code>num</code> when the argument is a number and greater or equal +zero, otherwise <code>NIL</code>. See also <code><a +href="refG.html#gt0">gt0</a></code>, <code><a +href="refL.html#lt0">lt0</a></code>, <code><a href="ref_.html#=0">=0</a></code> +and <code><a href="refN.html#n0">n0</a></code>. + +<pre><code> +: (ge0 -2) +-> NIL +: (ge0 3) +-> 3 +: (ge0 0) +-> 0 +</code></pre> + +<dt><a name="genKey"><code>(genKey 'var 'cls ['hook ['num1 ['num2]]]) -> num</code></a> +<dd>Generates a key for a database tree. If a minimal key <code>num1</code> +and/or a maximal key <code>num2</code> is given, the next free number in that +range is returned. Otherwise, the current maximal key plus one is returned. See +also <code><a href="refU.html#useKey">useKey</a></code> and <code><a +href="refM.html#maxKey">maxKey</a></code>. + +<pre><code> +: (maxKey (tree 'nr '+Item)) +-> 8 +: (genKey 'nr '+Item) +-> 9 +</code></pre> + +<dt><a name="get"><code>(get 'sym1|lst ['sym2|cnt ..]) -> any</code></a> +<dd>Fetches a value <code>any</code> from the properties of a symbol, or from a +list. From the first argument <code>sym1|lst</code>, values are retrieved in +successive steps by either extracting the value (if the next argument is zero) +or a property from a symbol, the <code><a +href="refA.html#asoq">asoq</a></code>ed 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 +<code><a href="refP.html#put">put</a></code>, <code><a +href="ref_.html#;">;</a></code> and <code><a href="ref_.html#:">:</a></code>. + +<pre><code> +: (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 +</code></pre> + +<dt><a name="getd"><code>(getd 'any) -> fun | NIL</code></a> +<dd>Returns <code>fun</code> if <code>any</code> is a symbol that has a function +definition, otherwise <code>NIL</code>. See also <code><a +href="refF.html#fun?">fun?</a></code>. + +<pre><code> +: (getd '+) +-> 67327232 +: (getd 'script) +-> ((File . @) (load File)) +: (getd 1) +-> NIL +</code></pre> + +<dt><a name="getl"><code>(getl 'sym1|lst1 ['sym2|cnt ..]) -> lst</code></a> +<dd>Fetches the complete property list <code>lst</code> from a symbol. That +symbol is <code>sym1</code> (if no other arguments are given), or a symbol found +by applying the <code><a href="refG.html#get">get</a></code> algorithm to +<code>sym1|lst1</code> and the following arguments. See also <code><a +href="refP.html#putl">putl</a></code> and <code><a +href="refM.html#maps">maps</a></code>. + +<pre><code> +: (put 'X 'a 1) +-> 1 +: (put 'X 'b 2) +-> 2 +: (put 'X 'flg T) +-> T +: (getl 'X) +-> (flg (2 . b) (1 . a)) +</code></pre> + +<dt><a name="glue"><code>(glue 'any 'lst) -> sym</code></a> +<dd>Builds a new transient symbol (string) by <code><a +href="refP.html#pack">pack</a></code>ing the <code>any</code> argument between +the individual elements of <code>lst</code>. See also <code><a +href="refT.html#text">text</a></code>. + +<pre><code> +: (glue "," '(a b c d)) +-> "a,b,c,d" +</code></pre> + +<dt><a name="goal"><code>(goal '([pat 'any ..] . lst) ['sym 'any ..]) -> lst</code></a> +<dd>Constructs a <a href="ref.html#pilog">Pilog</a> query list from the list of +clauses <code>lst</code>. 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 <code>sym</code> and <code>any</code> arguments to +form an initial environment. See also <code><a +href="refP.html#prove">prove</a></code> and <code><a +href="refF.html#fail">fail</a></code>. + +<pre><code> +: (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))) +</code></pre> + +<dt><a name="group"><code>(group 'lst) -> lst</code></a> +<dd>Builds a list of lists, by grouping all elements of <code>lst</code> with +the same CAR into a common sublist. See also <a +href="ref.html#cmp">Comparing</a>, <code><a +href="refB.html#by">by</a></code>, <code><a +href="refS.html#sort">sort</a></code> and <code><a +href="refU.html#uniq">uniq</a></code>. + +<pre><code> +: (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)) +</code></pre> + +<dt><a name="gt0"><code>(gt0 'any) -> num | NIL</code></a> +<dd>Returns <code>num</code> when the argument is a number and greater than +zero, otherwise <code>NIL</code>. See also <code><a +href="refG.html#ge0">ge0</a></code>, <code><a +href="refL.html#lt0">lt0</a></code>, <code><a href="ref_.html#=0">=0</a></code> +and <code><a href="refN.html#n0">n0</a></code>. + +<pre><code> +: (gt0 -2) +-> NIL +: (gt0 3) +-> 3 +</code></pre> + +</dl> + +</body> +</html> diff --git a/doc/refH.html b/doc/refH.html @@ -0,0 +1,216 @@ +<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.0 Transitional//EN" "http://www.w3.org/TR/1998/REC-html40-19980424/loose.dtd"> +<html lang="en"> +<head> +<meta http-equiv="Content-Type" content="text/html; charset=utf-8"> +<title>H</title> +<link rel="stylesheet" href="doc.css" type="text/css"> +</head> +<body> + +<h1>H</h1> + +<dl> + +<dt><a name="*Hup"><code>*Hup</code></a> +<dd>Global variable holding a (possibly empty) <code>prg</code> body, which will +be executed when a SIGHUP signal is sent to the current process. Note that this +mechanism is "unreliable", in the way that when a second signal (it may be +SIGINT, SIGUSR1/2, SIGALRM or SIGTERM) arrives before the first signal's +<code>prg</code> is running, the first signal will be lost. See also <code><a +href="refA.html#alarm">alarm</a></code>, <code><a +href="refR.html#*Run">*Run</a></code>, <code><a +href="refS.html#*Sig1">*Sig[12]</a></code> and <code><a +href="refE.html#*Err">*Err</a></code>. + +<pre><code> +: (de *Hup (msg 'SIGHUP)) +-> *Hup +</code></pre> + +<dt><a name="+Hook"><code>+Hook</code></a> +<dd>Prefix class for <code><a href="refR.html#+relation">+relation</a></code>s, +typically <code><a href="refL.html#+Link">+Link</a></code> or <code><a +href="refJ.html#+Joint">+Joint</a></code>. In essence, this maintains an local +database in the referred object. See also <code><a +href="ref.html#dbase">Database</a></code>. + +<pre><code> +(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 +</code></pre> + +<dt><a name="hax"><code>(hax 'num) -> sym</code></a> +<dt><code>(hax 'sym) -> num</code> +<dd>Converts a number <code>num</code> to a string in hexadecimal/alpha +notation, or a hexadecimal/alpha formatted string to a number. The digits are +represented with the characters <code>@</code> - <code>O</code> (from "alpha" to +"omega"). This format is used internally for the names of <code><a +href="ref.html#external-io">external symbols</a></code> in the 64-bit version. +See also <code><a href="refF.html#fmt64">fmt64</a></code>, <code><a +href="refH.html#hex">hex</a></code> and <code><a +href="refO.html#oct">oct</a></code>. + +<pre><code> +: (hax 7) +-> <u>G</u> +: (hax 16) +-> <u>A@</u> +: (hax 255) +-> <u>OO</u> +: (hax <u>A</u>) +-> 1 +</code></pre> + +<dt><a name="hd"><code>(hd 'sym ['cnt]) -> NIL</code></a> +<dd>Displays a hexadecimal dump of the file given by <code>sym</code>, limited +to <code>cnt</code> lines. See also <code><a +href="refP.html#proc">proc</a></code>. + +<pre><code> +: (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 +</code></pre> + +<dt><a name="head"><code>(head 'cnt|lst 'lst) -> lst</code></a> +<dd>Returns a new list made of the first <code>cnt</code> elements of +<code>lst</code>. If <code>cnt</code> is negative, it is added to the length of +<code>lst</code>. If the first argument is a <code>lst</code>, <code>head</code> +is a predicate function returning that argument list if it is <code>equal</code> +to the head of the second argument, and <code>NIL</code> otherwise. See also +<code><a href="refT.html#tail">tail</a></code>. + +<pre><code> +: (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) +</code></pre> + +<dt><a name="head/3"><code>head/3</code></a> +<dd><a href="ref.html#pilog">Pilog</a> predicate that succeeds if the first +(string) argument is a prefix of the string representation of the result of +applying the <code><a href="refG.html#get">get</a></code> algorithm to the +following arguments. Typically used as filter predicate in <code><a +href="refS.html#select/3">select/3</a></code> database queries. See also +<code><a href="refP.html#pre?">pre?</a></code>, <code><a +href="refI.html#isa/2">isa/2</a></code>, <code><a +href="refS.html#same/3">same/3</a></code>, <code><a +href="refB.html#bool/3">bool/3</a></code>, <code><a +href="refR.html#range/3">range/3</a></code>, <code><a +href="refF.html#fold/3">fold/3</a></code>, <code><a +href="refP.html#part/3">part/3</a></code> and <code><a +href="refT.html#tolr/3">tolr/3</a></code>. + +<pre><code> +: (? + @Nm <u>Muller</u> + @Tel <u>37</u> + (select (@CuSu) + ((nm +CuSu @Nm) (tel +CuSu @Tel)) + (tolr @Nm @CuSu nm) + (head @Tel @CuSu tel) ) + (val @Name @CuSu nm) + (val @Phone @CuSu tel) ) + @Nm=<u>Muller</u> @Tel=<u>37</u> @CuSu={2-3} @Name=<u>Miller</u> @Phone=<u>37 4773 82534</u> +-> NIL +</code></pre> + +<dt><a name="heap"><code>(heap 'flg) -> cnt</code></a> +<dd>Returns the total size of the cell heap space in megabytes. If +<code>flg</code> is non-<code>NIL</code>, the size of the currently free space +is returned. See also <code><a href="refG.html#gc">gc</a></code>. + +<pre><code> +: (gc 4) +-> 4 +: (heap) +-> 5 +: (heap T) +-> 4 +</code></pre> + +<dt><a name="hear"><code>(hear 'cnt) -> cnt</code></a> +<dd>Uses the file descriptor <code>cnt</code> 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 +<code><a href="refT.html#tell">tell</a></code>), <code>hear</code> is usually +only called explicitly by a top level parent process. + +<pre><code> +: (call 'mkfifo <u>fifo/cmd</u>) +-> T +: (hear (open <u>fifo/cmd</u>)) +-> 3 +</code></pre> + +<dt><a name="here"><code>(here ['sym]) -> sym</code></a> +<dd>Echoes the current input stream until <code>sym</code> is encountered, or +until end of file. See also <code><a href="refE.html#echo">echo</a></code>. + +<pre><code> +$ cat hello.l +(html 0 <u>Hello</u> <u>lib.css</u> NIL + (&lt;h2&gt; NIL <u>Hello</u>) + (here) ) +&lt;p&gt;Hello!&lt;/p&gt; +&lt;p&gt;This is a test.&lt;/p&gt; + +$ ./p 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 + +&lt;!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd"&gt; +&lt;html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en" lang="en"&gt; +&lt;head&gt; +&lt;title&gt;Hello&lt;/title&gt; +&lt;link rel="stylesheet" href="http://:/lib.css" type="text/css"/&gt; +&lt;/head&gt; +&lt;body&gt;&lt;h2&gt;Hello&lt;/h2&gt; +&lt;p&gt;Hello!&lt;/p&gt; +&lt;p&gt;This is a test.&lt;/p&gt; +&lt;/body&gt; +&lt;/html&gt; +</code></pre> + +<dt><a name="hex"><code>(hex 'num) -> sym</code></a> +<dt><code>(hex 'sym) -> num</code> +<dd>Converts a number <code>num</code> to a hexadecimal string, or a hexadecimal +string <code>sym</code> to a number. See also <code><a +href="refO.html#oct">oct</a></code> and <code><a +href="refF.html#format">format</a></code>. + +<pre><code> +: (hex 273) +-> <u>111</u> +: (hex <u>111</u>) +-> 273 +</code></pre> + +<dt><a name="host"><code>(host 'any) -> sym</code></a> +<dd>Returns the hostname corresponding to the given IP address. See also +<code><a href="refA.html#*Adr">*Adr</a></code>. + +<pre><code> +: (host <u>80.190.158.9</u>) +-> <u>www.leo.org</u> +</code></pre> + +</dl> + +</body> +</html> diff --git a/doc/refI.html b/doc/refI.html @@ -0,0 +1,389 @@ +<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.0 Transitional//EN" "http://www.w3.org/TR/1998/REC-html40-19980424/loose.dtd"> +<html lang="en"> +<head> +<meta http-equiv="Content-Type" content="text/html; charset=utf-8"> +<title>I</title> +<link rel="stylesheet" href="doc.css" type="text/css"> +</head> +<body> + +<h1>I</h1> + +<dl> + +<dt><a name="+Idx"><code>+Idx</code></a> +<dd>Prefix class for maintaining non-unique full-text indexes to <code><a +href="refS.html#+String">+String</a></code> relations, a subclass of <code><a +href="refR.html#+Ref">+Ref</a></code>. Accepts optional arguments for the +minimally indexed substring length (defaults to 3), and a <code><a +href="refH.html#+Hook">+Hook</a></code> attribute. Often used in combination +with the <code><a href="refS.html#+Sn">+Sn</a></code> soundex index, or the +<code><a href="refF.html#+Fold">+Fold</a></code> index prefix classes. See also +<code><a href="ref.html#dbase">Database</a></code>. + +<pre><code> +(rel nm (+Sn +Idx +String)) # Name +</code></pre> + +<dt><a name="+index"><code>+index</code></a> +<dd>Abstract base class of all database B-Tree index relations (prefix classes +for <code><a href="refR.html#+relation">+relation</a></code>s). The class +hierarchy includes <code><a href="refK.html#+Key">+Key</a></code>, <code><a +href="refR.html#+Ref">+Ref</a></code> and <code><a +href="refI.html#+Idx">+Idx</a></code>. See also <code><a +href="ref.html#dbase">Database</a></code>. + +<pre><code> +(isa '+index Rel) # Check for an index relation +</code></pre> + +<dt><a name="id"><code>(id 'num ['num]) -> sym</code></a> +<dt><code>(id 'sym [NIL]) -> num</code> +<dt><code>(id 'sym T) -> (num . num)</code> +<dd>Converts one or two numbers to an external symbol, or an external symbol to +a number or a pair of numbers. + +<pre><code> +: (id 7) +-> {7} +: (id 1 2) +-> {2} +: (id '{1-2}) +-> 2 +: (id '{1-2} T) +-> (1 . 2) +</code></pre> + +<dt><a name="idx"><code>(idx 'var 'any 'flg) -> lst<br> +(idx 'var 'any) -> lst<br> +(idx 'var) -> lst</code></a> +<dd>Maintains an index tree in <code>var</code>, and checks for the existence of +<code>any</code>. If <code>any</code> is contained in <code>var</code>, the +corresponding subtree is returned, otherwise <code>NIL</code>. In the first +form, <code>any</code> is destructively inserted into the tree if +<code>flg</code> is non-<code>NIL</code> (and <code>any</code> was not already +there), or deleted from the tree if <code>flg</code> is <code>NIL</code>. The +second form only checks for existence, but does not change the index tree. In +the third form (when called with a single <code>var</code> argument) the +contents of the tree are returned as a sorted list. If all elements are inserted +in sorted order, the tree degenerates into a linear list. See also <code><a +href="refL.html#lup">lup</a></code>, <code><a +href="refD.html#depth">depth</a></code>, <code><a +href="refS.html#sort">sort</a></code>, <code><a +href="refB.html#balance">balance</a></code> and <code><a +href="refM.html#member">member</a></code>. + +<pre><code> +: (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 +</code></pre> + +<dt><a name="if"><code>(if 'any1 'any2 . prg) -> any</code></a> +<dd>Conditional execution: If the condition <code>any1</code> evaluates to +non-<code>NIL</code>, <code>any2</code> is evaluated and returned. Otherwise, +<code>prg</code> is executed and the result returned. See also <code><a +href="refC.html#cond">cond</a></code>, <code><a +href="refW.html#when">when</a></code> and <code><a +href="refI.html#if2">if2</a></code>. + +<pre><code> +: (if (> 4 3) (println 'OK) (println 'Bad)) +OK +-> OK +: (if (> 3 4) (println 'OK) (println 'Bad)) +Bad +-> Bad +</code></pre> + +<dt><a name="if2"><code>(if2 'any1 'any2 'any3 'any4 'any5 . prg) -> any</code></a> +<dd>Four-way conditional execution for two conditions: If both conditions +<code>any1</code> and <code>any2</code> evaluate to non-<code>NIL</code>, +<code>any3</code> is evaluated and returned. Otherwise, <code>any4</code> or +<code>any5</code> is evaluated and returned if <code>any1</code> or +<code>any2</code> evaluate to non-<code>NIL</code>, respectively. If none of the +conditions evaluate to non-<code>NIL</code>, <code>prg</code> is executed and +the result returned. See also <code><a href="refI.html#if">if</a></code> and +<code><a href="refC.html#cond">cond</a></code>. + +<pre><code> +: (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 +</code></pre> + +<dt><a name="ifn"><code>(ifn 'any1 'any2 . prg) -> any</code></a> +<dd>Conditional execution ("If not"): If the condition <code>any1</code> +evaluates to <code>NIL</code>, <code>any2</code> is evaluated and returned. +Otherwise, <code>prg</code> is executed and the result returned. + +<pre><code> +: (ifn (= 3 4) (println 'OK) (println 'Bad)) +OK +-> OK +</code></pre> + +<dt><a name="in"><code>(in 'any . prg) -> any</code></a> +<dd>Opens <code>any</code> as input channel during the execution of +<code>prg</code>. The current input channel will be saved and restored +appropriately. If the argument is <code>NIL</code>, standard input is used. If +the argument is a symbol, it is used as a file name (opened for reading +<i>and</i> writing if the first character is "<code>+</code>"). 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. See also <code><a +href="refI.html#ipid">ipid</a></code>, <code><a +href="refC.html#call">call</a></code>, <code><a +href="refL.html#load">load</a></code>, <code><a +href="refF.html#file">file</a></code>, <code><a +href="refO.html#out">out</a></code>, <code><a +href="refP.html#pipe">pipe</a></code> and <code><a +href="refC.html#ctl">ctl</a></code>. + +<pre><code> +: (in "a" (list (read) (read) (read))) # Read three items from file "a" +-> (123 (a b c) def) +</code></pre> + +<dt><a name="inc"><code>(inc 'num) -> num<br> +(inc 'var ['num]) -> num</code></a> +<dd>The first form returns the value of <code>num</code> incremented by 1. The +second form increments the <code>VAL</code> of <code>var</code> by 1, or by +<code>num</code>. If the first argument is <code>NIL</code>, it is returned +immediately. <code>(inc 'num)</code> is equivalent to <code>(+ 'num 1)</code> +and <code>(inc 'var)</code> is equivalent to <code>(set 'var (+ var 1))</code>. +See also <code><a href="refD.html#dec">dec</a></code> and <code><a +href="ref_.html#+">+</a></code>. + +<pre><code> +: (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) +</code></pre> + +<dt><a name="inc!"><code>(inc! 'obj 'sym ['num]) -> num</code></a> +<dd><a href="ref.html#trans">Transaction</a> wrapper function for <code><a +href="refI.html#inc">inc</a></code>. <code>num</code> defaults to 1. Note that +for incrementing a property value of an entity typically the <code><a +href="refE.html#entityMesssages">inc!></a></code> message is used. See also +<code><a href="refN.html#new!">new!</a></code>, <code><a +href="refS.html#set!">set!</a></code> and <code><a +href="refP.html#put!">put!</a></code>. + +<pre><code> +(inc! Obj 'cnt 0) # Incrementing a property of a non-entity object +</code></pre> + +<dt><a name="index"><code>(index 'any 'lst) -> cnt | NIL</code></a> +<dd>Returns the <code>cnt</code> position of <code>any</code> in +<code>lst</code>, or <code>NIL</code> if it is not found. See also <code><a +href="refO.html#offset">offset</a></code>. + +<pre><code> +: (index 'c '(a b c d e f)) +-> 3 +: (index '(5 6) '((1 2) (3 4) (5 6) (7 8))) +-> 3 +</code></pre> + +<dt><a name="info"><code>(info 'any) -> (cnt|T dat . tim)</code></a> +<dd>Returns information about a file with the name <code>any</code>: The current +size <code>cnt</code> in bytes, and the modification date and time (UTC). For +directories, <code>T</code> is returned instead of the a size. See also <code><a +href="refD.html#dir">dir</a></code>, <code><a +href="refD.html#date">date</a></code>, <code><a +href="refT.html#time">time</a></code> and <code><a +href="refL.html#lines">lines</a></code>. + +<pre><code> +$ ls -l x.l +-rw-r--r-- 1 abu users 208 Jun 17 08:58 x.l +$ ./dbg +: (info "x.l") +-> (208 730594 . 32315) +: (stamp 730594 32315) +-> "2000-06-17 08:58:35" +</code></pre> + +<dt><a name="init"><code>(init 'tree ['any1] ['any2]) -> lst</code></a> +<dd>Initializes a structure for stepping iteratively through a database tree. +<code>any1</code> and <code>any2</code> may specify a range of keys. If +<code>any2</code> is greater than <code>any1</code>, the traversal will be in +opposite direction. See also <code><a href="refT.html#tree">tree</a></code>, +<code><a href="refS.html#step">step</a></code>, <code><a +href="refI.html#iter">iter</a></code> and <code><a +href="refS.html#scan">scan</a></code>. + +<pre><code> +: (init (tree 'nr '+Item) 3 5) +-> (((3 . 5) ((3 NIL . {3-3}) (4 NIL . {3-4}) (5 NIL . {3-5}) (6 NIL . {3-6}) (7 NIL . {3-8})))) +</code></pre> + +<dt><a name="insert"><code>(insert 'cnt 'lst 'any) -> lst</code></a> +<dd>Inserts <code>any</code> into <code>lst</code> at position <code>cnt</code>. +See also <code><a href="refR.html#remove">remove</a></code>, <code><a +href="refP.html#place">place</a></code>, <code><a +href="refA.html#append">append</a></code>, <code><a +href="refD.html#delete">delete</a></code> and <code><a +href="refR.html#replace">replace</a></code>. + +<pre><code> +: (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) +</code></pre> + +<dt><a name="intern"><code>(intern 'sym) -> sym</code></a> +<dd>Creates or finds an internal symbol. If a symbol with the name +<code>sym</code> is already intern, it is returned. Otherwise, <code>sym</code> +is interned and returned. See also <code><a href="refZ.html#zap">zap</a></code>, +<code><a href="refE.html#extern">extern</a></code> and <code><a +href="ref_.html#====">====</a></code>. + +<pre><code> +: (intern "abc") +-> abc +: (intern 'car) +-> car +: ((intern (pack "c" "a" "r")) (1 2 3)) +-> 1 +</code></pre> + +<dt><a name="ipid"><code>(ipid) -> pid | NIL</code></a> +<dd>Returns the corresponding process ID when the current input channel is +reading from a pipe, otherwise <code>NIL</code>. See also <code><a +href="refO.html#opid">opid</a></code>, <code><a +href="refI.html#in">in</a></code>, <code><a +href="refP.html#pipe">pipe</a></code> and <code><a +href="refL.html#load">load</a></code>. + +<pre><code> +: (in '(ls "-l") (println (line T)) (kill (ipid))) +"total 7364" +-> T +</code></pre> + +<dt><a name="isa"><code>(isa 'cls|typ 'obj) -> obj | NIL</code></a> +<dd>Returns <code>obj</code> when it is an object that inherits from +<code>cls</code> or <code>type</code>. See also <code><a href="ref.html#oop">OO +Concepts</a></code>, <code><a href="refC.html#class">class</a></code>, <code><a +href="refT.html#type">type</a></code>, <code><a +href="refN.html#new">new</a></code> and <code><a +href="refO.html#object">object</a></code>. + +<pre><code> +: (isa '+Address Obj) +-> {1-17} +: (isa '(+Male +Person) Obj) +-> NIL +</code></pre> + +<dt><a name="isa/2"><code>isa/2</code></a> +<dd><a href="ref.html#pilog">Pilog</a> predicate that succeeds if the second +argument is of the type or class given by the first argument, according to the +<code><a href="refI.html#isa">isa</a></code> function. Typically used in +<code><a href="refD.html#db/3">db/3</a></code> or <code><a +href="refS.html#select/3">select/3</a></code> database queries. See also +<code><a href="refS.html#same/3">same/3</a></code>, <code><a +href="refB.html#bool/3">bool/3</a></code>, <code><a +href="refR.html#range/3">range/3</a></code>, <code><a +href="refH.html#head/3">head/3</a></code>, <code><a +href="refF.html#fold/3">fold/3</a></code>, <code><a +href="refP.html#part/3">part/3</a></code> and <code><a +href="refT.html#tolr/3">tolr/3</a></code>. + +<pre><code> +: (? (db nm +Person @Prs) (isa +Woman @Prs) (val @Nm @Prs nm)) + @Prs={2-Y} @Nm="Alexandra of Denmark" + @Prs={2-1I} @Nm="Alice Maud Mary" + @Prs={2-F} @Nm="Anne" + @Prs={2-j} @Nm="Augusta Victoria". # Stop +</code></pre> + +<dt><a name="iter"><code>(iter 'tree ['fun] ['any1] ['any2] ['flg])</code></a> +<dd>Iterates through a database tree by applying <code>fun</code> to all values. +<code>fun</code> defaults to <code><a +href="refP.html#println">println</a></code>. <code>any1</code> and +<code>any2</code> may specify a range of keys. If <code>any2</code> is greater +than <code>any1</code>, the traversal will be in opposite direction. If +<code>flg</code> is non-<code>NIL</code>, partial keys are skipped. See also +<code><a href="refT.html#tree">tree</a></code>, <code><a +href="refS.html#scan">scan</a></code>, <code><a +href="refI.html#init">init</a></code> and <code><a +href="refS.html#step">step</a></code>. + +<pre><code> +: (iter (tree 'nr '+Item)) +{3-1} +{3-2} +{3-3} +{3-4} +{3-5} +{3-6} +{3-8} +-> {7-1} +: (iter (tree 'nr '+Item) '((This) (println (: nm)))) +"Main Part" +"Spare Part" +"Auxiliary Construction" +"Enhancement Additive" +"Metal Fittings" +"Gadget Appliance" +"Testartikel" +-> {7-1} +</code></pre> + +</dl> + +</body> +</html> diff --git a/doc/refJ.html b/doc/refJ.html @@ -0,0 +1,81 @@ +<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.0 Transitional//EN" "http://www.w3.org/TR/1998/REC-html40-19980424/loose.dtd"> +<html lang="en"> +<head> +<meta http-equiv="Content-Type" content="text/html; charset=utf-8"> +<title>J</title> +<link rel="stylesheet" href="doc.css" type="text/css"> +</head> +<body> + +<h1>J</h1> + +<dl> + +<dt><a name="+Joint"><code>+Joint</code></a> +<dd>Class for bidirectional object relations, a subclass of <code><a +href="refL.html#+Link">+Link</a></code>. Expects a (symbolic) attribute, and +list of classes as <code><a href="refT.html#type">type</a></code> of the +referred database object (of class <code><a +href="refE.html#+Entity">+Entity</a></code>). A <code>+Joint</code> corresponds +to two <code>+Link</code>s, where the attribute argument is the relation of the +back-link in the referred object. See also <code><a +href="ref.html#dbase">Database</a></code>. + +<pre><code> +(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) # Back-link to the parent order +</code></pre> + +<dt><a name="job"><code>(job 'lst . prg) -> any</code></a> +<dd>Executes a job within its own environment (as specified by symbol-value +pairs in <code>lst</code>). The current values of all symbols are saved, the +symbols are bound to the values in <code>lst</code>, <code>prg</code> 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 <code>prg</code>. Typically used in <code><a +href="refC.html#curry">curried</a></code> functions and <code><a +href="refR.html#*Run">*Run</a></code> tasks. See also <code><a +href="refE.html#env">env</a></code>, <code><a +href="refB.html#bind">bind</a></code>, <code><a +href="refL.html#let">let</a></code>, <code><a +href="refU.html#use">use</a></code> and <code><a +href="refS.html#state">state</a></code>. + +<pre><code> +: (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 +</code></pre> + +<dt><a name="journal"><code>(journal 'any ..) -> T</code></a> +<dd>Reads journal data from the files with the names <code>any</code>, and +writes all changes to the database. See also <code><a +href="refP.html#pool">pool</a></code>. + +<pre><code> +: (journal <u>db.log</u>) +-> T +</code></pre> + +</dl> + +</body> +</html> diff --git a/doc/refK.html b/doc/refK.html @@ -0,0 +1,58 @@ +<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.0 Transitional//EN" "http://www.w3.org/TR/1998/REC-html40-19980424/loose.dtd"> +<html lang="en"> +<head> +<meta http-equiv="Content-Type" content="text/html; charset=utf-8"> +<title>K</title> +<link rel="stylesheet" href="doc.css" type="text/css"> +</head> +<body> + +<h1>K</h1> + +<dl> + +<dt><a name="+Key"><code>+Key</code></a> +<dd>Prefix class for maintaining unique indexes to <code><a +href="refR.html#+relation">+relation</a></code>s, a subclass of <code><a +href="refI.html#+index">+index</a></code>. Accepts an optional argument for a +<code><a href="refH.html#+Hook">+Hook</a></code> attribute. See also <code><a +href="ref.html#dbase">Database</a></code>. + +<pre><code> +(rel nr (+Need +Key +Number)) # Mandatory, unique Customer/Supplier number +</code></pre> + +<dt><a name="key"><code>(key ['cnt]) -> sym</code></a> +<dd>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 <code>select</code> system call is executed for all file descriptors and +timers in the <code>VAL</code> of the global variable <code><a +href="refR.html#*Run">*Run</a></code>. If <code>cnt</code> is +non-<code>NIL</code>, that amount of milliseconds is waited maximally, and +<code>NIL</code> is returned upon timeout. See also <code><a +href="refR.html#raw">raw</a></code> and <code><a +href="refW.html#wait">wait</a></code>. + +<pre><code> +: (key) # Wait for a key +-> <u>a</u> # 'a' pressed +</code></pre> + +<dt><a name="kill"><code>(kill 'pid ['cnt]) -> flg</code></a> +<dd>Sends a signal with the signal number <code>cnt</code> (or SIGTERM if +<code>cnt</code> is not given) to the process with the ID <code>pid</code>. +Returns <code>T</code> if successful. + +<pre><code> +: (kill *Pid 20) # Stop current process + +[2]+ Stopped bin/picolisp # Unix shell +$ fg # Job control: Foreground +bin/picolisp +-> T # 'kill' was successful +</code></pre> + +</dl> + +</body> +</html> diff --git a/doc/refL.html b/doc/refL.html @@ -0,0 +1,531 @@ +<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.0 Transitional//EN" "http://www.w3.org/TR/1998/REC-html40-19980424/loose.dtd"> +<html lang="en"> +<head> +<meta http-equiv="Content-Type" content="text/html; charset=utf-8"> +<title>L</title> +<link rel="stylesheet" href="doc.css" type="text/css"> +</head> +<body> + +<h1>L</h1> + +<dl> + +<dt><a name="*Led"><code>*Led</code></a> +<dd>A global variable holding a (possibly empty) <code>prg</code> body that +implements a "Line editor". When non-<code>NIL</code>, it should return a single +symbol (string) upon execution. + +<pre><code> +: (de *Led "(bye)") +# *Led redefined +-> *Led +: $ # Exit +</code></pre> + +<dt><a name="+Link"><code>+Link</code></a> +<dd>Class for object relations, a subclass of <code><a +href="refR.html#+relation">+relation</a></code>. Expects a list of classes as +<code><a href="refT.html#type">type</a></code> of the referred database object +(of class <code><a href="refE.html#+Entity">+Entity</a></code>). See also +<code><a href="ref.html#dbase">Database</a></code>. + +<pre><code> +(rel sup (+Ref +Link) NIL (+CuSu)) # Supplier (class Customer/Supplier) +</code></pre> + +<dt><a name="+List"><code>+List</code></a> +<dd>Prefix class for a list of identical relations. Objects of that class +maintain a list of Lisp data of uniform type. See also <code><a +href="ref.html#dbase">Database</a></code>. + +<pre><code> +(rel pos (+List +Joint) ord (+Pos)) # Positions +(rel nm (+List +Fold +Ref +String)) # List of folded and indexed names +(rel val (+Ref +List +Number)) # Indexed list of numeric values +</code></pre> + +<dt><a name="last"><code>(last 'lst) -> any</code></a> +<dd>Returns the last element of <code>lst</code>. See also <code><a +href="refF.html#fin">fin</a></code> and <code><a +href="refT.html#tail">tail</a></code>. + +<pre><code> +: (last (1 2 3 4)) +-> 4 +: (last '((a b) c (d e f))) +-> (d e f) +</code></pre> + +<dt><a name="later"><code>(later 'var . prg) -> var</code></a> +<dd>Executes <code>prg</code> in a <code><a +href="refP.html#pipe">pipe</a></code>'ed child process. The return value of +<code>prg</code> will later be available in <code>var</code>. + +<pre><code> +: (prog1 # Parallel background calculation of square numbers + (mapcan '((N) (later (cons) (* N N))) (1 2 3 4)) + (wait NIL (full @)) ) +-> (1 4 9 16) +</code></pre> + +<dt><a name="ld"><code>(ld) -> any</code></a> +<dd><code><a href="refL.html#load">load</a></code>s the last file edited with +<code><a href="refV.html#vi">vi</a></code>. + +<pre><code> +: (vi 'main) +-> T +: (ld) +# main redefined +-> go +</code></pre> + +<dt><a name="leaf"><code>(leaf 'tree) -> any</code></a> +<dd>Returns the first leaf (i.e. the value of the smallest key) in a database +tree. See also <code><a href="refT.html#tree">tree</a></code>, <code><a +href="refM.html#minKey">minKey</a></code>, <code><a +href="refM.html#maxKey">maxKey</a></code> and <code><a +href="refS.html#step">step</a></code>. + +<pre><code> +: (leaf (tree 'nr '+Item)) +-> {3-1} +: (db 'nr '+Item (minKey (tree 'nr '+Item))) +-> {3-1} +</code></pre> + +<dt><a name="length"><code>(length 'any) -> cnt | T</code></a> +<dd>Returns the "length" of <code>any</code>. 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 elements (or +<code>T</code> for circular lists). See also <code><a +href="refS.html#size">size</a></code>. + +<pre><code> +: (length "abc") +-> 3 +: (length "äbc") +-> 3 +: (length 123) +-> 3 +: (length (1 (2) 3)) +-> 3 +: (length (1 2 3 .)) +-> T +</code></pre> + +<dt><a name="let"><code>(let sym 'any . prg) -> any</code></a> +<dt><code>(let (sym 'any ..) . prg) -> any</code> +<dd>Defines local variables. The value of the symbol <code>sym</code> - or the +values of the symbols <code>sym</code> in the list of the second form - are +saved and the symbols are bound to the evaluated <code>any</code> arguments. +<code>prg</code> is executed, then the symbols are restored to their original +values. The result of <code>prg</code> is returned. It is an error condition to +pass <code>NIL</code> as a <code>sym</code> argument. See also <code><a +href="refL.html#let?">let?</a></code>, <code><a +href="refB.html#bind">bind</a></code>, <code><a +href="refR.html#recur">recur</a></code>, <code><a +href="refJ.html#job">job</a></code> and <code><a +href="refU.html#use">use</a></code>. + +<pre><code> +: (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 +</code></pre> + +<dt><a name="let?"><code>(let? sym 'any . prg) -> any</code></a> +<dd>Conditional local variable binding and execution: If <code>any</code> +evalutes to <code>NIL</code>, <code>NIL</code> is returned. Otherwise, the value +of the symbol <code>sym</code> is saved and <code>sym</code> is bound to the +evaluated <code>any</code> argument. <code>prg</code> is executed, then +<code>sym</code> is restored to its original value. The result of +<code>prg</code> is returned. It is an error condition to pass <code>NIL</code> +as the <code>sym</code> argument. <code>(let? sym 'any ..)</code> is equivalent +to <code>(when 'any (let sym @ ..))</code>. See also <code><a +href="refL.html#let">let</a></code>, <code><a +href="refB.html#bind">bind</a></code>, <code><a +href="refJ.html#job">job</a></code> and <code><a +href="refU.html#use">use</a></code>. + +<pre><code> +: (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 +</code></pre> + +<dt><a name="lieu"><code>(lieu 'any) -> sym | NIL</code></a> +<dd>Returns the argument <code>any</code> when it is an external symbol and +currently manifest in heap space, otherwise <code>NIL</code>. See also <code><a +href="refE.html#ext?">ext?</a></code>. + +<pre><code> +: (lieu *DB) +-> {1} +</code></pre> + +<dt><a name="line"><code>(line 'flg ['cnt ..]) -> lst|sym</code></a> +<dd>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 <code>flg</code> is +<code>NIL</code>, a list of single-character transient symbols is returned. When +<code>cnt</code> arguments are given, subsequent characters of the input line +are grouped into sublists, to allow parsing of fixed field length records. If +<code>flg</code> is non-<code>NIL</code>, strings are returned instead of +single-character lists. <code>NIL</code> is returned upon end of file. See also +<code><a href="refC.html#char">char</a></code>, <code><a +href="refT.html#till">till</a></code> and <code><a +href="refE.html#eof">eof</a></code>. + +<pre><code> +: (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") +</code></pre> + +<dt><a name="lines"><code>(lines 'any ..) -> cnt</code></a> +<dd>Returns the sum of the number of lines in the files with the names +<code>any</code>, or <code>NIL</code> if none was found. See also <code><a +href="refI.html#info">info</a></code>. + +<pre><code> +: (lines "x.l") +-> 11 +</code></pre> + +<dt><a name="link"><code>(link 'any ..) -> any</code></a> +<dd>Links one or several new elements <code>any</code> to the end of the list in +the current <code><a href="refM.html#make">make</a></code> environment. This +operation is efficient also for long lists, because a pointer to the last +element of the list is maintained. <code>link</code> returns the last linked +argument. See also <code><a href="refY.html#yoke">yoke</a></code>, <code><a +href="refC.html#chain">chain</a></code> and <code><a +href="refM.html#made">made</a></code>. + +<pre><code> +: (make + (println (link 1)) + (println (link 2 3)) ) +1 +3 +-> (1 2 3) +</code></pre> + +<dt><a name="lint"><code>(lint 'sym) -> lst</code></a> +<dt><code>(lint 'sym 'cls) -> lst</code> +<dt><code>(lint '(sym . cls)) -> lst</code> +<dd>Checks the function definition or file contents (in the first form), or the +method body of sym (second and third form), for possible pitfalls. Returns a +list of diagnoses, where <code>var</code> indicates improper variables, +<code>dup</code> duplicate parameters, <code>def</code> an undefined function, +<code>bnd</code> an unbound variable, and <code>use</code> unused variables. See +also <code><a href="refN.html#noLint">noLint</a></code>, <code><a +href="refL.html#lintAll">lintAll</a></code>, <code><a +href="refD.html#debug">debug</a></code>, <code><a +href="refT.html#trace">trace</a></code> and <code><a +href="refD.html#*Dbg">*Dbg</a></code>. + +<pre><code> +: (de foo (R S T R) # 'T' is a 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)) +</code></pre> + +<dt><a name="lintAll"><code>(lintAll ['sym ..]) -> lst</code></a> +<dd>Applies <code><a href="refL.html#lint">lint</a></code> to <code><a +href="refA.html#all">all</a></code> internal symbols - and optionally to all +files <code>sym</code> - and returns a list of diagnoses. See also <code><a +href="refN.html#noLint">noLint</a></code>. + +<pre><code> +: (more (lintAll "file1.l" "file2.l")) +... +</code></pre> + +<dt><a name="list"><code>(list 'any ['any ..]) -> lst</code></a> +<dd>Returns a list of all <code>any</code> arguments. See also <code><a +href="refC.html#cons">cons</a></code>. + +<pre><code> +: (list 1 2 3 4) +-> (1 2 3 4) +: (list 'a (2 3) "OK") +-> (a (2 3) "OK") +</code></pre> + +<dt><a name="lst/3"><code>lst/3</code></a> +<dd><a href="ref.html#pilog">Pilog</a> predicate that returns subsequent list +elements, after applying the <code><a href="refG.html#get">get</a></code> +algorithm to that object and the following arguments. Often used in database +queries. See also <code><a href="refM.html#map/3">map/3</a></code>. + +<pre><code> +: (? (db nr +Ord 1 @Ord) (lst @Pos @Ord pos)) + @Ord={3-7} @Pos={4-1} + @Ord={3-7} @Pos={4-2} + @Ord={3-7} @Pos={4-3} +-> NIL +</code></pre> + +<dt><a name="lst?"><code>(lst? 'any) -> flg</code></a> +<dd>Returns <code>T</code> when the argument <code>any</code> is a (possibly +empty) list (<code>NIL</code> or a cons pair cell). See also <code><a +href="refP.html#pair">pair</a></code>. + +<pre><code> +: (lst? NIL) +-> T +: (lst? (1 . 2)) +-> T +: (lst? (1 2 3)) +-> T +</code></pre> + +<dt><a name="listen"><code>(listen 'cnt1 ['cnt2]) -> cnt | NIL</code></a> +<dd>Listens at a socket descriptor <code>cnt1</code> (as received by <code><a +href="refP.html#port">port</a></code>) for an incoming connection, and returns +the new socket descriptor <code>cnt</code>. While waiting for a connection, a +<code>select</code> system call is executed for all file descriptors and timers +in the <code>VAL</code> of the global variable <code><a +href="refR.html#*Run">*Run</a></code>. If <code>cnt2</code> is +non-<code>NIL</code>, that amount of milliseconds is waited maximally, and +<code>NIL</code> is returned upon timeout. The global variable <code>*Adr</code> +is set to the IP address of the client. See also <code><a +href="refA.html#accept">accept</a></code>, <code><a +href="refC.html#connect">connect</a></code>, <code><a +href="refA.html#*Adr">*Adr</a></code>. + +<pre><code> +: (setq *Socket + (listen (port 6789) 60000) ) # Listen at port 6789 for max 60 seconds +-> 4 +: *Adr +-> "127.0.0.1" +</code></pre> + +<dt><a name="lit"><code>(lit 'any) -> any</code></a> +<dd>Returns the literal (i.e. quoted) value of <code>any</code>, by +<code>cons</code>ing it with the <code><a +href="refQ.html#quote">quote</a></code> function if necessary. + +<pre><code> +: (lit T) +-> T +: (lit 1) +-> 1 +: (lit '(1)) +-> (1) +: (lit '(a)) +-> '(a) +</code></pre> + +<dt><a name="load"><code>(load 'any ..) -> any</code></a> +<dd>Loads all <code>any</code> 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 <code><a href="refI.html#in">in</a></code>, 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 <code>any</code> is <code>T</code>, all remaining command +line arguments are loaded recursively. When <code>any</code> is +<code>NIL</code>, standard input is read, a prompt is issued before each read +operation, the results are printed to standard output (read-eval-print loop), +and <code>load</code> terminates when an empty line is entered. In any case, +<code>load</code> terminates upon end of file, or when <code>NIL</code> is read. +The index for transient symbols is cleared before and after the load, so that +all transient symbols in the file have a local scope. Returns the value of the +last evaluated expression. See also <code><a +href="refS.html#script">script</a></code>, <code><a +href="refI.html#ipid">ipid</a></code>, <code><a +href="refC.html#call">call</a></code>, <code><a +href="refF.html#file">file</a></code>, <code><a +href="refI.html#in">in</a></code>, <code><a href="refO.html#out">out</a></code> +and <code><a href="refS.html#str">str</a></code>. + +<pre><code> +: (load "lib.l" "-* 1 2 3") +-> 6 +</code></pre> + +<dt><a name="loc"><code>(loc 'sym 'lst) -> sym</code></a> +<dd>Locates in <code>lst</code> a <code><a +href="ref.html#transient">transient</a></code> symbol with the same name as +<code>sym</code>. Allows to get hold of otherwise inaccessible symbols. See also +<code><a href="ref_.html#====">====</a></code>. + +<pre><code> +: (loc "X" curry) +-> "X" +: (== @ "X") +-> NIL +</code></pre> + +<dt><a name="locale"><code>(locale 'sym1 'sym2 ['sym3])</code></a> +<dd>Sets the current locale to that given by the country file <code>sym1</code> +and the language file <code>sym2</code> (both located in the "loc/" directory), +and an optional application-specific directory <code>sym3</code>. The locale +influences the language, and numerical, date and other formats. See also +<code><a href="refU.html#*Uni">*Uni</a></code>, <code><a +href="refD.html#datStr">datStr</a></code>, <code><a +href="refS.html#strDat">strDat</a></code>, <code><a +href="refE.html#expDat">expDat</a></code>, <code><a +href="refD.html#day">day</a></code>, <code><a +href="refT.html#telStr">telStr</a></code>, <code><a +href="refE.html#expTel">expTel</a></code> and and <code><a +href="refM.html#money">money</a></code>. + +<pre><code> +: (locale "DE" "de" "app/loc/") +-> "Zip" +: ,"Yes" +-> "Ja" +</code></pre> + +<dt><a name="lock"><code>(lock ['sym]) -> cnt | NIL</code></a> +<dd>Write-locks an external symbol <code>sym</code> (file record locking), or +the whole database root file if <code>sym</code> is <code>NIL</code>. Returns +<code>NIL</code> if successful, or the ID of the process currently holding the +lock. When <code>sym</code> is non-<code>NIL</code>, the lock is released at the +next top level call to <code><a href="refC.html#commit">commit</a></code> or +<code><a href="refR.html#rollback">rollback</a></code>, otherwise only when +another database is opened with <code><a href="refP.html#pool">pool</a></code>, +or when the process terminates. See also <code><a +href="refS.html#*Solo">*Solo</a></code>. + +<pre><code> +: (lock '{1}) # Lock single object +-> NIL +: (lock) # Lock whole database +-> NIL +</code></pre> + +<dt><a name="loop"><code>(loop ['any | (NIL 'any . prg) | (T 'any . prg) ..]) -> any</code></a> +<dd>Endless loop with multiple conditional exits: The body is executed an +unlimited number of times. If a clause has <code>NIL</code> or <code>T</code> as +its CAR, the clause's second element is evaluated as a condition and - if the +result is <code>NIL</code> or non-<code>NIL</code>, respectively - the +<code>prg</code> is executed and the result returned. See also <code><a +href="refD.html#do">do</a></code> and <code><a +href="refF.html#for">for</a></code>. + +<pre><code> +: (let N 3 + (loop + (prinl N) + (T (=0 (dec 'N)) 'done) ) ) +3 +2 +1 +-> done +</code></pre> + +<dt><a name="low?"><code>(low? 'any) -> sym | NIL</code></a> +<dd>Returns <code>any</code> when the argument is a string (symbol) that starts +with a lowercase character. See also <code><a +href="refL.html#lowc">lowc</a></code>. + +<pre><code> +: (low? "a") +-> "a" +: (low? "A") +-> NIL +: (low? 123) +-> NIL +: (low? ".") +-> NIL +</code></pre> + +<dt><a name="lowc"><code>(lowc 'any) -> any</code></a> +<dd>Lower case conversion: If <code>any</code> is not a symbol, it is returned +as it is. Otherwise, a new transient symbol with all characters of +<code>any</code>, converted to lower case, is returned. See also <code><a +href="refU.html#uppc">uppc</a></code>, <code><a +href="refF.html#fold">fold</a></code> and <code><a +href="refL.html#low?">low?</a></code>. + +<pre><code> +: (lowc 123) +-> 123 +: (lowc "ABC") +-> "abc" +</code></pre> + +<dt><a name="lt0"><code>(lt0 'any) -> num | NIL</code></a> +<dd>Returns <code>num</code> when the argument is a number and less than zero, +otherwise <code>NIL</code>. See also <code><a +href="refG.html#ge0">ge0</a></code>, <code><a +href="refG.html#gt0">gt0</a></code>, <code><a href="ref_.html#=0">=0</a></code> +and <code><a href="refN.html#n0">n0</a></code>. + +<pre><code> +: (lt0 -2) +-> -2 +: (lt0 3) +-> NIL +</code></pre> + +<dt><a name="lup"><code>(lup 'lst 'any) -> lst</code></a> +<dt><code>(lup 'lst 'any 'any2) -> lst</code> +<dd>Looks up <code>any</code> in the CAR-elements of cells stored in the index +tree <code>lst</code>, as built-up by <code><a +href="refI.html#idx">idx</a></code>. In the first form, the first found cell is +returned, in the second form a list of all cells whose CAR is in the range +<code>any</code> .. <code>any2</code>. See also <code><a +href="refA.html#assoc">assoc</a></code>. + +<pre><code> +: (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)) +</code></pre> + +</dl> + +</body> +</html> diff --git a/doc/refM.html b/doc/refM.html @@ -0,0 +1,621 @@ +<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.0 Transitional//EN" "http://www.w3.org/TR/1998/REC-html40-19980424/loose.dtd"> +<html lang="en"> +<head> +<meta http-equiv="Content-Type" content="text/html; charset=utf-8"> +<title>M</title> +<link rel="stylesheet" href="doc.css" type="text/css"> +</head> +<body> + +<h1>M</h1> + +<dl> + +<dt><a name="*Msg"><code>*Msg</code></a> +<dd>A global variable holding the last recently issued error message. See also +<code><a href="ref.html#errors">Error Handling</a></code>, <code><a +href="refE.html#*Err">*Err</a></code> and <code><a +href="ref_.html#^">^</a></code>. + +<pre><code> +: (+ 'A 2) +!? (+ 'A 2) +A -- Number expected +? +: +: *Msg +-> "Number expected" +</code></pre> + +<dt><a name="+Mis"><code>+Mis</code></a> +<dd>Prefix class to explicitly specify validation functions for <code><a +href="refR.html#+relation">+relation</a></code>s. Expects a function that takes +a value and an entity object, and returns <code>NIL</code> if everything is +correct, or an error string. See also <code><a +href="ref.html#dbase">Database</a></code>. + +<pre><code> +(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) ) +</code></pre> + +<dt><a name="macro"><code>(macro prg) -> any</code></a> +<dd>Substitues all <code><a href="refP.html#pat?">pat?</a></code> symbols in +<code>prg</code> (using <code><a href="refF.html#fill">fill</a></code>), and +executes the result with <code><a href="refR.html#run">run</a></code>. Used +occasionally to call functions which otherwise do not evaluate their arguments. + +<pre><code> +: (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 +... +</code></pre> + +<dt><a name="made"><code>(made ['lst1 ['lst2]]) -> lst</code></a> +<dd>Initializes a new list value for the current <code><a +href="refM.html#make">make</a></code> environment. All list elements already +produced with <code><a href="refC.html#chain">chain</a></code> and <code><a +href="refL.html#link">link</a></code> are discarded, and <code>lst1</code> is +used instead. Optionally, <code>lst2</code> can be specified as the new linkage +cell, otherwise the last cell of <code>lst1</code> is used. When called without +arguments, <code>made</code> does not modify the environment. In any case, the +current list is returned. + +<pre><code> +: (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) +</code></pre> + +<dt><a name="mail"><code>(mail 'any 'cnt 'sym1 'sym2|lst1 'sym3 'lst2 . prg)'</code></a> +<dd>Sends an eMail via SMTP to a mail server at host <code>any</code>, port +<code>cnt</code>. <code>sym1</code> should be the "from" address, +<code>sym2|lst1</code> the "to" address(es), and <code>sym3</code> the subject. +<code>lst2</code> is a list of attachments, each one specified by three elements +for path, name and mime type. <code>prg</code> generates the mail body with +<code><a href="refP.html#prEval">prEval</a></code>. See also <code><a +href="refC.html#connect">connect</a></code>. + +<pre><code> +(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 +</code></pre> + +<dt><a name="make"><code>(make .. [(made 'lst ..)] .. [(link 'any ..)] ..) -> any</code></a> +<dd>Initializes and executes a list-building process with the <code><a +href="refM.html#made">made</a></code>, <code><a +href="refC.html#chain">chain</a></code>, <code><a +href="refL.html#link">link</a></code> and <code><a +href="refY.html#yoke">yoke</a></code> functions, and returns the result list. +For efficiency, pointers to the head and the tail of the list are maintained +internally. + +<pre><code> +: (make (link 1) (link 2 3) (link 4)) +-> (1 2 3 4) +: (make (made (1 2 3)) (link 4)) +-> (1 2 3 4) +</code></pre> + +<dt><a name="map"><code>(map 'fun 'lst ..) -> lst</code></a> +<dd>Applies <code>fun</code> to <code>lst</code> and all successive CDRs. When +additional <code>lst</code> arguments are given, they are passed to +<code>fun</code> in the same way. Returns the result of the last application. +See also <code><a href="refM.html#mapc">mapc</a></code>, <code><a +href="refM.html#maplist">maplist</a></code>, <code><a +href="refM.html#mapcar">mapcar</a></code>, <code><a +href="refM.html#mapcon">mapcon</a></code>, <code><a +href="refM.html#mapcan">mapcan</a></code> and <code><a +href="refF.html#filter">filter</a></code>. + +<pre><code> +: (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 +</code></pre> + +<dt><a name="map/3"><code>map/3</code></a> +<dd><a href="ref.html#pilog">Pilog</a> predicate that returns a list and +subsequent CDRs of that list, after applying the <code><a +href="refG.html#get">get</a></code> algorithm to that object and the following +arguments. Often used in database queries. See also <code><a +href="refL.html#lst/3">lst/3</a></code>. + +<pre><code> +: (? (db nr +Ord 1 @Ord) (map @L @Ord pos)) + @Ord={3-7} @L=({4-1} {4-2} {4-3}) + @Ord={3-7} @L=({4-2} {4-3}) + @Ord={3-7} @L=({4-3}) +-> NIL +</code></pre> + +<dt><a name="mapc"><code>(mapc 'fun 'lst ..) -> any</code></a> +<dd>Applies <code>fun</code> to each element of <code>lst</code>. When +additional <code>lst</code> arguments are given, their elements are also passed +to <code>fun</code>. Returns the result of the last application. See also +<code><a href="refM.html#map">map</a></code>, <code><a +href="refM.html#maplist">maplist</a></code>, <code><a +href="refM.html#mapcar">mapcar</a></code>, <code><a +href="refM.html#mapcon">mapcon</a></code>, <code><a +href="refM.html#mapcan">mapcan</a></code> and <code><a +href="refF.html#filter">filter</a></code>. + +<pre><code> +: (mapc println (1 2 3 4) '(A B C)) +1 A +2 B +3 C +4 NIL +-> NIL +</code></pre> + +<dt><a name="mapcan"><code>(mapcan 'fun 'lst ..) -> lst</code></a> +<dd>Applies <code>fun</code> to each element of <code>lst</code>. When +additional <code>lst</code> arguments are given, their elements are also passed +to <code>fun</code>. Returns a (destructively) concatenated list of all results. +See also <code><a href="refM.html#map">map</a></code>, <code><a +href="refM.html#mapc">mapc</a></code>, <code><a +href="refM.html#maplist">maplist</a></code>, <code><a +href="refM.html#mapcar">mapcar</a></code>, <code><a +href="refM.html#mapcon">mapcon</a></code>, <code><a +href="refF.html#filter">filter</a></code>. + +<pre><code> +: (mapcan reverse '((a b c) (d e f) (g h i))) +-> (c b a f e d i h g) +</code></pre> + +<dt><a name="mapcar"><code>(mapcar 'fun 'lst ..) -> lst</code></a> +<dd>Applies <code>fun</code> to each element of <code>lst</code>. When +additional <code>lst</code> arguments are given, their elements are also passed +to <code>fun</code>. Returns a list of all results. See also <code><a +href="refM.html#map">map</a></code>, <code><a +href="refM.html#mapc">mapc</a></code>, <code><a +href="refM.html#maplist">maplist</a></code>, <code><a +href="refM.html#mapcon">mapcon</a></code>, <code><a +href="refM.html#mapcan">mapcan</a></code> and <code><a +href="refF.html#filter">filter</a></code>. + +<pre><code> +: (mapcar + (1 2 3) (4 5 6)) +-> (5 7 9) +: (mapcar '((X Y) (+ X (* Y Y))) (1 2 3 4) (5 6 7 8)) +-> (26 38 52 68) +</code></pre> + +<dt><a name="mapcon"><code>(mapcon 'fun 'lst ..) -> lst</code></a> +<dd>Applies <code>fun</code> to <code>lst</code> and all successive CDRs. When +additional <code>lst</code> arguments are given, they are passed to +<code>fun</code> in the same way. Returns a (destructively) concatenated list of +all results. See also <code><a href="refM.html#map">map</a></code>, <code><a +href="refM.html#mapc">mapc</a></code>, <code><a +href="refM.html#maplist">maplist</a></code>, <code><a +href="refM.html#mapcar">mapcar</a></code>, <code><a +href="refM.html#mapcan">mapcan</a></code> and <code><a +href="refF.html#filter">filter</a></code>. + +<pre><code> +: (mapcon copy '(1 2 3 4 5)) +-> (1 2 3 4 5 2 3 4 5 3 4 5 4 5 5) +</code></pre> + +<dt><a name="maplist"><code>(maplist 'fun 'lst ..) -> lst</code></a> +<dd>Applies <code>fun</code> to <code>lst</code> and all successive CDRs. When +additional <code>lst</code> arguments are given, they are passed to +<code>fun</code> in the same way. Returns a list of all results. See also +<code><a href="refM.html#map">map</a></code>, <code><a +href="refM.html#mapc">mapc</a></code>, <code><a +href="refM.html#mapcar">mapcar</a></code>, <code><a +href="refM.html#mapcon">mapcon</a></code>, <code><a +href="refM.html#mapcan">mapcan</a></code> and <code><a +href="refF.html#filter">filter</a></code>. + +<pre><code> +: (maplist cons (1 2 3) '(A B C)) +-> (((1 2 3) A B C) ((2 3) B C) ((3) C)) +</code></pre> + +<dt><a name="maps"><code>(maps 'fun 'sym ['lst ..]) -> any</code></a> +<dd>Applies <code>fun</code> to all properties of <code>sym</code>. When +additional <code>lst</code> arguments are given, their elements are also passed +to <code>fun</code>. Returns the result of the last application. See also +<code><a href="refP.html#putl">putl</a></code> and <code><a +href="refG.html#getl">getl</a></code>. + +<pre><code> +: (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 +</code></pre> + +<dt><a name="mark"><code>(mark 'sym|0 ['NIL | 'T | '0]) -> flg</code></a> +<dd>Tests, sets or resets a mark for <code>sym</code> in the database (for a +second argument of <code>NIL</code>, <code>T</code> or <code>0</code>, +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. + +<pre><code> +: (pool "db") +-> T +: (mark '{1} T) # Mark +-> NIL +: (mark '{1}) # Test +-> T # -> marked +: (mark '{1} 0) # Unmark +-> T +: (mark '{1}) # Test +-> NIL # -> unmarked +</code></pre> + +<dt><a name="match"><code>(match 'lst1 'lst2) -> flg</code></a> +<dd>Takes <code>lst1</code> as a pattern to be matched against +<code>lst2</code>, and returns <code>T</code> when successful. Atoms must be +equal, and sublists must match recursively. Symbols in the pattern list with +names starting with an at-mark "<code>@</code>" (see <code><a +href="refP.html#pat?">pat?</a></code>) are taken as wildcards. They can match +zero, one or more elements, and are bound to the corresponding data. See also +<code><a href="refC.html#chop">chop</a></code>, <code><a +href="refS.html#split">split</a></code> and <code><a +href="refF.html#fill">fill</a></code>. + +<pre><code> +: (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) +</code></pre> + +<dt><a name="max"><code>(max 'any ..) -> any</code></a> +<dd>Returns the largest of all <code>any</code> arguments. See also <a +href="refM.html#min">min</a> and <a href="ref.html#cmp">Comparing</a>. + +<pre><code> +: (max 2 'a 'z 9) +-> z +: (max (5) (2 3) 'X) +-> (5) +</code></pre> + +<dt><a name="maxKey"><code>(maxKey 'tree ['any1 ['any2]]) -> any</code></a> +<dd>Returns the largest key in a database tree. If a minimal key +<code>any1</code> and/or a maximal key <code>any2</code> is given, the largest +key from that range is returned. See also <code><a +href="refT.html#tree">tree</a></code>, <code><a +href="refL.html#leaf">leaf</a></code>, <code><a +href="refM.html#minKey">minKey</a></code> and <code><a +href="refG.html#genKey">genKey</a></code>. + +<pre><code> +: (maxKey (tree 'nr '+Item)) +-> 7 +: (maxKey (tree 'nr '+Item) 3 5) +-> 5 +</code></pre> + +<dt><a name="maxi"><code>(maxi 'fun 'lst ..) -> any</code></a> +<dd>Applies <code>fun</code> to each element of <code>lst</code>. When +additional <code>lst</code> arguments are given, their elements are also passed +to <code>fun</code>. Returns that element from <code>lst</code> for that +<code>fun</code> returned a maximal value. See also <code><a +href="refM.html#mini">mini</a></code> and <code><a +href="refS.html#sort">sort</a></code>. + +<pre><code> +: (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 @)) ) + (what) ) +-> *History +</code></pre> + +<dt><a name="member"><code>(member 'any 'lst) -> any</code></a> +<dd>Returns the tail of <code>lst</code> that starts with <code>any</code> when +<code>any</code> is a member of <code>lst</code>, otherwise <code>NIL</code>. +See also <code><a href="refM.html#memq">memq</a></code>, <code><a +href="refA.html#assoc">assoc</a></code> and <code><a +href="refI.html#idx">idx</a></code>. + +<pre><code> +: (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)) +</code></pre> + +<dt><a name="member/2"><code>member/2</code></a> +<dd><a href="ref.html#pilog">Pilog</a> predicate that succeeds if the the first +argument is a member of the list in the second argument. See also <code><a +href="refE.html#equal/2">equal/2</a></code> and <code><a +href="refM.html#member">member</a></code>. + +<pre><code> +: (? (member @X (a b c))) + @X=a + @X=b + @X=c +-> NIL +</code></pre> + +<dt><a name="memq"><code>(memq 'any 'lst) -> any</code></a> +<dd>Returns the tail of <code>lst</code> that starts with <code>any</code> when +<code>any</code> is a member of <code>lst</code>, otherwise <code>NIL</code>. +<code><a href="ref_.html#==">==</a></code> is used for comparison (pointer +equality). See also <code><a href="refM.html#member">member</a></code>, <code><a +href="refM.html#mmeq">mmeq</a></code>, <code><a +href="refA.html#asoq">asoq</a></code>, <code><a +href="refD.html#delq">delq</a></code> and <a href="ref.html#cmp">Comparing</a>. + +<pre><code> +: (memq 'c '(a b c d e f)) +-> (c d e f) +: (memq (2) ((1) (2) (3))) +-> NIL +</code></pre> + +<dt><a name="meta"><code>(meta 'obj|typ 'sym ['sym2|cnt ..]) -> any</code></a> +<dd>Fetches a property value <code>any</code>, by searching the property lists +of the classes and superclasses of <code>obj</code>, or the classes in +<code>typ</code>, for the property key <code>sym</code>, and by applying the +<code><a href="refG.html#get">get</a></code> algorithm to the following optional +arguments. + +<pre><code> +: (setq A '(B)) # Be 'A' an object of class 'B' +-> (B) +: (put 'B 'a 123) +-> 123 +: (meta 'A 'a) # Fetch 'a' from 'B' +-> 123 +</code></pre> + +<dt><a name="meth"><code>(meth 'obj ..) -> any</code></a> +<dd>This function is usually not called directly, but is used by <code> <a +href="refD.html#dm">dm</a></code> as a template to initialize the +<code>VAL</code> of message symbols. It searches for itself in the methods of +<code>obj</code> and its classes and superclasses, and executes that method. An +error <code>"Bad message"</code> is issued if the search is unsuccessful. See +also <code><a href="ref.html#oop">OO Concepts</a></code>, <code><a +href="refM.html#method">method</a></code>, <code><a +href="refS.html#send">send</a></code> and <code><a +href="refT.html#try">try</a></code>. + +<pre><code> +: meth +-> 67283504 # Value of 'meth' +: stop> +-> 67283504 # Value of any message +</code></pre> + +<dt><a name="method"><code>(method 'msg 'obj) -> fun</code></a> +<dd>Returns the function body of the method that would be executed upon sending +the message <code>msg</code> to the object <code>obj</code>. If the message +cannot be located in <code>obj</code>, its classes and superclasses, +<code>NIL</code> is returned. See also <code><a +href="ref.html#oop">OO Concepts</a></code>, <code><a +href="refS.html#send">send</a></code>, <code><a +href="refT.html#try">try</a></code>, <code><a +href="refM.html#meth">meth</a></code>, <code><a +href="refS.html#super">super</a></code>, <code><a +href="refE.html#extra">extra</a></code>, <code><a +href="refC.html#class">class</a></code>. + +<pre><code> +: (method 'mis> '+Number) +-> ((Val Obj) (and Val (not (num? Val)) "Numeric input expected")) +</code></pre> + +<dt><a name="min"><code>(min 'any ..) -> any</code></a> +<dd>Returns the smallest of all <code>any</code> arguments. See also <a +href="refM.html#max">max</a> and <a href="ref.html#cmp">Comparing</a>. + +<pre><code> +: (min 2 'a 'z 9) +-> 2 +: (min (5) (2 3) 'X) +-> X +</code></pre> + +<dt><a name="minKey"><code>(minKey 'tree ['any1 ['any2]]) -> any</code></a> +<dd>Returns the smallest key in a database tree. If a minimal key +<code>any1</code> and/or a maximal key <code>any2</code> is given, the smallest +key from that range is returned. See also <code><a +href="refT.html#tree">tree</a></code>, <code><a +href="refL.html#leaf">leaf</a></code>, <code><a +href="refM.html#maxKey">maxKey</a></code> and <code><a +href="refG.html#genKey">genKey</a></code>. + +<pre><code> +: (minKey (tree 'nr '+Item)) +-> 1 +: (minKey (tree 'nr '+Item) 3 5) +-> 3 +</code></pre> + +<dt><a name="mini"><code>(mini 'fun 'lst ..) -> any</code></a> +<dd>Applies <code>fun</code> to each element of <code>lst</code>. When +additional <code>lst</code> arguments are given, their elements are also passed +to <code>fun</code>. Returns that element from <code>lst</code> for that +<code>fun</code> returned a minimal value. See also <code><a +href="refM.html#maxi">maxi</a></code> and <code><a +href="refS.html#sort">sort</a></code>. + +<pre><code> +: (setq A 1 B 2 C 3) +-> 3 +: (mini val '(A B C)) +-> A +</code></pre> + +<dt><a name="mix"><code>(mix 'lst cnt|'any ..) -> lst</code></a> +<dd>Builds a list from the elements of the argument <code>lst</code>, as +specified by the following <code>cnt|'any</code> arguments. If such an argument +is a number, the <code>cnt</code>'th element from <code>lst</code> is taken, +otherwise that argument is evaluated and the result is used. + +<pre><code> +: (mix '(a b c d) 3 4 1 2) +-> (c d a b) +: (mix '(a b c d) 1 'A 4 'D) +-> (a A d D) +</code></pre> + +<dt><a name="mmeq"><code>(mmeq 'lst 'lst) -> any</code></a> +<dd>Returns the tail of the second argument <code>lst</code> that starts with a +member of the first argument <code>lst</code>, otherwise <code>NIL</code>. +<code><a href="ref_.html#==">==</a></code> is used for comparison (pointer +equality). See also <code><a href="refM.html#member">member</a></code>, <code><a +href="refM.html#memq">memq</a></code>, <code><a +href="refA.html#asoq">asoq</a></code> and <code><a +href="refD.html#delq">delq</a></code>. + +<pre><code> +: (mmeq '(a b c) '(d e f)) +-> NIL +: (mmeq '(a b c) '(d b x)) +-> (b x) +</code></pre> + +<dt><a name="money"><code>(money 'num ['sym]) -> sym</code></a> +<dd>Formats a number <code>num</code> into a digit string with two decimal +places, according to the current <code><a +href="refL.html#locale">locale</a></code>. If an additional currency name is +given, it is appended (separated by a space). See also <code><a +href="refT.html#telStr">telStr</a></code>, <code><a +href="refD.html#datStr">datStr</a></code> and <code><a +href="refF.html#format">format</a></code>. + +<pre><code> +: (money 123456789) +-> "1,234,567.89" +: (money 12345 "EUR") +-> "123.45 EUR" +: (locale "DE" "de") +-> NIL +: (money 123456789 "EUR") +-> "1.234.567,89 EUR" +</code></pre> + +<dt><a name="more"><code>(more 'lst ['fun]) -> flg</code></a> +<dt><code>(more 'cls) -> any</code> +<dd>Displays the elements of <code>lst</code> (first form), or the type and +methods of <code>cls</code> (second form). <code>fun</code> defaults to <code><a +href="refP.html#print">print</a></code>. In the second form, the method +definitions of <code>cls</code> are pretty-printed with <code><a +href="refP.html#pp">pp</a></code>. After each step, <code>more</code> waits for +console input, and terminates when a non-empty line is entered. In that case, +<code>T</code> is returned, otherwise (when end of data is reached) +<code>NIL</code>. See also <code><a href="refQ.html#query">query</a></code> and +<code><a href="refS.html#show">show</a></code>. + +<pre><code> +: (more (all)) # Display all internal symbols +inc> +leaf +nil +inc! +accept. # Stop +-> T + +: (more (all) show) # 'show' all internal symbols +inc> 67292896 + *Dbg ((859 . "lib/db.l")) + +leaf ((Tree) (let (Node (cdr (root Tree)) X) (while (val Node) (setq X (cadr @) Node (car @))) (cddr X))) + *Dbg ((173 . "lib/btree.l")) + +nil 67284680 + T (((@X) (@ not (-> @X)))) +. # Stop +-> T + +: (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 (cdr Lst)) ) + +-> NIL +</code></pre> + +<dt><a name="msg"><code>(msg 'any ['any ..]) -> any</code></a> +<dd>Prints <code>any</code> with <code><a +href="refP.html#print">print</a></code>, followed by all <code>any</code> +arguments (printed with <code><a href="refP.html#prin">prin</a></code>) and a +newline, to standard error. The first <code>any</code> argument is returned. + +<pre><code> +: (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) +</code></pre> + +</dl> + +</body> +</html> diff --git a/doc/refN.html b/doc/refN.html @@ -0,0 +1,399 @@ +<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.0 Transitional//EN" "http://www.w3.org/TR/1998/REC-html40-19980424/loose.dtd"> +<html lang="en"> +<head> +<meta http-equiv="Content-Type" content="text/html; charset=utf-8"> +<title>N</title> +<link rel="stylesheet" href="doc.css" type="text/css"> +</head> +<body> + +<h1>N</h1> + +<dl> + +<dt><a name="+Need"><code>+Need</code></a> +<dd>Prefix class for mandatory <code><a +href="refR.html#+relation">+relation</a></code>s. Note that this does not +enforce any requirements by itself, it only returns an error message if the +<code>mis&gt;</code> message is explicitly called, e.g. by GUI functions. See +also <code><a href="ref.html#dbase">Database</a></code>. + +<pre><code> +(rel nr (+Need +Key +Number)) # Item number is mandatory +</code></pre> + +<dt><a name="+Number"><code>+Number</code></a> +<dd>Class for numeric relations, a subclass of <code><a +href="refR.html#+relation">+relation</a></code>. Accepts an optional argument +for the fixpoint scale (currently not used). See also <code><a +href="ref.html#dbase">Database</a></code>. + +<pre><code> +(rel pr (+Number) 2) # Price, with two decimal places +</code></pre> + +<dt><a name="n=="><code>(n== 'any ..) -> flg</code></a> +<dd>Returns <code>T</code> when not all <code>any</code> arguments are the same +(pointer equality). <code>(n== 'any ..)</code> is equivalent to <code>(not (== +'any ..))</code>. See also <code><a href="ref_.html#==">==</a></code> and <a +href="ref.html#cmp">Comparing</a>. + +<pre><code> +: (n== 'a 'a) +-> NIL +: (n== (1) (1)) +-> T +</code></pre> + +<dt><a name="n0"><code>(n0 'any) -> flg</code></a> +<dd>Returns <code>T</code> when <code>any</code> is not a number with value +zero. See also <code><a href="ref_.html#=0">=0</a></code>, <code><a +href="refL.html#lt0">lt0</a></code>, <code><a +href="refG.html#ge0">ge0</a></code> and <code><a +href="refG.html#gt0">gt0</a></code>. + +<pre><code> +: (n0 (- 6 3 2 1)) +-> NIL +: (n0 'a) +-> T +</code></pre> + +<dt><a name="nT"><code>(nT 'any) -> flg</code></a> +<dd>Returns <code>T</code> when <code>any</code> is not the symbol +<code>T</code>. See also <a href="ref_.html#=T">=T</a>. + +<pre><code> +: (nT 0) +-> T +: (nT "T") +-> T +: (nT T) +-> NIL +</code></pre> + +<dt><a name="name"><code>(name 'sym ['sym2]) -> sym</code></a> +<dd>Returns, if <code>sym2</code> is not given, a new transient symbol with the +name of <code>sym</code>. Otherwise <code>sym</code> must be a transient symbol, +and its name is changed to that of <code>sym2</code>. See also <code><a +href="refS.html#str">str</a></code>, <code><a +href="refS.html#sym">sym</a></code>, <code><a +href="refZ.html#zap">zap</a></code> and <code><a +href="refI.html#intern">intern</a></code>. + +<pre><code> +: (name 'abc) +-> "abc" +: (name "abc") +-> "abc" +: (name '{abc}) +-> "abc" +: (name (new)) +-> NIL +: (de foo (Lst) (car Lst)) # 'foo' calls 'car' +-> foo +: (intern (name (zap 'car) "xxx")) # Globally change the name of 'car' +-> xxx +: (xxx (1 2 3)) +-> 1 +: (pp 'foo) +(de foo (Lst) + (xxx Lst) ) # Name changed +-> 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 +? +</code></pre> + +<dt><a name="nand"><code>(nand 'any ..) -> flg</code></a> +<dd>Logical NAND. The expressions <code>any</code> are evaluated from left to +right. If <code>NIL</code> is encountered, <code>T</code> is returned +immediately. Else <code>NIL</code> is returned. <code>(nand ..)</code> is +equivalent to <code>(not (and ..))</code>. + +<pre><code> +: (nand (lt0 7) (read)) +-> T +: (nand (lt0 -7) (read)) +abc +-> NIL +: (nand (lt0 -7) (read)) +NIL +-> T +</code></pre> + +<dt><a name="native"><code>(native 'cnt1|sym1 'cnt2|sym2 'sym|lst 'any ..) -> any</code></a> +<dd>(64-bit version only) Calls a native C function. The first argument should +specify a shared object library, either <code>"@"</code> (the current main +program), <code>sym1</code> (a library path name), or <code>cnt1</code> (a +library handle obtained by a previous call). The second argument should be a +symbol name <code>sym2</code>, or a function pointer <code>cnt2</code> 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 pointer +assigned as values to be cached and used in subsequent calls. The third +<code>sym|lst</code> argument is a return value specification, while all +following arguments are the arguments to the native function. + +<p>The return value specification may either be one of the symbols + +<pre><code> + NIL void + B byte # Byte (unsigned) + C char # Character (UTF-8, 1-3 bytes) + I int # Integer (32 bit) + N long # Long or pointer (64 bit) + S string # String (UTF-8) +</code></pre> + +<p>or nested lists of these symbols with size specifications to denote arrays +and structures, e.g. + +<pre><code> + (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)) +</code></pre> + +<p>Arguments can be numbers (passed as 64-bit integers), symbols (passed as +strings), or a list with a variable in the CAR (to recieve the returned +structure data, ignored when the CAR is <code>NIL</code>), a cons pair for the +size- and value-specification in the CADR, and an optional sequence of +initialization bytes in the CDDR. + +<pre><code> +: (native "@" "getenv" 'S "TERM") # Same as (sys "TERM") +-> "xterm" + +: (native "@" "printf" 'I "abc%d%s^J" (+ 3 4) (pack "X" "Y" "Z")) +abc7XYZ +-> 8 + +: (use Tim + (native "@" "time" NIL '(Tim (8 B . 8))) # time_t 8 # Get time_t structure + (native "@" "localtime" '(I . 9) (cons NIL (8) Tim)) ) # Read local time +-> (32 18 13 31 11 109 4 364 0) # 13:18:32, Dec. 31st, 2009 +</code></pre> + +<p>The C function may in turn call a function + +<pre><code> + long lisp(char*, long, long, long, long, long); +</code></pre> + +<p>which accepts a symbol name as the first argument, and up to 5 numbers. +<code>lisp()</code> calls that symbol with the five numbers, and expects a +numeric return value. All numbers in this context should not be larger than 60 +bits (signed). + +<dt><a name="need"><code>(need 'cnt ['lst ['any]]) -> lst</code></a> +<dd>Produces a list of at least <code>cnt</code> elements. When called without +optional arguments, a list of <code>cnt</code> <code>NIL</code>'s is returned. +When <code>lst</code> is given, it is extended to the left (if <code>cnt</code> +is positive) or (destructively) to the right (if <code>cnt</code> is negative) +with <code>any</code> elements. See also <code><a +href="refR.html#range">range</a></code>. + +<pre><code> +: (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) +</code></pre> + +<dt><a name="new"><code>(new ['flg|num] ['typ ['any ..]]) -> obj</code></a> +<dd>Creates and returns a new object. If <code>flg</code> is given and +non-<code>NIL</code>, the new object will be an external symbol (created in +database file 1 if <code>T</code>, or in the corresponding database file if +<code>num</code> is given). <code>typ</code> (typically a list of classes) is +assigned to the <code>VAL</code>, and the initial <code>T</code> message is sent +with the arguments <code>any</code> to the new object. If no <code>T</code> +message is defined for the classes in <code>typ</code> or their superclasses, +the <code>any</code> arguments should evaluate to alternating keys and values +for the initialization of the new object. See also <code><a +href="refB.html#box">box</a></code>, <code><a +href="refO.html#object">object</a></code>, <code><a +href="refC.html#class">class</a></code>, <code><a +href="refT.html#type">type</a></code>, <code><a +href="refI.html#isa">isa</a></code>, <code><a +href="refS.html#send">send</a></code> and <code><a +href="ref.html#dbase">Database</a></code>. + +<pre><code> +: (new) +-> $134426427 +: (new T '(+Address)) +-> {1A;3} +</code></pre> + +<dt><a name="new!"><code>(new! 'typ ['any ..]) -> obj</code></a> +<dd><a href="ref.html#trans">Transaction</a> wrapper function for <code><a +href="refN.html#new">new</a></code>. <code>(new! '(+Cls) 'key 'val ...)</code> +is equivalent to <code>(dbSync) (new (db: +Cls) 'key 'val ...) (commit +'upd)</code>. See also <code><a href="refS.html#set!">set!</a></code>, <code><a +href="refP.html#put!">put!</a></code> and <code><a +href="refI.html#inc!">inc!</a></code>. + +<pre><code> +: (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 +</code></pre> + +<dt><a name="next"><code>(next) -> any</code></a> +<dd>Can only be used inside functions with a variable number of arguments (with +<code>@</code>). Returns the next argument from the internal list. See also +<code><a href="refA.html#args">args</a></code>, <code><a +href="refA.html#arg">arg</a></code>, <code><a +href="refR.html#rest">rest</a></code>, and <code><a +href="refP.html#pass">pass</a></code>. + +<pre><code> +: (de foo @ (println (next))) # Print next argument +-> foo +: (foo) +NIL +-> NIL +: (foo 123) +123 +-> 123 +</code></pre> + +<dt><a name="nil"><code>(nil . prg) -> NIL</code></a> +<dd>Executes <code>prg</code>, and returns <code>NIL</code>. See also <code><a +href="refT.html#t">t</a></code>, <code><a href="refP.html#prog">prog</a></code>, +<code><a href="refP.html#prog1">prog1</a></code> and <code><a +href="refP.html#prog2">prog2</a></code>. + +<pre><code> +: (nil (println 'OK)) +OK +-> NIL +</code></pre> + +<dt><a name="nil/1"><code>nil/1</code></a> +<dd><a href="ref.html#pilog">Pilog</a> predicate expects an argument variable, +and succeeds if that variable is bound to <code>NIL</code>. See also <code><a +href="refN.html#not/1">not/1</a></code>. + +<pre><code> +: (? @X NIL (nil @X)) + @X=NIL +-> NIL +</code></pre> + +<dt><a name="noLint"><code>(noLint 'sym)</code></a> +<dt><code>(noLint 'sym|(sym . cls) 'sym2)</code> +<dd>Excludes the check for a function definition of <code>sym</code> (in the +first form), or for variable binding and usage of <code>sym2</code> in the +function definition, file contents or method body of <code>sym</code> (second +form), during calls to <code><a href="refL.html#lint">lint</a></code>. See also +<code><a href="refL.html#lintAll">lintAll</a></code>. + +<pre><code> +: (de foo () + (bar FreeVariable) ) +-> foo +: (lint 'foo) +-> ((def bar) (bnd FreeVariable)) +: (noLint 'bar) +-> bar +: (noLint 'foo 'FreeVariable) +-> (foo . FreeVariable) +: (lint 'foo) +-> NIL +</code></pre> + +<dt><a name="nond"><code>(nond ('any1 . prg1) ('any2 . prg2) ..) -> any</code></a> +<dd>Negated ("non-cond") multi-way conditional: If any of the <code>anyN</code> +conditions evaluates to <code>NIL</code>, <code>prgN</code> is executed and the +result returned. Otherwise (all conditions evaluate to non-<code>NIL</code>), +<code>NIL</code> is returned. See also <code><a +href="refC.html#cond">cond</a></code>, <code><a +href="refI.html#ifn">ifn</a></code> and <code><a +href="refU.html#unless">unless</a></code>. + +<pre><code> +: (nond + ((= 3 3) (println 1)) + ((= 3 4) (println 2)) + (NIL (println 3)) ) +2 +-> 2 +</code></pre> + +<dt><a name="nor"><code>(nor 'any ..) -> flg</code></a> +<dd>Logical NOR. The expressions <code>any</code> are evaluated from left to +right. If a non-<code>NIL</code> value is encountered, <code>NIL</code> is +returned immediately. Else <code>T</code> is returned. <code>(nor ..)</code> is +equivalent to <code>(not (or ..))</code>. + +<pre><code> +: (nor (lt0 7) (= 3 4)) +-> T +</code></pre> + +<dt><a name="not"><code>(not 'any) -> flg</code></a> +<dd>Logical negation. Returns <code>T</code> if <code>any</code> evaluates to +<code>NIL</code>. + +<pre><code> +: (not (== 'a 'a)) +-> NIL +: (not (get 'a 'a)) +-> T +</code></pre> + +<dt><a name="not/1"><code>not/1</code></a> +<dd><a href="ref.html#pilog">Pilog</a> predicate that succeeds if and only if +the goal cannot be proven. See also <code><a +href="refN.html#nil/1">nil/1</a></code>, <code><a +href="refT.html#true/0">true/0</a></code> and <code><a +href="refF.html#fail/0">fail/0</a></code>. + +<pre><code> +: (? (equal 3 4)) +-> NIL +: (? (not (equal 3 4))) +-> T +</code></pre> + +<dt><a name="nth"><code>(nth 'lst 'cnt ..) -> lst</code></a> +<dd>Returns the tail of <code>lst</code> starting from the <code>cnt</code>'th +element of <code>lst</code>. Successive <code>cnt</code> arguments operate on +the results in the same way. <code>(nth 'lst 2)</code> is equivalent to +<code>(cdr 'lst)</code>. See also <code><a href="refG.html#get">get</a></code>. + +<pre><code> +: (nth '(a b c d) 2) +-> (b c d) +: (nth '(a (b c) d) 2 2) +-> (c) +: (cdadr '(a (b c) d)) +-> (c) +</code></pre> + +<dt><a name="num?"><code>(num? 'any) -> num | NIL</code></a> +<dd>Returns <code>any</code> when the argument <code>any</code> is a number, +otherwise <code>NIL</code>. + +<pre><code> +: (num? 123) +-> 123 +: (num? (1 2 3)) +-> NIL +</code></pre> + +</dl> + +</body> +</html> diff --git a/doc/refO.html b/doc/refO.html @@ -0,0 +1,262 @@ +<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.0 Transitional//EN" "http://www.w3.org/TR/1998/REC-html40-19980424/loose.dtd"> +<html lang="en"> +<head> +<meta http-equiv="Content-Type" content="text/html; charset=utf-8"> +<title>O</title> +<link rel="stylesheet" href="doc.css" type="text/css"> +</head> +<body> + +<h1>O</h1> + +<dl> + +<dt><a name="*Once"><code>*Once</code></a> +<dd>Holds an <code><a href="refI.html#idx">idx</a></code> tree of already +<code><a href="refL.html#load">load</a></code>ed source locations (as returned +by <code><a href="refF.html#file">file</a></code>) See also <code><a +href="refO.html#once">once</a></code>. + +<pre><code> +: *Once +-> (("lib/" "misc.l" . 11) (("lib/" "http.l" . 9) (("lib/" "form.l" . 11)))) +</code></pre> + +<dt><a name="*OS"><code>*OS</code></a> +<dd>A global constant holding the name of the operating system. Possible values +include <code>"Linux"</code>, <code>"FreeBSD"</code>, <code>"Darwin"</code> or +<code>"Cygwin"</code>. + +<pre><code> +: *OS +-> "Linux" +</code></pre> + +<dt><a name="obj"><code>(obj (typ var [hook] val ..) var2 val2 ..) -> obj</code></a> +<dd>Finds or creates a database object (using <code><a +href="refR.html#request">request</a></code>) corresponding to <code>(typ var +[hook] val ..)</code>, and initializes additional properties using the +<code>varN</code> and <code>valN</code> arguments. + +<pre><code> +: (obj ((+Item) nr 2) nm "Spare Part" sup `(db 'nr '+CuSu 2) inv 100 pr 1250) +-> {3-2} +</code></pre> + +<dt><a name="object"><code>(object 'sym 'any ['sym2 'any2 ..]) -> obj</code></a> +<dd>Defines <code>sym</code> to be an object with the value (or type) +<code>any</code>. The property list is initialized with all optionally supplied +key-value pairs. See also <code><a href="ref.html#oop">OO Concepts</a></code>, +<code><a href="refN.html#new">new</a></code>, <code><a +href="refT.html#type">type</a></code> and <code><a +href="refI.html#isa">isa</a></code>. + +<pre><code> +: (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 +</code></pre> + +<dt><a name="oct"><code>(oct 'num) -> sym</code></a> +<dt><code>(oct 'sym) -> num</code> +<dd>Converts a number <code>num</code> to an octal string, or an octal string +<code>sym</code> to a number. See also <code><a +href="refH.html#hex">hex</a></code> and <code><a +href="refF.html#format">format</a></code>. + +<pre><code> +: (oct 73) +-> "111" +: (oct "111") +-> 73 +</code></pre> + +<dt><a name="off"><code>(off var ..) -> NIL</code></a> +<dd>Stores <code>NIL</code> in all <code>var</code> arguments. See also <code><a +href="refO.html#on">on</a></code>, <code><a +href="refO.html#onOff">onOff</a></code>, <code><a +href="refZ.html#zero">zero</a></code> and <code><a +href="refO.html#one">one</a></code>. + +<pre><code> +: (off A B) +-> NIL +: A +-> NIL +: B +-> NIL +</code></pre> + +<dt><a name="offset"><code>(offset 'lst1 'lst2) -> cnt | NIL</code></a> +<dd>Returns the <code>cnt</code> position of the tail list <code>lst1</code> in +<code>lst2</code>, or <code>NIL</code> if it is not found. See also <code><a +href="refI.html#index">index</a></code>. + +<pre><code> +: (offset '(c d e f) '(a b c d e f)) +-> 3 +: (offset '(c d e) '(a b c d e f)) +-> NIL +</code></pre> + +<dt><a name="on"><code>(on var ..) -> T</code></a> +<dd>Stores <code>T</code> in all <code>var</code> arguments. See also <code><a +href="refO.html#off">off</a></code>, <code><a +href="refO.html#onOff">onOff</a></code>, <code><a +href="refZ.html#zero">zero</a></code> and <code><a +href="refO.html#one">one</a></code>. + +<pre><code> +: (on A B) +-> T +: A +-> T +: B +-> T +</code></pre> + +<dt><a name="once"><code>(once . prg) -> any</code></a> +<dd>Executes <code>prg</code> once, when the current file is <code><a +href="refL.html#load">load</a></code>ed the first time. Subsequent loads at a +later time will not execute <code>prg</code>, and <code>once</code> returns +<code>NIL</code>. See also <code><a href="refO.html#*Once">*Once</a></code>. + +<pre><code> +(once + (zero *Cnt1 *Cnt2) # Init counters + (load "file1.l" "file2.l") ) # Load other files +</code></pre> + +<dt><a name="one"><code>(one var ..) -> 1</code></a> +<dd>Stores <code>1</code> in all <code>var</code> arguments. See also <code><a +href="refZ.html#zero">zero</a></code>, <code><a +href="refO.html#on">on</a></code>, <code><a href="refO.html#off">off</a></code> +and <code><a href="refO.html#onOff">onOff</a></code>. + +<pre><code> +: (one A B) +-> 1 +: A +-> 1 +: B +-> 1 +</code></pre> + +<dt><a name="onOff"><code>(onOff var ..) -> flg</code></a> +<dd>Logically negates the values of all <code>var</code> arguments. Returns the +new value of the last symbol. See also <code><a +href="refO.html#on">on</a></code>, <code><a href="refO.html#off">off</a></code>, +<code><a href="refZ.html#zero">zero</a></code> and <code><a +href="refO.html#one">one</a></code>. + +<pre><code> +: (onOff A B) +-> T +: A +-> T +: B +-> T +: (onOff A B) +-> NIL +: A +-> NIL +: B +-> NIL +</code></pre> + +<dt><a name="open"><code>(open 'any) -> cnt | NIL</code></a> +<dd>Opens the file with the name <code>any</code> in read/write mode, and +returns a file descriptor <code>cnt</code> (or <code>NIL</code> on error). A +leading "<code>@</code>" character in <code>any</code> is substituted with the +<u>PicoLisp Home Directory</u>, as it was remembered during interpreter startup. +If the file does not exist, it is created. The file descriptor can be used in +subsequent calls to <code><a href="refI.html#in">in</a></code> and <code><a +href="refO.html#out">out</a></code>. See also <code><a +href="refC.html#close">close</a></code>. + +<pre><code> +: (open "x") +-> 3 +</code></pre> + +<dt><a name="opid"><code>(opid) -> pid | NIL</code></a> +<dd>Returns the corresponding process ID when the current output channel is +writing to a pipe, otherwise <code>NIL</code>. See also <code><a +href="refI.html#ipid">ipid</a></code> and <code><a +href="refO.html#out">out</a></code>. + +<pre><code> +: (out '(cat) (call 'ps "-p" (opid))) + PID TTY TIME CMD + 7127 pts/3 00:00:00 cat +-> T +</code></pre> + +<dt><a name="opt"><code>(opt) -> sym</code></a> +<dd>Return the next command line argument (option) as a string, and remove it +from the remaining command line arguments. See also <code><a +href="ref.html#invoc">Invocation</a></code> and <code><a +href="refA.html#argv">argv</a></code>. + +<pre><code> +$ ./p -"de f () (println 'opt (opt))" -f abc -bye +opt "abc" +</code></pre> + +<dt><a name="or"><code>(or 'any ..) -> any</code></a> +<dd>Logical OR. The expressions <code>any</code> are evaluated from left to +right. If a non-<code>NIL</code> value is encountered, it is returned +immediately. Else the result of the last expression is returned. + +<pre><code> +: (or (= 3 3) (read)) +-> T +: (or (= 3 4) (read)) +abc +-> abc +</code></pre> + +<dt><a name="or/2"><code>or/2</code></a> +<dd><a href="ref.html#pilog">Pilog</a> predicate that takes an arbitrary number +of clauses, and succeeds if one of them can be proven. See also <code><a +href="refN.html#not/1">not/1</a></code>. + +<pre><code> +: (? + (or + ((equal 3 @X) (equal @X 4)) + ((equal 7 @X) (equal @X 7)) ) ) + @X=7 +-> NIL</code></pre> + +<dt><a name="out"><code>(out 'any . prg) -> any</code></a> +<dd>Opens <code>any</code> as output channel during the execution of +<code>prg</code>. The current output channel will be saved and restored +appropriately. If the argument is <code>NIL</code>, standard output is used. If +the argument is a symbol, it is used as a file name (opened in "append" mode if +the first character is "<code>+</code>"). If it is a positve 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. +See also <code><a href="refO.html#opid">opid</a></code>, <code> <a +href="refC.html#call">call</a></code>, <code><a +href="refI.html#in">in</a></code>, <code> <a +href="refP.html#pipe">pipe</a></code>, <code> <a +href="refC.html#ctl">ctl</a></code>, <code><a +href="refC.html#close">close</a></code> and <code><a +href="refL.html#load">load</a></code>. + +<pre><code> +: (out "a" (println 123 '(a b c) 'def)) # Write one line to file "a" +-> def +</code></pre> + +</dl> + +</body> +</html> diff --git a/doc/refP.html b/doc/refP.html @@ -0,0 +1,816 @@ +<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.0 Transitional//EN" "http://www.w3.org/TR/1998/REC-html40-19980424/loose.dtd"> +<html lang="en"> +<head> +<meta http-equiv="Content-Type" content="text/html; charset=utf-8"> +<title>P</title> +<link rel="stylesheet" href="doc.css" type="text/css"> +</head> +<body> + +<h1>P</h1> + +<dl> + +<dt><a name="*PPid"><code>*PPid</code></a> +<dd>A global constant holding the process-id of the parent picolisp process, or +<code>NIL</code> if the current process is a top level process. + +<pre><code> +: (println *PPid *Pid) +NIL 5286 + +: (unless (fork) (println *PPid *Pid) (bye)) +5286 5522 +</code></pre> + +<dt><a name="*Pid"><code>*Pid</code></a> +<dd>A global constant holding the current process-id. + +<pre><code> +: *Pid +-> 6386 +: (call "ps") # Show processes + PID TTY TIME CMD + .... ... ........ ..... + 6386 pts/1 00:00:00 bin/picolisp # <- current process + 6388 pts/1 00:00:00 ps +-> T +</code></pre> + +<dt><a name="pack"><code>(pack 'any ..) -> sym</code></a> +<dd>Returns a transient symbol whose name is concatenated from all arguments +<code>any</code>. A <code>NIL</code> 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 <code><a +href="refT.html#text">text</a></code> and <code><a +href="refG.html#glue">glue</a></code>. + +<pre><code> +: (pack 'car " is " 1 '(" symbol " name)) +-> "car is 1 symbol name" +</code></pre> + +<dt><a name="pad"><code>(pad 'cnt 'num) -> sym</code></a> +<dd>Returns a transient symbol with <code>num</code> <code><a +href="refP.html#pack">pack</a></code>ed with leading '0' characters, up to a +field width of <code>cnt</code>. See also <code><a +href="refF.html#format">format</a></code> and <code><a +href="refA.html#align">align</a></code>. + +<pre><code> +: (pad 5 1) +-> "00001" +: (pad 5 123456789) +-> "123456789" +</code></pre> + +<dt><a name="pair"><code>(pair 'any) -> any</code></a> +<dd>Returns <code>any</code> when the argument a cons pair cell. See also +<code><a href="refA.html#atom">atom</a></code>. + +<pre><code> +: (pair NIL) +-> NIL +: (pair (1 . 2)) +-> (1 . 2) +: (pair (1 2 3)) +-> (1 2 3) +</code></pre> + +<dt><a name="part/3"><code>part/3</code></a> +<dd><a href="ref.html#pilog">Pilog</a> predicate that succeeds if the first +argument, after <code><a href="refF.html#fold">fold</a></code>ing it to a +canonical form, is a <i>substring</i> of the folded string representation of the +result of applying the <code><a href="refG.html#get">get</a></code> algorithm to +the following arguments. Typically used as filter predicate in <code><a +href="refS.html#select/3">select/3</a></code> database queries. See also +<code><a href="refS.html#sub?">sub?</a></code>, <code><a +href="refI.html#isa/2">isa/2</a></code>, <code><a +href="refS.html#same/3">same/3</a></code>, <code><a +href="refB.html#bool/3">bool/3</a></code>, <code><a +href="refR.html#range/3">range/3</a></code>, <code><a +href="refH.html#head/3">head/3</a></code>, <code><a +href="refF.html#fold/3">fold/3</a></code> and <code><a +href="refT.html#tolr/3">tolr/3</a></code>. + +<pre><code> +: (? + @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={3-1} @Nr=(1 . 5) @Nm="part" @Item={3-2} +-> NIL +</code></pre> + +<dt><a name="pass"><code>(pass 'fun ['any ..]) -> any</code></a> +<dd>Passes to <code>fun</code> all arguments <code>any</code>, and all remaining +variable arguments (<code>@</code>) as they would be returned by <code><a +href="refR.html#rest">rest</a></code>. <code>(pass 'fun 'any)</code> is +equivalent to <code>(apply 'fun (rest) 'any)</code>. See also <code><a +href="refA.html#apply">apply</a></code>. + +<pre><code> +: (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) +</code></pre> + +<dt><a name="pat?"><code>(pat? 'any) -> pat | NIL</code></a> +<dd>Returns <code>any</code> when the argument <code>any</code> is a symbol +whose name starts with an at-mark "<code>@</code>", otherwise <code>NIL</code>. + +<pre><code> +: (pat? '@) +-> @ +: (pat? "@Abc") +-> "@Abc" +: (pat? "ABC") +-> NIL +: (pat? 123) +-> NIL +</code></pre> + +<dt><a name="patch"><code>(patch 'lst 'any . prg) -> any</code></a> +<dd>Destructively replaces all sub-expressions of <code>lst</code>, that +<code><a href="refM.html#match">match</a></code> the pattern <code>any</code>, +by the result of the execution of <code>prg</code>. See also <code><a +href="refD.html#daemon">daemon</a></code> and <code><a +href="refR.html#redef">redef</a></code>. + +<pre><code> +: (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!" +</code></pre> + +<dt><a name="path"><code>(path 'any) -> sym</code></a> +<dd>Substitutes any leading "<code>@</code>" character in the <code>any</code> +argument with the <u>PicoLisp Home Directory</u>, as it was remembered during +interpreter startup. Optionally, the name may be preceded by a "<code>+</code>" +character (as used by <code><a href="refO.html#out">out</a></code>). This +mechanism is used internally by all I/O functions. See also <code><a +href="ref.html#invoc">Invocation</a></code> and <code><a +href="refD.html#dirname">dirname</a></code>. + +<pre><code> +$ /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" +</code></pre> + +<dt><a name="peek"><code>(peek) -> sym</code></a> +<dd>Single character look-ahead: Returns the same character as the next call to +<code><a href="refC.html#char">char</a></code> would return. See also <code><a +href="refS.html#skip">skip</a></code>. + +<pre><code> +$ cat a +# Comment +abcd +$ ./dbg +: (in "a" (list (peek) (char))) +-> ("#" "#") +</code></pre> + +<dt><a name="permute/2"><code>permute/2</code></a> +<dd><a href="ref.html#pilog">Pilog</a> predicate that succeeds if the second +argument is a permutation of the list in the second argument. See also <code><a +href="refA.html#append/3">append/3</a></code>. + +<pre><code> +: (? (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 +</code></pre> + +<dt><a name="pick"><code>(pick 'fun 'lst ..) -> any</code></a> +<dd>Applies <code>fun</code> to successive elements of <code>lst</code> until +non-<code>NIL</code> is returned. Returns that value, or <code>NIL</code> if +<code>fun</code> did not return non-<code>NIL</code> for any element of +<code>lst</code>. When additional <code>lst</code> arguments are given, their +elements are also passed to <code>fun</code>. <code>(pick 'fun 'lst)</code> is +equivalent to <code>(fun (find 'fun 'lst))</code>. See also <code><a +href="refS.html#seek">seek</a></code>, <code><a +href="refF.html#find">find</a></code> and <code><a +href="refE.html#extract">extract</a></code>. + +<pre><code> +: (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 +</code></pre> + +<dt><a name="pid"><code>(pid 'pid|lst . exe) -> any</code></a> +<dd>Evaluates <code>exe</code> when the value of the global <code><a +href="refP.html#*Pid">*Pid</a></code> is equal to the <code>pid</code> argument, +or a member of the <code>lst</code> argument. Used typically in combination with +<code><a href="refT.html#tell">tell</a></code> to send a command selectively to +another process. + +<pre><code> +: (tell 'pid 20290 'gc 0) # Tell process 20290 to purge unused heap blocks +-> 0 +</code></pre> + +<dt><a name="pilog"><code>(pilog 'lst . prg) -> any</code></a> +<dd>Evaluates a <a href="ref.html#pilog">Pilog</a> query, and executes +<code>prg</code> for each result set with all Pilog variables bound to their +matching values. See also <code><a href="refS.html#solve">solve</a></code>, +<code><a href="ref_.html#?">?</a></code>, <code><a +href="refG.html#goal">goal</a></code> and <code><a +href="refP.html#prove">prove</a></code>. + +<pre><code> +: (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 +</code></pre> + +<dt><a name="pipe"><code>(pipe exe) -> cnt</code></a> +<dt><code>(pipe exe . prg) -> any</code> +<dd>Executes <code>exe</code> in a <code><a +href="refF.html#fork">fork</a></code>'ed child process (which terminates +thereafter). In the first form, <code>pipe</code> just returns a file descriptor +to 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 +<code>prg</code>. The current input channel will be saved and restored +appropriately. See also <code><a href="refI.html#ipid">ipid</a></code>, <code><a +href="refI.html#in">in</a></code>, <code><a href="refO.html#out">out</a></code> +and <code><a href="refR.html#rpc">rpc</a></code>. + +<pre><code> +: (pipe # equivalent to 'any' + (prinl "(a b # Comment^Jc d)") # (child process) + (read) ) # (parent process) +-> (a b c d) +: (pipe # pipe through an external program + (out '(tr "[a-z]" "[A-Z]") # (child process) + (prinl "abc def ghi") ) + (line T) ) # (parent process) +-> "ABC DEF GHI" +</code></pre> + +<dt><a name="place"><code>(place 'cnt 'lst 'any) -> lst</code></a> +<dd>Places <code>any</code> into <code>lst</code> at position <code>cnt</code>. +See also <code><a href="refI.html#insert">insert</a></code>, <code><a +href="refR.html#remove">remove</a></code>, <code><a +href="refA.html#append">append</a></code>, <code><a +href="refD.html#delete">delete</a></code> and <code><a +href="refR.html#replace">replace</a></code>. + +<pre><code> +: (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) +</code></pre> + +<dt><a name="poll"><code>(poll 'cnt) -> cnt | NIL</code></a> +<dd>Checks for the availability of data for reading on the file descriptor +<code>cnt</code>. See also <code><a href="refO.html#open">open</a></code>, +<code><a href="refI.html#in">in</a></code> and <code><a +href="refC.html#close">close</a></code>. + +<pre><code> +: (and (poll *Fd) (in @ (read))) # Prevent blocking +</code></pre> + +<dt><a name="pool"><code>(pool ['sym1 ['lst] ['sym2] ['sym3]]) -> T</code></a> +<dd>Opens the file <code>sym1</code> as a database file in read/write mode. If +the file does not exist, it is created. A currently open database is closed. +<code>lst</code> 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 +<code>lst</code> is given, an individual database file is opened for each item. +If <code>sym2</code> is non-<code>NIL</code>, it is opened in append-mode as an +asynchronous replication journal. If <code>sym3</code> is non-<code>NIL</code>, +it is opened for reading and appending, to be used as a synchronous transaction +log during <code><a href="refC.html#commit">commit</a></code>s. See also +<code><a href="refD.html#dbs">dbs</a></code>, <code><a +href="refD.html#*Dbs">*Dbs</a></code> and <code><a +href="refJ.html#journal">journal</a></code>. + +<pre><code> +: (pool "/dev/hda2") +-> T + +: *Dbs +-> (1 2 2 4) +: (pool "dbFile" *Dbs) +-> T +: +abu:~/pico ls -l dbFile* +-rw-r--r-- 1 abu abu 256 2007-06-11 07:57 dbFile1 +-rw-r--r-- 1 abu abu 13 2007-06-11 07:57 dbFile2 +-rw-r--r-- 1 abu abu 13 2007-06-11 07:57 dbFile3 +-rw-r--r-- 1 abu abu 13 2007-06-11 07:57 dbFile4 +</code></pre> + +<dt><a name="pop"><code>(pop 'var) -> any</code></a> +<dd>Pops the first element (CAR) from the stack in <code>var</code>. See also +<code><a href="refP.html#push">push</a></code>, <code><a +href="refQ.html#queue">queue</a></code>, <code><a +href="refC.html#cut">cut</a></code>, <code><a +href="refD.html#del">del</a></code> and <code><a +href="refF.html#fifo">fifo</a></code>. + +<pre><code> +: (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)) +</code></pre> + +<dt><a name="port"><code>(port ['T] 'cnt|(cnt . cnt) ['var]) -> cnt</code></a> +<dd>Opens a TCP-Port <code>cnt</code> (or a UDP-Port if the first argument is +<code>T</code>), and returns a socket descriptor suitable as an argument for +<code><a href="refL.html#listen">listen</a></code> or <code><a +href="refA.html#accept">accept</a></code> (or <code><a +href="refU.html#udp">udp</a></code>, respectively). If <code>cnt</code> is zero, +some free port number is allocated. If a pair of <code>cnt</code>s is given +instead, it should be a range of numbers which are tried in turn. When +<code>var</code> is given, it is bound to the port number. + +<pre><code> +: (port 0 'A) # Allocate free port +-> 4 +: A +-> 1034 # Got 1034 +: (port (4000 . 4008) 'A) # Try one of these ports +-> 5 +: A +-> 4002 +</code></pre> + +<dt><a name="pp"><code>(pp 'sym) -> sym</code></a> +<dt><code>(pp 'sym 'cls) -> sym</code> +<dt><code>(pp '(sym . cls)) -> sym</code> +<dd>Pretty-prints the function or method definition of <code>sym</code>. The +output format would regenerate that same definition when read and executed. See +also <code><a href="refP.html#pretty">pretty</a></code>, <code><a +href="refD.html#debug">debug</a></code> and <code><a +href="refV.html#vi">vi</a></code>. + +<pre><code> +: (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))) ) ) +</code></pre> + +<dt><a name="pr"><code>(pr 'any ..) -> any</code></a> +<dd>Binary print: Prints all <code>any</code> arguments to the current output +channel in encoded binary format. See also <code><a +href="refR.html#rd">rd</a></code>, <code><a +href="refT.html#tell">tell</a></code>, <code><a +href="refH.html#hear">hear</a></code>, <code><a +href="refR.html#rpc">rpc</a></code> and <code><a +href="refW.html#wr">wr</a></code>. + +<pre><code> +: (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 +</code></pre> + +<dt><a name="prEval"><code>(prEval 'prg ['cnt]) -> any</code></a> +<dd>Executes <code>prg</code>, similar to <code><a +href="refR.html#run">run</a></code>, by evaluating all expressions in +<code>prg</code> (within the binding environment given by <code>cnt-1</code>). +As a side effect, all atomics expression will be printed with <code><a +href="refP.html#prinl">prinl</a></code>. See also <code><a +href="refE.html#eval">eval</a></code>. + +<pre><code> +: (let Prg 567 + (prEval + '("abc" (prinl (+ 1 2 3)) Prg 987) ) ) +abc +6 +567 +987 +-> 987 +</code></pre> + +<dt><a name="pre?"><code>(pre? 'any1 'any2) -> any2 | NIL</code></a> +<dd>Returns <code>any2</code> when the string representation of +<code>any1</code> is a prefix of the string representation of <code>any2</code>. +See also <code><a href="refS.html#sub?">sub?</a></code>. + +<pre><code> +: (pre? "abc" "abcdef") +-> "abcdef" +: (pre? "def" "abcdef") +-> NIL +: (pre? (+ 3 4) "7fach") +-> "7fach" +: (pre? NIL "abcdef") +-> "abcdef" +</code></pre> + +<dt><a name="pretty"><code>(pretty 'any 'cnt)</code></a> +<dd>Pretty-prints <code>any</code>. If <code>any</code> is an atom, or a list +with a <code><a href="refS.html#size">size</a></code> not greater than 12, it is +<code><a href="refP.html#print">print</a></code>ed as is. Otherwise, only the +opening parenthesis and the CAR of the list is printed, all other elementes are +pretty-printed recursively indented by three spaces, followed by a space and the +corresponding closing parenthesis. The initial indentation level +<code>cnt</code> defaults to zero. See also <code><a +href="refP.html#pp">pp</a></code>. + +<pre><code> +: (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 )-> ")" +</code></pre> + +<dt><a name="prin"><code>(prin 'any ..) -> any</code></a> +<dd>Prints the string representation of all <code>any</code> 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 <code>prin</code>'ted +recursively. See also <code><a href="refP.html#prinl">prinl</a></code>. + +<pre><code> +: (prin 'abc 123 '(a 1 b 2)) +abc123a1b2-> (a 1 b 2) +</code></pre> + +<dt><a name="prinl"><code>(prinl 'any ..) -> any</code></a> +<dd>Prints the string representation of all <code>any</code> arguments to the +current output channel, followed by a newline. No space or newline is printed +between individual items. For lists, all elements are <code>prin</code>'ted +recursively. See also <code><a href="refP.html#prin">prin</a></code>. + +<pre><code> +: (prinl 'abc 123 '(a 1 b 2)) +abc123a1b2 +-> (a 1 b 2) +</code></pre> + +<dt><a name="print"><code>(print 'any ..) -> any</code></a> +<dd>Prints all <code>any</code> 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 <code><a +href="refP.html#println">println</a></code>, <code><a +href="refP.html#printsp">printsp</a></code>, <code><a +href="refS.html#sym">sym</a></code> and <code><a +href="refS.html#str">str</a></code> + +<pre><code> +: (print 123) +123-> 123 +: (print 1 2 3) +1 2 3-> 3 +: (print '(a b c) 'def) +(a b c) def-> def +</code></pre> + +<dt><a name="println"><code>(println 'any ..) -> any</code></a> +<dd>Prints all <code>any</code> 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 <code><a +href="refP.html#print">print</a></code>, <code><a +href="refP.html#printsp">printsp</a></code>. + +<pre><code> +: (println '(a b c) 'def) +(a b c) def +-> def +</code></pre> + +<dt><a name="printsp"><code>(printsp 'any ..) -> any</code></a> +<dd>Prints all <code>any</code> 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 <code><a +href="refP.html#print">print</a></code>, <code><a +href="refP.html#println">println</a></code>. + +<pre><code> +: (printsp '(a b c) 'def) +(a b c) def -> def +</code></pre> + +<dt><a name="proc"><code>(proc 'sym ..) -> T</code></a> +<dd>Shows a list of processes with command names given by the <code>sym</code> +arguments, using the system <code>ps</code> utility. See also <code><a +href="refH.html#hd">hd</a></code>. + +<pre><code> +: (proc 'picolisp) + PID PPID STARTED SZ %CPU WCHAN CMD + 9781 8895 16:06:53 2536 0.8 select ./bin/picolisp -on *Dbg ./lib.l @ext.l @dbg.l app/main.l lib/too.l -main -go + 9884 9781 16:07:01 2540 0.0 wait ./bin/picolisp -on *Dbg ./lib.l @ext.l @dbg.l app/main.l lib/too.l -main -go +-> T</code></pre> + +<dt><a name="prog"><code>(prog . prg) -> any</code></a> +<dd>Executes <code>prg</code>, and returns the result of the last expression. +See also <code><a href="refN.html#nil">nil</a></code>, <code><a +href="refT.html#t">t</a></code>, <code><a +href="refP.html#prog1">prog1</a></code> and <code><a +href="refP.html#prog2">prog2</a></code>. + +<pre><code> +: (prog (print 1) (print 2) (print 3)) +123-> 3 +</code></pre> + +<dt><a name="prog1"><code>(prog1 'any1 . prg) -> any1</code></a> +<dd>Executes all arguments, and returns the result of the first expression +<code>any1</code>. See also <code><a href="refN.html#nil">nil</a></code>, +<code><a href="refT.html#t">t</a></code>, <code><a +href="refP.html#prog">prog</a></code> and <code><a +href="refP.html#prog2">prog2</a></code>. + +<pre><code> +: (prog1 (print 1) (print 2) (print 3)) +123-> 1 +</code></pre> + +<dt><a name="prog2"><code>(prog2 'any1 'any2 . prg) -> any2</code></a> +<dd>Executes all arguments, and returns the result of the second expression +<code>any2</code>. See also <code><a href="refN.html#nil">nil</a></code>, +<code><a href="refT.html#t">t</a></code>, <code><a +href="refP.html#prog">prog</a></code> and <code><a +href="refP.html#prog1">prog1</a></code>. + +<pre><code> +: (prog2 (print 1) (print 2) (print 3)) +123-> 2 +</code></pre> + +<dt><a name="prop"><code>(prop 'sym1|lst ['sym2|cnt ..] 'sym) -> lst|sym</code></a> +<dd>Fetches a property for a property key <code>sym</code> from a symbol. That +symbol is <code>sym1</code> (if no other arguments are given), or a symbol found +by applying the <code><a href="refG.html#get">get</a></code> algorithm to +<code>sym1|lst</code> and the following arguments. The property (the cell, not +just its value) is returned, suitable for direct (destructive) manipulations. +See also <code><a href="ref_.html#::">::</a></code>. + +<pre><code> +: (put 'X 'cnt 0) +-> 0 +: (prop 'X 'cnt) +-> (0 . cnt) +: (inc (prop 'X 'cnt)) # Directly manipulate the property value +-> 1 +: (get 'X 'cnt) +-> 1 +</code></pre> + +<dt><a name="protect"><code>(protect . prg) -> any</code></a> +<dd>Executes <code>prg</code>, 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 <code>prg</code> is completed. See also <code><a +href="refA.html#alarm">alarm</a></code>, <a href="refH.html#*Hup">*Hup</a>, <a +href="refS.html#*Sig1">*Sig[12]</a> and <code><a +href="refK.html#kill">kill</a></code>. + +<pre><code> +: (protect (journal "db1.log" "db2.log")) +-> T +</code></pre> + +<dt><a name="prove"><code>(prove 'lst ['lst]) -> lst</code></a> +<dd>The <a href="ref.html#pilog">Pilog</a> interpreter. Tries to prove the query +list in the first argument, and returns an association list of symbol-value +pairs, or <code>NIL</code> if not successful. The query list is modified as a +side effect, allowing subsequent calls to <code>prove</code> 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 <code><a href="refG.html#goal">goal</a></code>, <code><a +href="ref_.html#->">-&gt</a></code> and <code><a +href="refU.html#unify">unify</a></code>. + +<pre><code> +: (prove (goal '((equal 3 3)))) +-> T +: (prove (goal '((equal 3 @X)))) +-> ((@X . 3)) +: (prove (goal '((equal 3 4)))) +-> NIL +</code></pre> + +<dt><a name="prune"><code>(prune ['flg])</code></a> +<dd>Optimizes memory usage by pruning in-memory leaf nodes of database trees. +Typically called repeatedly during heavy data imports. If <code>flg</code> is +non-<code>NIL</code>, further pruning will be disabled. See also <code><a +href="refL.html#lieu">lieu</a></code>. + +<pre><code> +(in File1 + (while (someData) + (new T '(+Cls1) ..) + (at (0 . 10000) (commit) (prune)) ) ) +(in File2 + (while (moreData) + (new T '(+Cls2) ..) + (at (0 . 10000) (commit) (prune)) ) ) +(commit) +(prune T) +</code></pre> + +<dt><a name="push"><code>(push 'var 'any ..) -> any</code></a> +<dd>Implements a stack using a list in <code>var</code>. The <code>any</code> +arguments are cons'ed in front of the value list. See also <code><a +href="refP.html#push1">push1</a></code>, <code><a +href="refP.html#pop">pop</a></code>, <code><a +href="refQ.html#queue">queue</a></code> and <code><a +href="refF.html#fifo">fifo</a></code>. + +<pre><code> +: (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) +</code></pre> + +<dt><a name="push1"><code>(push1 'var 'any ..) -> any</code></a> +<dd>Maintains a unique list in <code>var</code>. Each <code>any</code> argument +is cons'ed in front of the value list only if it is not already a <code><a +href="refM.html#member">member</a></code> of that list. See also <code><a +href="refP.html#push">push</a></code>, <code><a +href="refP.html#pop">pop</a></code> and <code><a +href="refQ.html#queue">queue</a></code>. + +<pre><code> +: (push1 'S 1 2 3) +-> 3 +: S +-> (3 2 1) +: (push1 'S 2 4) +-> 4 +: S +-> (4 3 2 1) +</code></pre> + +<dt><a name="put"><code>(put 'sym1|lst ['sym2|cnt ..] 'sym|0 'any) -> any</code></a> +<dd>Stores a new value <code>any</code> for a property key <code>sym</code> (or +in the value cell for zero) in a symbol. That symbol is <code>sym1</code> (if no +other arguments are given), or a symbol found by applying the <code><a +href="refG.html#get">get</a></code> algorithm to <code>sym1|lst</code> and the +following arguments. See also <code><a href="ref_.html#=:">=:</a></code>. + +<pre><code> +: (put 'X 'a 1) +-> 1 +: (get 'X 'a) +-> 1 +: (prop 'X 'a) +-> (1 . a) +</code></pre> + +<dt><a name="put!"><code>(put! 'obj 'sym 'any) -> any</code></a> +<dd><a href="ref.html#trans">Transaction</a> wrapper function for <code><a +href="refP.html#put">put</a></code>. Note that for setting property values of +entities typically the <code><a +href="refE.html#entityMesssages">put!></a></code> message is used. See also +<code><a href="refN.html#new!">new!</a></code>, <code><a +href="refS.html#set!">set!</a></code> and <code><a +href="refI.html#inc!">inc!</a></code>. + +<pre><code> +(put! Obj 'cnt 0) # Setting a property of a non-entity object +</code></pre> + +<dt><a name="putl"><code>(putl 'sym1|lst1 ['sym2|cnt ..] 'lst) -> lst</code></a> +<dd>Stores a complete new property list <code>lst</code> in a symbol. That +symbol is <code>sym1</code> (if no other arguments are given), or a symbol found +by applying the <code><a href="refG.html#get">get</a></code> algorithm to +<code>sym1|lst1</code> and the following arguments. All previously defined +properties for that symbol are lost. See also <code><a +href="refG.html#getl">getl</a></code> and <code><a +href="refM.html#maps">maps</a></code>. + +<pre><code> +: (putl 'X '((123 . a) flg ("Hello" . b))) +-> ((123 . a) flg ("Hello" . b)) +: (get 'X 'a) +-> 123 +: (get 'X 'b) +-> "Hello" +: (get 'X 'flg) +-> T +</code></pre> + +<dt><a name="pwd"><code>(pwd) -> sym</code></a> +<dd>Returns the path to the current working directory. See also <code><a +href="refD.html#dir">dir</a></code> and <code><a +href="refC.html#cd">cd</a></code>. + +<pre><code> +: (pwd) +-> "/home/app/" +</code></pre> + +</dl> + +</body> +</html> diff --git a/doc/refQ.html b/doc/refQ.html @@ -0,0 +1,107 @@ +<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.0 Transitional//EN" "http://www.w3.org/TR/1998/REC-html40-19980424/loose.dtd"> +<html lang="en"> +<head> +<meta http-equiv="Content-Type" content="text/html; charset=utf-8"> +<title>Q</title> +<link rel="stylesheet" href="doc.css" type="text/css"> +</head> +<body> + +<h1>Q</h1> + +<dl> + +<dt><a name="qsym"><code>(qsym . sym) -> lst</code></a> +<dd>Returns a cons pair of the value and property list of <code>sym</code>. See +also <code><a href="refQ.html#quote">quote</a></code>, <code><a +href="refV.html#val">val</a></code> and <code><a +href="refG.html#getl">getl</a></code>. + +<pre><code> +: (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)) +</code></pre> + +<dt><a name="quote"><code>(quote . any) -> any</code></a> +<dd>Returns <code>any</code> unevaluated. The reader recognizes the single quote +char <code>'</code> as a macro for this function. See also <code><a +href="refL.html#lit">lit</a></code>. + +<pre><code> +: 'a +-> a +: '(foo a b c) +-> (foo a b c) +: (quote (quote (quote a))) +-> ('('(a))) +</code></pre> + +<dt><a name="query"><code>(query 'lst ['lst]) -> flg</code></a> +<dd>Handles an interactive <a href="ref.html#pilog">Pilog</a> query. The two +<code>lst</code> arguments are passed to <code><a +href="refP.html#prove">prove</a></code>. <code>query</code> displays each +result, waits for console input, and terminates when a non-empty line is +entered. See also <code><a href="ref_.html#?">?</a></code>, <code><a +href="refP.html#pilog">pilog</a></code> and <code><a +href="refS.html#solve">solve</a></code>. + +<pre><code> +: (query (goal '((append @X @Y (a b c))))) + @X=NIL @Y=(a b c) + @X=(a) @Y=(b c). # Stop +-> NIL +</code></pre> + +<dt><a name="queue"><code>(queue 'var 'any) -> any</code></a> +<dd>Implements a queue using a list in <code>var</code>. The <code>any</code> +argument is (destructively) concatenated to the end of the value list. See also +<code><a href="refP.html#push">push</a></code>, <code><a +href="refP.html#pop">pop</a></code> and <code><a +href="refF.html#fifo">fifo</a></code>. + +<pre><code> +: (queue 'A 1) +-> 1 +: (queue 'A 2) +-> 2 +: (queue 'A 3) +-> 3 +: A +-> (1 2 3) +: (pop 'A) +-> 1 +: A +-> (2 3) +</code></pre> + +<dt><a name="quit"><code>(quit ['any ['any]])</code></a> +<dd>Stops current execution. If no arguments are given, all pending <code><a +href="refF.html#finally">finally</a></code> 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 <code><a href="ref.html#errors">Error +Handling</a></code>. + +<pre><code> +: (de foo (X) (quit <u>Sorry, my error</u> X)) +-> foo +: (foo 123) # 'X' is bound to '123' +123 -- Sorry, my error # Error entered +? X # Inspect 'X' +-> 123 +? # Empty line: Exit +: +</code></pre> + +</dl> + +</body> +</html> diff --git a/doc/refR.html b/doc/refR.html @@ -0,0 +1,713 @@ +<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.0 Transitional//EN" "http://www.w3.org/TR/1998/REC-html40-19980424/loose.dtd"> +<html lang="en"> +<head> +<meta http-equiv="Content-Type" content="text/html; charset=utf-8"> +<title>R</title> +<link rel="stylesheet" href="doc.css" type="text/css"> +</head> +<body> + +<h1>R</h1> + +<dl> + +<dt><a name="*Run"><code>*Run</code></a> +<dd>This global variable can hold a list of <code>prg</code> expressions which +are used during <code><a href="refK.html#key">key</a></code>, <code><a +href="refS.html#sync">sync</a></code>, <code><a +href="refW.html#wait">wait</a></code> and <code><a +href="refL.html#listen">listen</a></code>. 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 <code>select</code> +system call is performed with these values, and the corresponding +<code>prg</code> body is executed when input data are available or when a +timeout occurred. See also <code><a href="refT.html#task">task</a></code>. + +<pre><code> +: (de *Run (-2000 0 (println '2sec))) # Install 2-sec-timer +-> *Run +: 2sec # Prints "2sec" every 2 seconds +2sec +2sec + # (Enter) Exit +$ +</code></pre> + +<dt><a name="+Ref"><code>+Ref</code></a> +<dd>Prefix class for maintaining non-unique indexes to <code><a +href="refR.html#+relation">+relation</a></code>s, a subclass of <code><a +href="refI.html#+index">+index</a></code>. Accepts an optional argument for a +<code><a href="refH.html#+Hook">+Hook</a></code> attribute. See also <code><a +href="ref.html#dbase">Database</a></code>. + +<pre><code> +(rel tel (+Fold +Ref +String)) # Phone number with folded, non-unique index +</code></pre> + +<dt><a name="+Ref2"><code>+Ref2</code></a> +<dd>Prefix class for maintaining a secondary ("backing") index to <code><a +href="refR.html#+relation">+relation</a></code>s. Can only be used as a prefix +class to <code><a href="refK.html#+Key">+Key</a></code> or <code><a +href="refR.html#+Ref">+Ref</a></code>. It maintains an index in the current +(sub)class, in addition to that in one of the superclasses, to allow +(sub)class-specific queries. See also <code><a +href="ref.html#dbase">Database</a></code>. + +<pre><code> +(class +Ord +Entity) # Order class +(rel nr (+Need +Key +Number)) # Order number +... +(class +EuOrd +Ord) # EU-specific order subclass +(rel nr (+Ref2 +Key +Number)) # Order number with backing index +</code></pre> + +<dt><a name="+relation"><code>+relation</code></a> +<dd>Abstract base class of all database releations. Relation objects are usually +defined with <code><a href="refR.html#rel">rel</a></code>. The class hierarchy +includes the classes <code><a href="refA.html#+Any">+Any</a></code>, <code><a +href="refB.html#+Bag">+Bag</a></code>, <code><a +href="refB.html#+Bool">+Bool</a></code>, <code><a +href="refN.html#+Number">+Number</a></code>, <code><a +href="refD.html#+Date">+Date</a></code>, <code><a +href="refT.html#+Time">+Time</a></code>, <code><a +href="refS.html#+Symbol">+Symbol</a></code>, <code><a +href="refS.html#+String">+String</a></code>, <code><a +href="refL.html#+Link">+Link</a></code>, <code><a +href="refJ.html#+Joint">+Joint</a></code> and <code><a +href="refB.html#+Blob">+Blob</a></code>, and the prefix classes <code><a +href="refH.html#+Hook">+Hook</a></code>, <code><a +href="refI.html#+index">+index</a></code>, <code><a +href="refK.html#+Key">+Key</a></code>, <code><a +href="refR.html#+Ref">+Ref</a></code>, <code><a +href="refR.html#+Ref2">+Ref2</a></code>, <code><a +href="refI.html#+Idx">+Idx</a></code>, <code><a +href="refS.html#+Sn">+Sn</a></code>, <code><a +href="refF.html#+Fold">+Fold</a></code>, <code><a +href="refA.html#+Aux">+Aux</a></code>, <code><a +href="refD.html#+Dep">+Dep</a></code>, <code><a +href="refL.html#+List">+List</a></code>, <code><a +href="refN.html#+Need">+Need</a></code>, <code><a +href="refM.html#+Mis">+Mis</a></code> and <code><a +href="refA.html#+Alt">+Alt</a></code>. See also <code><a +href="ref.html#dbase">Database</a></code> and <code><a +href="refE.html#+Entity">+Entity</a></code>. + +<p><a name="relationMesssages">Messages</a> to relation objects include + +<pre><code> +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 strutures +lose> (Obj Val) # Delete relational structures +keep> (Obj Val) # Restore deleted relational structures +zap> (Obj Val) # Clean up relational structures +</code></pre> + +<dt><a name="rand"><code>(rand ['cnt1 'cnt2] | ['T]) -> cnt | flg</code></a> +<dd>Returns a pseudo random number in the range cnt1 .. cnt2 (or -2147483648 .. ++2147483647 if no arguments are given). If the argument is <code>T</code>, a +boolean value <code>flg</code> is returned. See also <code><a +href="refS.html#seed">seed</a></code>. + +<pre><code> +: (rand 3 9) +-> 3 +: (rand 3 9) +-> 7 +</code></pre> + +<dt><a name="range"><code>(range 'num1 'num2 ['num3]) -> lst</code></a> +<dd>Produces a list of numbers in the range <code>num1</code> through +<code>num2</code>. When <code>num3</code> is non-<code>NIL</code>), it is used +to increment <code>num1</code> (if it is smaller than <code>num2</code>) or to +decrement <code>num1</code> (if it is greater than <code>num2</code>). See also +<code><a href="refN.html#need">need</a></code>. + +<pre><code> +: (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) +</code></pre> + +<dt><a name="range/3"><code>range/3</code></a> +<dd><a href="ref.html#pilog">Pilog</a> predicate that succeeds if the first +argument is in the range of the result of applying the <code><a +href="refG.html#get">get</a></code> algorithm to the following arguments. +Typically used as filter predicate in <code><a +href="refS.html#select/3">select/3</a></code> database queries. See also +<code><a href="ref.html#cmp">Comparing</a></code>, <code><a +href="refI.html#isa/2">isa/2</a></code>, <code><a +href="refS.html#same/3">same/3</a></code>, <code><a +href="refB.html#bool/3">bool/3</a></code>, <code><a +href="refH.html#head/3">head/3</a></code>, <code><a +href="refF.html#fold/3">fold/3</a></code>, <code><a +href="refP.html#part/3">part/3</a></code> and <code><a +href="refT.html#tolr/3">tolr/3</a></code>. + +<pre><code> +: (? + @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={3-1} @Nr=(1 . 5) @Nm="part" @Item={3-2} +-> NIL +</code></pre> + +<dt><a name="rank"><code>(rank 'any 'lst ['flg]) -> lst</code></a> +<dd>Searches a ranking list. <code>lst</code> should be sorted. Returns the +element from <code>lst</code> with a maximal CAR less or equal to +<code>any</code> (if <code>flg</code> is <code>NIL</code>), or with a minimal +CAR greater or equal to <code>any</code> (if <code>flg</code> is +non-<code>NIL</code>), or <code>NIL</code> if no match is found. See also +<code><a href="refA.html#assoc">assoc</a></code> and <a +href="ref.html#cmp">Comparing</a>. + +<pre><code> +: (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) +</code></pre> + +<dt><a name="raw"><code>(raw ['flg]) -> flg</code></a> +<dd>Console mode control function. When called without arguments, it returns the +current console mode (<code>NIL</code> for "cooked mode"). Otherwise, the +console is set to the new state. See also <code><a +href="refK.html#key">key</a></code>. + +<pre><code> +$ ./p +: (raw) +-> NIL +$ ./dbg +: (raw) +-> T +</code></pre> + +<dt><a name="rc"><code>(rc 'sym 'any1 ['any2]) -> any</code></a> +<dd>Fetches a value from a ressource file <code>sym</code>, or stores a value +<code>any2</code> in that file, using a key <code>any1</code>. All values are +stored in a list in the file, using <code><a +href="refA.html#assoc">assoc</a></code>. During the whole operation, the file is +exclusively locked with <code><a href="refC.html#ctl">ctl</a></code>. + +<pre><code> +: (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) +</code></pre> + +<dt><a name="rd"><code>(rd ['sym]) -> any</code></a> +<dt><code>(rd 'cnt) -> num | NIL</code> +<dd>Binary read: Reads one item from the current input channel in encoded binary +format. When called with a <code>cnt</code> argument (second form), that number +of raw bytes (in big endian format if <code>cnt</code> is positive, otherwise +little endian) is read as a single number. Upon end of file, if the +<code>sym</code> argument is given, it is returned, otherwise <code>NIL</code>. +See also <code><a href="refP.html#pr">pr</a></code>, <code><a +href="refT.html#tell">tell</a></code>, <code><a +href="refH.html#hear">hear</a></code>, <code><a +href="refR.html#rpc">rpc</a></code> and <code><a +href="refW.html#wr">wr</a></code>. + +<pre><code> +: (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 +</code></pre> + +<dt><a name="read"><code>(read ['sym1 ['sym2]]) -> any</code></a> +<dd>Reads one item from the current input channel. <code>NIL</code> is returned +upon end of file. When called without arguments, an arbitrary Lisp expression is +read. Otherwise, a token (a number, or an internal or transient symbol) is read. +In that case, <code>sym1</code> specifies which set of characters to accept for +continuous symbol names (in addition to the standard alphanumerical characters), +and <code>sym2</code> an optional comment character. See also <code><a +href="refA.html#any">any</a></code>, <code><a +href="refS.html#str">str</a></code>, <code><a +href="refS.html#skip">skip</a></code> and <code><a +href="refE.html#eof">eof</a></code>. + +<pre><code> +: (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 "(" "xyz" "+" "-" 123 ")") +</code></pre> + +<dt><a name="recur"><code>(recur fun) -> any</code></a> +<dt><a name="recurse"><code>(recurse ..) -> any</code></a> +<dd>Implements anonymous recursion, by defining the function +<code>recurse</code> on the fly. During the execution of <code>fun</code>, the +symbol <code>recurse</code> is bound to the function definition +<code>fun</code>. See also <code><a href="refL.html#let">let</a></code> and +<code><a href="ref.html#lambda">lambda</a></code>. + +<pre><code> +: (de fibonacci (N) + (when (lt0 N) + (quit "Bad fibonacci" N) ) + (recur (N) + (if (< N 2) + 1 + (+ + (recurse (dec N)) + (recurse (- N 2)) ) ) ) ) +-> fibonacci +: (fibonacci 22) +-> 28657 +: (fibonacci -7) +-7 -- Bad fibonacci +</code></pre> + +<dt><a name="redef"><code>(redef sym . fun) -> sym</code></a> +<dd>Redefines <code>sym</code> in terms of itself. The current definition is +saved in a new symbol, which is substituted for each occurrence of +<code>sym</code> in <code>fun</code>, and which is also returned. See also +<code><a href="refD.html#de">de</a></code>, <code><a +href="refD.html#daemon">daemon</a></code> and <code><a +href="refP.html#patch">patch</a></code>. + +<pre><code> +: (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" + +</code></pre> + +<dt><a name="rel"><code>(rel var lst [any ..]) -> any</code></a> +<dd>Defines a relation for <code>var</code> in the current class <code><a +href="refC.html#*Class">*Class</a></code>, using <code>lst</code> as the list of +classes for that relation, and possibly additional arguments <code>any</code> +for its initialization. See also <a href="ref.html#dbase">Database</a>, <a +href="refC.html#class">class</a>, <a href="refE.html#extend">extend</a>, <a +href="refD.html#dm">dm</a> and <a href="refV.html#var">var</a>. + +<pre><code> +(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 +</code></pre> + +<dt><a name="release"><code>(release 'sym) -> NIL</code></a> +<dd>Releases the mutex represented by the file 'sym'. This is the reverse +operation of <code><a href="refA.html#acquire">acquire</a></code>. + +<pre><code> +: (release "sema1") +-> NIL +</code></pre> + +<dt><a name="remote/2"><code>remote/2</code></a> +<dd><a href="ref.html#pilog">Pilog</a> 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 <code><a +href="refE.html#*Ext">*Ext</a></code>, <code><a +href="refS.html#select/3">select/3</a></code> and <code><a +href="refD.html#db/3">db/3</a></code>. + +<pre><code> +(setq *Ext # Set up external offsets + (mapcar + '((@Host @Ext) + (let Sock NIL + (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) ) +{L-2} (+Item) + pr 1250 + inv 100 + sup {K-2} + nm Spare Part + nr 2 + @Nr=(1 . 3) @Sup=2 @Rsrc=((((X) (ext 20 (out 16 (pr X)))) NIL (ext 20 (in 16 (rd))))) @Item={L-2} +-> NIL +</code></pre> + +<dt><a name="remove"><code>(remove 'cnt 'lst) -> lst</code></a> +<dd>Removes the element at position <code>cnt</code> from <code>lst</code>. See +also <code><a href="refI.html#insert">insert</a></code>, <code><a +href="refP.html#place">place</a></code>, <code><a +href="refA.html#append">append</a></code>, <code><a +href="refD.html#delete">delete</a></code> and <code><a +href="refR.html#replace">replace</a></code>. + +<pre><code> +: (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) +</code></pre> + +<dt><a name="repeat"><code>(repeat) -> lst</code></a> +<dd>Makes the current <a href="ref.html#pilog">Pilog</a> definition "tail +recursive", by closing the previously defined clauses in the T property to a +circular list. See also <code><a href="refB.html#be">be</a></code>. + +<pre><code> +(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 +</code></pre> + +<dt><a name="repeat/0"><code>repeat/0</code></a> +<dd><a href="ref.html#pilog">Pilog</a> predicate that always succeeds, also on +backtracking. See also <code><a href="refR.html#repeat">repeat</a></code> and +<code><a href="refT.html#true">true</a></code>. + +<pre><code> +: (be int (@N) # Generate unlimited supply of integers + (@ zero *N) + (repeat) # Repeat from here + (@N inc '*N) ) +-> int + +: (? (int @X)) + @X=1 + @X=2 + @X=3 + @X=4. # Stop +-> NIL +</code></pre> + +<dt><a name="replace"><code>(replace 'lst 'any1 'any2 ..) -> lst</code></a> +<dd>Replaces in <code>lst</code> all occurrences of <code>any1</code> with +<code>any2</code>. For optional additional argument pairs, this process is +repeated. See also <code><a href="refA.html#append">append</a></code>, <code><a +href="refD.html#delete">delete</a></code>, <code><a +href="refI.html#insert">insert</a></code>, <code><a +href="refR.html#remove">remove</a></code> and <code><a +href="refP.html#place">place</a></code>. + +<pre><code> +: (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) +</code></pre> + +<dt><a name="request"><code>(request 'typ 'var ['hook] 'val ..) -> obj</code></a> +<dd>Returns a database object. If a matching object cannot be found (using +<code><a href="refD.html#db">db</a></code>), a new object of the given type is +created (using <code><a href="refN.html#new">new</a></code>). See also <code><a +href="refO.html#obj">obj</a></code>. + +<pre><code> +: (request '(+Item) 'nr 2) +-> {3-2} +</code></pre> + +<dt><a name="rest"><code>(rest) -> lst</code></a> +<dd>Can only be used inside functions with a variable number of arguments (with +<code>@</code>). Returns the list of all remaining arguments from the internal +list. See also <code><a href="refA.html#args">args</a></code>, <code><a +href="refN.html#next">next</a></code>, <code><a +href="refA.html#arg">arg</a></code> and <code><a +href="refP.html#pass">pass</a></code>. + +<pre><code> +: (de foo @ (println (rest))) +-> foo +: (foo 1 2 3) +(1 2 3) +-> (1 2 3) +</code></pre> + +<dt><a name="retract">(retract ) -> lst<code></code></a> +<dd>Removes a <a href="ref.html#pilog">Pilog</a> fact or rule. <code><a +href="refB.html#be">be</a></code>, <code><a +href="refA.html#asserta">asserta</a></code> and <code><a +href="refA.html#assertz">assertz</a></code>. + +<pre><code> +: (be a (1)) +-> a +: (be a (2)) +-> a +: (be a (3)) +-> a + +: (retract '(a (2))) +-> (((1)) ((3))) + +: (? (a @N)) + @N=1 + @N=3 +-> NIL +</code></pre> + +<dt><a name="retract/1"><code>retract/1</code></a> +<dd><a href="ref.html#pilog">Pilog</a> predicate that removes a fact or rule. +See also <code><a href="refR.html#retract">retract</a></code>, <code><a +href="refA.html#asserta/1">asserta/1</a></code> and <code><a +href="refA.html#assertz/1">assertz/1</a></code>. + +<pre><code> +: (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 +</code></pre> + +<dt><a name="reverse"><code>(reverse 'lst) -> lst</code></a> +<dd>Returns a reversed copy of <code>lst</code>. See also <code><a +href="refF.html#flip">flip</a></code>. + +<pre><code> +: (reverse (1 2 3 4)) +-> (4 3 2 1) +</code></pre> + +<dt><a name="rewind"><code>(rewind) -> flg</code></a> +<dd>Sets the file position indicator for the current output stream to the +beginning of the file, and truncates the file length to zero. Returns +<code>T</code> when successful. See also <code><a +href="refF.html#flush">flush</a></code>. + +<pre><code> +: (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) +</code></pre> + +<dt><a name="rollback"><code>(rollback) -> T</code></a> +<dd>Cancels a transaction, by discarding all modifications of external symbols. +See also <code><a href="refC.html#commit">commit</a></code>. + +<pre><code> +: (pool "db") +-> T +# .. Modify external objects .. +: (rollback) # Rollback +-> T +</code></pre> + +<dt><a name="root"><code>(root 'tree) -> (num . sym)</code></a> +<dd>Returns the root of a database index tree, with the number of entries in +<code>num</code>, and the base node in <code>sym</code>. See also <code><a +href="refT.html#tree">tree</a></code>. + +<pre><code> +: (root (tree 'nr '+Item)) +-> (7 . {7-1}) +</code></pre> + +<dt><a name="rot"><code>(rot 'lst ['cnt]) -> lst</code></a> +<dd>Rotate: The contents of the cells of <code>lst</code> are (destructively) +shifted right, and the value from the last cell is stored in the first cell. +Without the optional <code>cnt</code> argument, the whole list is rotated, +otherwise only the first <code>cnt</code> elements. See also <code><a +href="refF.html#flip">flip</a></code> . + +<pre><code> +: (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) +</code></pre> + +<dt><a name="rpc"><code>(rpc 'sym ['any ..]) -> flg</code></a> +<dd><i>Rapid</i> (or <i>remote</i>) procedure call: Send an executable list +<code>(sym any ..)</code> via standard output in encoded binary format. See also +<code><a href="refP.html#pr">pr</a></code>, <code><a +href="refP.html#pipe">pipe</a></code>, <code><a +href="refT.html#tell">tell</a></code> and <code><a +href="refH.html#hear">hear</a></code>. + +<pre><code> +: (hear (pipe (do 3 (wait 2000) (rpc 'println ''OK)))) +-> 3 +: OK # every two seconds +OK +OK +</code></pre> + +<dt><a name="rules"><code>(rules 'sym ..) -> sym</code></a> +<dd>Prints all rules defined for the <code>sym</code> arguments. See also <a +href="ref.html#pilog">Pilog</a> and <code><a href="refB.html#be">be</a></code>. + +<pre><code> +: (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 +</code></pre> + +<dt><a name="run"><code>(run 'any ['cnt ['lst]]) -> any</code></a> +<dd>If <code>any</code> is an atom, <code>run</code> behaves like +<code>eval</code>. Otherwise <code>any</code> is a list, which is evaluated in +sequence. The last result is returned. If a binding environment offset +<code>cnt</code> is given, that evaluation takes place in the corresponding +environment, and an optional <code>lst</code> of excluded symbols can be +supplied. See also <code><a href="refE.html#eval">eval</a></code> and <code><a +href="refU.html#up">up</a></code>. + +<pre><code> +: (run '((println (+ 1 2 3)) (println 'OK))) +6 +OK +-> OK +</code></pre> + +</dl> + +</body> +</html> diff --git a/doc/refS.html b/doc/refS.html @@ -0,0 +1,870 @@ +<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.0 Transitional//EN" "http://www.w3.org/TR/1998/REC-html40-19980424/loose.dtd"> +<html lang="en"> +<head> +<meta http-equiv="Content-Type" content="text/html; charset=utf-8"> +<title>S</title> +<link rel="stylesheet" href="doc.css" type="text/css"> +</head> +<body> + +<h1>S</h1> + +<dl> + +<dt><a name="*Scl"><code>*Scl</code></a> +<dd>A global variable holding the current fixed-point input scale. See also <a +href="ref.html#num-io">Numbers</a> and <code><a +href="refS.html#scl">scl</a></code>. + +<pre><code> +: (str "123.45") # Default value of '*Scl' is 0 +-> (123) +: (setq *Scl 3) +-> 3 +: (str "123.45") +-> (123450) +</code></pre> + +<dt><a name="*Sig1"><code>*Sig1</code></a> +<dt><a name="*Sig2"><code>*Sig2</code></a> +<dd>Global variables holding (possibly empty) <code>prg</code> bodies, which +will be executed when a SIGUSR1 signal (or a SIGUSR2 signal, respectively) is +sent to the current process. Note that this mechanism is "unreliable", in the +way that when a second signal (it may be SIGHUP, SIGINT, another SIGUSR1/2, +SIGALRM or SIGTERM) arrives before the first signal's <code>prg</code> is +running, the first signal will be lost. See also <code><a +href="refA.html#alarm">alarm</a></code>, <code><a +href="refR.html#*Run">*Run</a></code>, <code><a +href="refH.html#*Hup">*Hup</a></code> and <code><a +href="refE.html#*Err">*Err</a></code>. + +<pre><code> +: (de *Sig1 (msg 'SIGUSR1)) +-> *Sig1 +</code></pre> + +<dt><a name="*Solo"><code>*Solo</code></a> +<dd>A global variable indicating exclusive database access. Its value is +<code>0</code> initially, set to <code>T</code> (or <code>NIL</code>) during +cooperative database locks when <code><a href="refL.html#lock">lock</a></code> +is successfully called with a <code>NIL</code> (or non-<code>NIL</code>) +argument. See also <code><a href="refZ.html#*Zap">*Zap</a></code>. + +<pre><code> +: *Solo +-> 0 +: (lock *DB) +-> NIL +: *Solo +-> NIL +: (rollback) +-> T +: *Solo +-> 0 +: (lock) +-> NIL +: *Solo +-> T +: (rollback) +-> T +: *Solo +-> T +</code></pre> + +<dt><a name="+Sn"><code>+Sn</code></a> +<dd>Prefix class for maintaining indexes according to a modified soundex +algorithm, for tolerant name searches, to <code><a +href="refS.html#+String">+String</a></code> relations. Typically used in +combination with the <code><a href="refI.html#+Idx">+Idx</a></code> prefix +class. See also <code><a href="ref.html#dbase">Database</a></code>. + +<pre><code> +(rel nm (+Sn +Idx +String)) # Name +</code></pre> + +<dt><a name="+String"><code>+String</code></a> +<dd>Class for string (transient symbol) relations, a subclass of <code><a +href="refS.html#+Symbol">+Symbol</a></code>. Accepts an optional argument for +the string length (currently not used). See also <code><a +href="ref.html#dbase">Database</a></code>. + +<pre><code> +(rel nm (+Sn +Idx +String)) # Name, indexed by soundex and substrings +</code></pre> + +<dt><a name="+Symbol"><code>+Symbol</code></a> +<dd>Class for symbolic relations, a subclass of <code><a +href="refR.html#+relation">+relation</a></code>. Objects of that class typically +maintain internal symbols, as opposed to the more often-used <code><a +href="refS.html#+String">+String</a></code> for transient symbols. See also +<code><a href="ref.html#dbase">Database</a></code>. + +<pre><code> +(rel perm (+List +Symbol)) # Permission list +</code></pre> + +<dt><a name="same/3"><code>same/3</code></a> +<dd><a href="ref.html#pilog">Pilog</a> predicate that succeeds if the first +argument matches the result of applying the <code><a +href="refG.html#get">get</a></code> algorithm to the following arguments. +Typically used as filter predicate in <code><a +href="refS.html#select/3">select/3</a></code> database queries. See also +<code><a href="refI.html#isa/2">isa/2</a></code>, <code><a +href="refB.html#bool/3">bool/3</a></code>, <code><a +href="refR.html#range/3">range/3</a></code>, <code><a +href="refH.html#head/3">head/3</a></code>, <code><a +href="refF.html#fold/3">fold/3</a></code>, <code><a +href="refP.html#part/3">part/3</a></code> and <code><a +href="refT.html#tolr/3">tolr/3</a></code>. + +<pre><code> +: (? + @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={3-2} +</code></pre> + +<dt><a name="scan"><code>(scan 'tree ['fun] ['any1] ['any2] ['flg])</code></a> +<dd>Scans through a database tree by applying <code>fun</code> to all key-value +pairs. <code>fun</code> should be a function accepting two arguments for key and +value. It defaults to <code><a href="refP.html#println">println</a></code>. +<code>any1</code> and <code>any2</code> may specify a range of keys. If +<code>any2</code> is greater than <code>any1</code>, the traversal will be in +opposite direction. If <code>flg</code> is non-<code>NIL</code>, partial keys +are skipped. See also <code><a href="refT.html#tree">tree</a></code>, <code><a +href="refI.html#iter">iter</a></code>, <code><a +href="refI.html#init">init</a></code> and <code><a +href="refS.html#step">step</a></code>. + +<pre><code> +: (scan (tree 'nm '+Item)) +("ASLRSNSTRSTN" {3-3} . T) {3-3} +("Additive" {3-4}) {3-4} +("Appliance" {3-6}) {3-6} +("Auxiliary Construction" . {3-3}) {3-3} +("Construction" {3-3}) {3-3} +("ENNSNNTTTF" {3-4} . T) {3-4} +("Enhancement Additive" . {3-4}) {3-4} +("Fittings" {3-5}) {3-5} +("GTSTFLNS" {3-6} . T) {3-6} +("Gadget Appliance" . {3-6}) {3-6} +... + +: (scan (tree 'nm '+Item) println NIL T T) # 'flg' is non-NIL +("Auxiliary Construction" . {3-3}) {3-3} +("Enhancement Additive" . {3-4}) {3-4} +("Gadget Appliance" . {3-6}) {3-6} +("Main Part" . {3-1}) {3-1} +("Metal Fittings" . {3-5}) {3-5} +("Spare Part" . {3-2}) {3-2} +("Testartikel" . {3-8}) {3-8} +-> {7-6} +</code></pre> + +<dt><a name="scl"><code>(scl 'num) -> num</code></a> +<dd>Sets <code><a href="refS.html#*Scl">*Scl</a></code> globally to +<code>num</code>. See also <a href="ref.html#num-io">Numbers</a>. + +<pre><code> +: (scl 0) +-> 0 +: (str "123.45") +-> (123) +: (scl 1) +-> 1 +: (read) +123.45 +-> 1235 +: (scl 3) +-> 3 +: (str "123.45") +-> (123450) +</code></pre> + +<dt><a name="script"><code>(script 'any ..) -> any</code></a> +<dd>The first <code>any</code> argument is <code><a +href="refL.html#load">load</a></code>ed, with the remaining arguments <code><a +href="refP.html#pass">pass</a></code>ed as variable arguments. They can be +accessed with <code><a href="refN.html#next">next</a></code>, <code><a +href="refA.html#arg">arg</a></code>, <code><a +href="refA.html#args">args</a></code> and <code><a +href="refR.html#rest">rest</a></code>. + +<pre><code> +$ cat x +(* (next) (next)) + +$ ./dbg +: (script "x" 3 4) +-> 12 +</code></pre> + +<dt><a name="sect"><code>(sect 'lst 'lst) -> lst</code></a> +<dd>Returns the intersection of the <code>lst</code> arguments. See also +<code><a href="refD.html#diff">diff</a></code>. + +<pre><code> +: (sect (1 2 3 4) (3 4 5 6)) +-> (3 4) +: (sect (1 2 3) (4 5 6)) +-> NIL +</code></pre> + +<dt><a name="seed"><code>(seed 'any) -> cnt</code></a> +<dd>Initializes the random generator's seed, and returns a pseudo random number +in the range -2147483648 .. +2147483647. See also <code><a +href="refR.html#rand">rand</a></code>. + +<pre><code> +: (seed "init string") +-> 2015582081 +: (rand) +-> -706917003 +: (rand) +-> 1224196082 + +: (seed (time)) +-> 128285383 +</code></pre> + +<dt><a name="seek"><code>(seek 'fun 'lst ..) -> lst</code></a> +<dd>Applies <code>fun</code> to <code>lst</code> and all successive CDRs, until +non-<code>NIL</code> is returned. Returns the tail of <code>lst</code> starting +with that element, or <code>NIL</code> if <code>fun</code> did not return +non-<code>NIL</code> for any element of <code>lst</code>. When additional +<code>lst</code> arguments are given, they are passed to <code>fun</code> in the +same way. See also <code><a href="refF.html#find">find</a></code>, <code><a +href="refP.html#pick">pick</a></code>. + +<pre><code> +: (seek '((X) (> (car X) 9)) (1 5 8 12 19 22)) +-> (12 19 22) +</code></pre> + +<dt><a name="select"><code>(select [var ..] cls [hook|T] [var val ..]) -> obj | NIL</code></a> +<dd>Interactive database function, loosely modelled after the SQL +'<code>SELECT</code>' command. A (limited) front-end to the Pilog <code><a +href="refS.html#select/3">select/3</a></code> predicate. When called with only a +<code>cls</code> argument, <code>select</code> steps through all objects of that +class, and <code><a href="refS.html#show">show</a></code>s their complete +contents (this is analog to 'SELECT * from CLS'). If <code>cls</code> is +followed by attribute/value specifications, the search is limited to these +values (this is analog to 'SELECT * from CLS where VAR = VAL'). If between the +<code>select</code> function and <code>cls</code> one or several attribute names +are supplied, only these attribute (instead of the full <code>show</code>) are +printed. These attribute specifications may also be lists, then the <code><a +href="refG.html#get">get</a></code> algorithm will be used to retrieve related +data. See also <code><a href="refU.html#update">update</a></code>, <code><a +href="ref.html#dbase">Database</a></code> and <a +href="ref.html#pilog">Pilog</a>. + +<pre><code> +: (select +Item) # Show all items +{3-1} (+Item) + nr 1 + pr 29900 + inv 100 + sup {2-1} + nm "Main Part" + +{3-2} (+Item) + nr 2 + pr 1250 + inv 100 + sup {2-2} + nm "Spare Part" +. # Stop +-> {3-2} + +: (select +Item nr 3) # Show only item 3 +{3-3} (+Item) + nr 3 + sup {2-1} + pr 15700 + nm "Auxiliary Construction" + inv 100 +. # Stop +-> {3-3} + +# 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." {3-3} +4 "Enhancement Additive" 9.99 "Seven Oaks Ltd." {3-4} +5 "Metal Fittings" 79.80 "Active Parts Inc." {3-5} +-> NIL +</code></pre> + +<dt><a name="select/3"><code>select/3</code></a> +<dd><a href="ref.html#pilog">Pilog</a> database predicate that allows combined +searches over <code><a href="refI.html#+index">+index</a></code> 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 <a href="select.html">The 'select' Predicate</a>. See also <code><a +href="refD.html#db/3">db/3</a></code>, <code><a +href="refI.html#isa/2">isa/2</a></code>, <code><a +href="refS.html#same/3">same/3</a></code>, <code><a +href="refB.html#bool/3">bool/3</a></code>, <code><a +href="refR.html#range/3">range/3</a></code>, <code><a +href="refH.html#head/3">head/3</a></code>, <code><a +href="refF.html#fold/3">fold/3</a></code>, <code><a +href="refP.html#part/3">part/3</a></code>, <code><a +href="refT.html#tolr/3">tolr/3</a></code> and <code><a +href="refR.html#remote/2">remote/2</a></code>. + +<pre><code> +: (? + @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={3-3} + @Nr=(2 . 5) @Sup="Active" @Item={3-5} +-> NIL +</code></pre> + +<dt><a name="send"><code>(send 'msg 'obj ['any ..]) -> any</code></a> +<dd>Sends the message <code>msg</code> to the object <code>obj</code>, +optionally with arguments <code>any</code>. If the message cannot be located in +<code>obj</code>, its classes and superclasses, an error <code>"Bad +message"</code> is issued. See also <code><a href="ref.html#oop">OO +Concepts</a></code>, <code><a href="refT.html#try">try</a></code>, <code><a +href="refM.html#method">method</a></code>, <code><a +href="refM.html#meth">meth</a></code>, <code><a +href="refS.html#super">super</a></code> and <code><a +href="refE.html#extra">extra</a></code>. + +<pre><code> +: (send 'stop> Dlg) # Equivalent to (stop> Dlg) +-> NIL +</code></pre> + +<dt><a name="seq"><code>(seq 'cnt|sym1) -> sym | NIL</code></a> +<dd>Sequential single step: Returns the <i>first</i> external symbol in the +<code>cnt</code>'th database file, or the <i>next</i> external symbol following +<code>sym1</code> in the database, or <code>NIL</code> when the end of the +database is reached. See also <code><a href="refF.html#free">free</a></code>. + +<pre><code> +: (pool "db") +-> T +: (seq *DB) +-> {2} +: (seq @) +-> {3} +</code></pre> + +<dt><a name="set"><code>(set 'var 'any ..) -> any</code></a> +<dd>Stores new values <code>any</code> in the <code>var</code> arguments. See +also <code><a href="refS.html#setq">setq</a></code>, <code><a +href="refV.html#val">val</a></code>, <code><a +href="refC.html#con">con</a></code> and <code><a +href="refD.html#def">def</a></code>. + +<pre><code> +: (set 'L '(a b c) (cdr L) '999) +-> 999 +: L +-> (a 999 c) +</code></pre> + +<dt><a name="set!"><code>(set! 'obj 'any) -> any</code></a> +<dd><a href="ref.html#trans">Transaction</a> wrapper function for <code><a +href="refS.html#set">set</a></code>. Note that for setting the value of entities +typically the <code><a href="refE.html#entityMesssages">set!></a></code> message +is used. See also <code><a href="refN.html#new!">new!</a></code>, <code><a +href="refP.html#put!">put!</a></code> and <code><a +href="refI.html#inc!">inc!</a></code>. + +<pre><code> +(set! Obj (* Count Size)) # Setting a non-entity object to a numeric value +</code></pre> + +<dt><a name="setq"><code>(setq var 'any ..) -> any</code></a> +<dd>Stores new values <code>any</code> in the <code>var</code> arguments. See +also <code><a href="refS.html#set">set</a></code>, <code><a +href="refV.html#val">val</a></code> and <code><a +href="refD.html#def">def</a></code>. + +<pre><code> +: (setq A 123 B (list A A)) # Set 'A' to 123, then 'B' to (123 123) +-> (123 123) +</code></pre> + +<dt><a name="show"><code>(show 'any ['sym|cnt ..]) -> any</code></a> +<dd>Shows the name, value and property list of a symbol found by applying the +<code><a href="refG.html#get">get</a></code> algorithm to <code>any</code> and +the following arguments. See also <code><a href="refE.html#edit">edit</a></code> +and <code><a href="refV.html#view">view</a></code>. + +<pre><code> +: (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 +</code></pre> + +<dt><a name="show/1"><code>show/1</code></a> +<dd><a href="ref.html#pilog">Pilog</a> predicate that always succeeds, and shows +the name, value and property list of the argument symbol. See also <code><a +href="refS.html#show">show</a></code>. + +<pre><code> +: (? (db nr +Item 2 @Item) (show @Item)) +{3-2} (+Item) + nm "Spare Part" + nr 2 + pr 1250 + inv 100 + sup {2-2} + @Item={3-2} +-> NIL +</code></pre> + +<dt><a name="size"><code>(size 'any) -> cnt</code></a> +<dd>Returns the "size" of <code>any</code>. 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 in 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 <code><a +href="refL.html#length">length</a></code>. + +<pre><code> +: (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 +</code></pre> + +<dt><a name="skip"><code>(skip ['any]) -> sym</code></a> +<dd>Skips all white space (and comments if <code>any</code> is given) in the +input stream. Returns the next available character, or <code>NIL</code> upon end +of file. See also <code><a href="refP.html#peek">peek</a></code> and <code><a +href="refE.html#eof">eof</a></code>. + +<pre><code> +$ cat a +# Comment +abcd +$ ./dbg +: (in "a" (skip "#")) +-> "a" +</code></pre> + +<dt><a name="solve"><code>(solve 'lst [. prg]) -> lst</code></a> +<dd>Evaluates a <a href="ref.html#pilog">Pilog</a> query and, returns the list +of result sets. If <code>prg</code> 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 <code><a href="refP.html#pilog">pilog</a></code>, +<code><a href="ref_.html#?">?</a></code>, <code><a +href="refG.html#goal">goal</a></code> and <code><a +href="refP.html#prove">prove</a></code>. + +<pre><code> +: (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)) +</code></pre> + +<dt><a name="sort"><code>(sort 'lst ['fun]) -> lst</code></a> +<dd>Sorts <code>lst</code> by destructively exchanging its elements. If +<code>fun</code> is given, it is used as a "less than" predicate for +comparisons. Typically, <code>sort</code> is used in combination with <a +href="refB.html#by">by</a>, giving shorter and often more efficient solutions +than with the predicate function. See also <a href="ref.html#cmp">Comparing</a>, +<code><a href="refG.html#group">group</a></code>, <code><a +href="refM.html#maxi">maxi</a></code>, <code><a +href="refM.html#mini">mini</a></code> and <code><a +href="refU.html#uniq">uniq</a></code>. + +<pre><code> +: (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)) +</code></pre> + +<dt><a name="space"><code>(space ['cnt]) -> cnt</code></a> +<dd>Prints <code>cnt</code> spaces, or a single space when <code>cnt</code> is +not given. + +<pre><code> +: (space) + -> 1 +: (space 1) + -> 1 +: (space 2) + -> 2 +</code></pre> + +<dt><a name="sp?"><code>(sp? 'any) -> flg</code></a> +<dd>Returns <code>T</code> when the argument <code>any</code> is +<code>NIL</code>, or if it is a string (symbol) that consists only of whitespace +characters. + +<pre><code> +: (sp? " ") +-> T +: (sp? "ABC") +-> NIL +: (sp? 123) +-> NIL +</code></pre> + +<dt><a name="split"><code>(split 'lst 'any ..) -> lst</code></a> +<dd>Splits <code>lst</code> at all places containing an element <code>any</code> +and returns the resulting list of sublists. See also <code><a +href="refS.html#stem">stem</a></code>. + +<pre><code> +: (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") +</code></pre> + +<dt><a name="sqrt"><code>(sqrt 'num) -> num</code></a> +<dd>Returns the square root of the <code>num</code> argument. + +<pre><code> +: (sqrt 64) +-> 8 +: (sqrt 1000) +-> 31 +: (sqrt 10000000000000000000000000000000000000000) +-> 100000000000000000000 +</code></pre> + +<dt><a name="stamp"><code>(stamp ['dat 'tim]) -> sym</code></a> +<dd>Returns a date-time string in the form "YYYY-MM-DD HH:MM:SS". If +<code>dat</code> and/or <code>tim</code> is missing, the current date or time is +used. See also <code><a href="refD.html#date">date</a></code> and <code><a +href="refT.html#time">time</a></code>. + +<pre><code> +: (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" +</code></pre> + +<dt><a name="state"><code>(state 'var (sym|lst exe [. prg]) ..) -> any</code></a> +<dd>Implements a finite state machine. The variable <code>var</code> holds the +current state as a symbolic value. When a clause is found that contains the +current state in its CAR <code>sym|lst</code> value, and where the +<code>exe</code> in its CADR evaluates to non-<code>NIL</code>, the current +state will be set to that value, the body <code>prg</code> in the CDDR will be +executed, and the result returned. <code>T</code> is a catch-all for any state. +If no state-condition matches, <code>NIL</code> is returned. See also <code><a +href="refC.html#case">case</a></code>, <code><a +href="refC.html#cond">cond</a></code> and <code><a +href="refJ.html#job">job</a></code>. + +<pre><code> +: (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 +</code></pre> + +<dt><a name="stem"><code>(stem 'lst 'any ..) -> lst</code></a> +<dd>Returns the tail of <code>lst</code> that does not contain any of the +<code>any</code> arguments. <code>(stem 'lst 'any ..)</code> is equivalent to +<code>(last (split 'lst 'any ..))</code>. See also <code><a +href="refT.html#tail">tail</a></code> and <code><a +href="refS.html#split">split</a></code>. + +<pre><code> +: (stem (chop "abc/def\\ghi") "/" "\\") +-> ("g" "h" "i") +</code></pre> + +<dt><a name="step"><code>(step 'lst ['flg]) -> any</code></a> +<dd>Single-steps iteratively through a database tree. <code>lst</code> is a +structure as received from <code><a href="refI.html#init">init</a></code>. If +<code>flg</code> is non-<code>NIL</code>, partial keys are skipped. See also +<code><a href="refT.html#tree">tree</a></code>, <code><a +href="refL.html#leaf">leaf</a></code> and <code><a +href="refF.html#fetch">fetch</a></code>. + +<pre><code> +: (setq Q (init (tree 'nr '+Item) 3 5)) +-> (((3 . 5) ((3 NIL . {3-3}) (4 NIL . {3-4}) (5 NIL . {3-5}) (6 NIL . {3-6}) (7 NIL . {3-8})))) +: (get (step Q) 'nr) +-> 3 +: (get (step Q) 'nr) +-> 4 +: (get (step Q) 'nr) +-> 5 +: (get (step Q) 'nr) +-> NIL +</code></pre> + +<dt><a name="store"><code>(store 'tree 'any1 'any2 ['(num1 . num2)])</code></a> +<dd>Stores a value <code>any2</code> for the key <code>any1</code> in a database +tree. <code>num1</code> is a database file number, as used in <code><a +href="refN.html#new">new</a></code> (defaulting to 1), and <code>num2</code> a +database block size (defaulting to 256). When <code>any2</code> is +<code>NIL</code>, the corresponding entry is deleted from the tree. See also +<code><a href="refT.html#tree">tree</a></code> and <code><a +href="refF.html#fetch">fetch</a></code>. + +<pre><code> +: (store (tree 'nr '+Item) 2 '{3-2}) +</code></pre> + +<dt><a name="str"><code>(str 'sym ['sym1]) -> lst</code></a> +<dt><code>(str 'lst) -> sym</code> +<dd>In the first form, the string <code>sym</code> is parsed into a list. This +mechanism is also used by <code><a href="refL.html#load">load</a></code>. If +<code>sym1</code> is given, it should specify a set of characters, and +<code>str</code> will then return a list of tokens analog to <code><a +href="refR.html#read">read</a></code>. The second form does the reverse +operation by building a string from a list. See also <code><a +href="refA.html#any">any</a></code>, <code><a +href="refN.html#name">name</a></code> and <code><a +href="refS.html#sym">sym</a></code>. + +<pre><code> +: (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) +</code></pre> + +<dt><a name="strDat"><code>(strDat 'sym) -> dat</code></a> +<dd>Converts a string <code>sym</code> in the date format of the current +<code><a href="refL.html#locale">locale</a></code> to a <code><a +href="refD.html#date">date</a></code>. See also <code><a +href="refE.html#expDat">expDat</a></code>, <code><a +href="ref_.html#$dat">$dat</a></code> and <code><a +href="refD.html#datStr">datStr</a></code>. + +<pre><code> +: (strDat "2007-06-01") +-> 733134 +: (strDat "01.06.2007") +-> NIL +: (locale "DE" "de") +-> NIL +: (strDat "01.06.2007") +-> 733134 +: (strDat "1.6.2007") +-> 733134 +</code></pre> + +<dt><a name="strip"><code>(strip 'any) -> any</code></a> +<dd>Strips all leading <code>quote</code> symbols from <code>any</code>. + +<pre><code> +: (strip 123) +-> 123 +: (strip '''(a)) +-> (a) +: (strip (quote quote a b c)) +-> (a b c) +</code></pre> + +<dt><a name="str?"><code>(str? 'any) -> sym | NIL</code></a> +<dd>Returns the argument <code>any</code> when it is a transient symbol +(string), otherwise <code>NIL</code>. See also <code><a +href="refS.html#sym?">sym?</a></code>, <code><a +href="refB.html#box?">box?</a></code> and <code><a +href="refE.html#ext?">ext?</a></code>. + +<pre><code> +: (str? 123) +-> NIL +: (str? '{ABC}) +-> NIL +: (str? 'abc) +-> NIL +: (str? "abc") +-> "abc" +</code></pre> + +<dt><a name="sub?"><code>(sub? 'any1 'any2) -> any2 | NIL</code></a> +<dd>Returns <code>any2</code> when the string representation of +<code>sym1</code> is a substring of the string representation of +<code>sym2</code>. See also <code><a href="refP.html#pre?">pre?</a></code>. + +<pre><code> +: (sub? "def" "abcdef") +-> T +: (sub? "abb" "abcdef") +-> NIL +: (sub? NIL "abcdef") +-> T +</code></pre> + +<dt><a name="subr"><code>(subr 'sym) -> num</code></a> +<dd>Converts a Lisp-function that was previously converted with <code><a +href="refE.html#expr">expr</a></code> back to a C-function. + +<pre><code> +: car +-> 67313448 +: (expr 'car) +-> (@ (pass $385260187)) +: (subr 'car) +-> 67313448 +: car +-> 67313448 +</code></pre> + +<dt><a name="sum"><code>(sum 'fun 'lst ..) -> num</code></a> +<dd>Applies <code>fun</code> to each element of <code>lst</code>. When +additional <code>lst</code> arguments are given, their elements are also passed +to <code>fun</code>. Returns the sum of all numeric values returned from +<code>fun</code>. + +<pre><code> +: (setq A 1 B 2 C 3) +-> 3 +: (sum val '(A B C)) +-> 6 +: (sum # Total size of symbol list values + '((X) + (and (pair (val X)) (size @)) ) + (what) ) +-> 32021 +</code></pre> + +<dt><a name="super"><code>(super ['any ..]) -> any</code></a> +<dd>Can only be used inside methods. Sends the current message to the current +object <code>This</code>, this time starting the search for a method at the +superclass(es) of the class where the current method was found. See also +<code><a href="ref.html#oop">OO Concepts</a></code>, <code><a +href="refE.html#extra">extra</a></code>, <code><a +href="refM.html#method">method</a></code>, <code><a +href="refM.html#meth">meth</a></code>, <code><a +href="refS.html#send">send</a></code> and <code><a +href="refT.html#try">try</a></code>. + +<pre><code> +(dm stop> () # 'stop>' method of current class + (super) # Call the 'stop>' method of the superclass + ... ) # other things +</code></pre> + +<dt><a name="sym"><code>(sym 'any) -> sym</code></a> +<dd>Generate the printed representation of <code>any</code> into the name of a +new symbol <code>sym</code>. This is the reverse operation of <code><a +href="refA.html#any">any</a></code>. See also <code><a +href="refN.html#name">name</a></code> and <code><a +href="refS.html#str">str</a></code>. + +<pre><code> +: (sym '(abc "Hello" 123)) +-> "(abc \"Hello\" 123)" +</code></pre> + +<dt><a name="sym?"><code>(sym? 'any) -> flg</code></a> +<dd>Returns <code>T</code> when the argument <code>any</code> is a symbol. See +also <code><a href="refS.html#str?">str?</a></code>, <code><a +href="refB.html#box?">box?</a></code> and <code><a +href="refE.html#ext?">ext?</a></code>. + +<pre><code> +: (sym? 'a) +-> T +: (sym? NIL) +-> T +: (sym? 123) +-> NIL +: (sym? '(a b)) +-> NIL +</code></pre> + +<dt><a name="sync"><code>(sync) -> flg</code></a> +<dd>Waits for pending data from all family processes. While other processes are +still sending data (via the <code><a href="refT.html#tell">tell</a></code> +mechanism), a <code>select</code> system call is executed for all file +descriptors and timers in the <code>VAL</code> of the global variable <code><a +href="refR.html#*Run">*Run</a></code>. See also <code><a +href="refK.html#key">key</a></code> and <code><a +href="refW.html#wait">wait</a></code>. + +<pre><code> +: (or (lock) (sync)) # Ensure database consistency +-> T # (numeric process-id if lock failed) +</code></pre> + +<dt><a name="sys"><code>(sys 'any ['any]) -> sym</code></a> +<dd>Returns or sets a system environment variable. + +<pre><code> +: (sys "TERM") # Get current value +-> "xterm" +: (sys "TERM" "vt100") # Set new value +-> "vt100" +: (sys "TERM") +-> "vt100" +</code></pre> + +</dl> + +</body> +</html> diff --git a/doc/refT.html b/doc/refT.html @@ -0,0 +1,565 @@ +<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.0 Transitional//EN" "http://www.w3.org/TR/1998/REC-html40-19980424/loose.dtd"> +<html lang="en"> +<head> +<meta http-equiv="Content-Type" content="text/html; charset=utf-8"> +<title>T</title> +<link rel="stylesheet" href="doc.css" type="text/css"> +</head> +<body> + +<h1>T</h1> + +<dl> + +<dt><a name="*Tmp"><code>*Tmp</code></a> +<dd>A global variable holding the temporary directory name created with <code><a +href="refT.html#tmp">tmp</a></code>. See also <code><a +href="refB.html#*Bye">*Bye</a></code>. + +<pre><code> +: *Bye +-> ((saveHistory) (and *Tmp (call 'rm "-r" *Tmp))) +: (tmp "foo" 123) +-> "tmp/27140/foo123" +: *Tmp +-> "tmp/27140/" +</code></pre> + +<p><dt><a name="*Tsm"><code>*Tsm</code></a> +<dd>A global variable which may hold a cons pair of two strings with escape +sequences, to switch on and off an alternative transient symbol markup. If set, +<code><a href="refP.html#print">print</a></code> will output these sequences to +the console instead of the standard double quote markup characters. + +<pre><code> +: (de *Tsm "^[[4m" . "^[[24m") # vt100 escape sequences for underline +-> *Tsm +: <u>Hello world</u> +-> <u>Hello world</u> +: (off *Tsm) +-> NIL +: "Hello world" # No underlining +-> "Hello world" +</code></pre> + +<dt><a name="+Time"><code>+Time</code></a> +<dd>Class for clock time values (as calculated by <code><a +href="refT.html#time">time</a></code>), a subclass of <code><a +href="refN.html#+Number">+Number</a></code>. See also <code><a +href="ref.html#dbase">Database</a></code>. + +<pre><code> +(rel tim (+Time)) # Time of the day +</code></pre> + +<dt><a name="T"><code>T</code></a> +<dd>A global constant, evaluating to itself. <code>T</code> is commonly returned +as the boolean value "true" (though any non-<code>NIL</code> values could be +used). As a property key, it is used to store <a href="ref.html#pilog">Pilog</a> +clauses, and inside Pilog clauses it is the <i>cut</i> operator. See also +<code><a href="ref.html#nilSym">NIL</a></code>. + +<pre><code> +: T +-> T +: (= 123 123) +-> T +: (get 'not T) +-> ((@P (1 -> @P) T (fail)) (@P)) +</code></pre> + +<dt><a name="This"><code>This</code></a> +<dd>Holds the current object during method execution (see <a +href="ref.html#oop">OO Concepts</a>), or inside the body of a <code><a +href="refW.html#with">with</a></code> statement. As it is a normal symbol, +however, it can be used in normal bindings anywhere. See also <code><a +href="refI.html#isa">isa</a></code>, <code><a href="ref_.html#:">:</a></code>, +<code><a href="ref_.html#=:">=:</a></code>, <code><a +href="ref_.html#::">::</a></code> and <code><a +href="refV.html#var:">var:</a></code>. + +<pre><code> +: (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)) +</code></pre> + +<dt><a name="t"><code>(t . prg) -> T</code></a> +<dd>Executes <code>prg</code>, and returns <code>T</code>. See also <code><a +href="refN.html#nil">nil</a></code>, <code><a +href="refP.html#prog">prog</a></code>, <code><a +href="refP.html#prog1">prog1</a></code> and <code><a +href="refP.html#prog2">prog2</a></code>. + +<pre><code> +: (t (println 'OK)) +OK +-> T +</code></pre> + +<dt><a name="tab"><code>(tab 'lst 'any ..) -> NIL</code></a> +<dd>Print all <code>any</code> arguments in a tabular format. <code>lst</code> +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 <code><a href="refA.html#align">align</a></code>, +<code><a href="refC.html#center">center</a></code> and <code><a +href="refW.html#wrap">wrap</a></code>. + +<pre><code> +: (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 +</code></pre> + +<dt><a name="tail"><code>(tail 'cnt|lst 'lst) -> lst</code></a> +<dd>Returns the last <code>cnt</code> elements of <code>lst</code>. If +<code>cnt</code> is negative, it is added to the length of <code>lst</code>. If +the first argument is a <code>lst</code>, <code>tail</code> is a predicate +function returning that argument list if it is <code>equal</code> to the tail of +the second argument, and <code>NIL</code> otherwise. <code>(tail -2 Lst)</code> +is equivalent to <code>(nth Lst 3)</code>. See also <code><a +href="refH.html#head">head</a></code>, <code><a +href="refL.html#last">last</a></code> and <code><a +href="refS.html#stem">stem</a></code>. + +<pre><code> +: (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) +</code></pre> + +<dt><a name="task"><code>(task 'num ['num] [sym 'any ..] [. prg]) -> lst</code></a> +<dd>A front-end to the <code><a href="refR.html#*Run">*Run</a></code> global. If +called with only a single <code>num</code> argument, the corresponding entry is +removed from the value of <code>*Run</code>. 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 <code>sym</code>/<code>any</code> +arguments are given, a <code><a href="refJ.html#job">job</a></code> environment +is built for thie <code>*Run</code> entry. See also <code><a +href="refF.html#forked">forked</a></code> and <code><a +href="refT.html#timeout">timeout</a></code>. + +<pre><code> +: (task -10000 5000 N 0 (msg (inc 'N))) # Install task +-> (-10000 5000 (job '((N . 0)) (msg (inc 'N)))) # for every 10 seconds +: 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) +</code></pre> + +<dt><a name="telStr"><code>(telStr 'sym) -> sym</code></a> +<dd>Formats a telephone number according to the current <code><a +href="refL.html#locale">locale</a></code>. If the string head matches the local +country code, it is replaced with <code>0</code>, otherwise <code>+</code> is +prepended. See also <code><a href="refE.html#expTel">expTel</a></code>, <code><a +href="refD.html#datStr">datStr</a></code>, <code><a +href="refM.html#money">money</a></code> and <code><a +href="refF.html#format">format</a></code>. + +<pre><code> +: (telStr "49 1234 5678-0") +-> "+49 1234 5678-0" +: (locale "DE" "de") +-> NIL +: (telStr "49 1234 5678-0") +-> "01234 5678-0" +</code></pre> + +<dt><a name="tell"><code>(tell 'sym ['any ..]) -> any</code></a> +<dd>Family IPC: Send an executable list <code>(sym any ..)</code> to all family +members (i.e. all children of the current process, and all other children of the +parent process, see <code><a href="refF.html#fork">fork</a></code>) for +automatic execution. <code>tell</code> can also be used by <code><a +href="refC.html#commit">commit</a></code> to notify about database changes. See +also <code><a href="refH.html#hear">hear</a></code>, <code><a +href="refP.html#pid">pid</a></code> and <code><a +href="refR.html#rpc">rpc</a></code>. + +<pre><code> +: (call 'ps "x") # Show processes + PID TTY STAT TIME COMMAND + .. + 1321 pts/0 S 0:00 bin/picolisp .. # Parent process + 1324 pts/0 S 0:01 bin/picolisp .. # First child + 1325 pts/0 S 0:01 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 +</code></pre> + +<dt><a name="test"><code>(test 'any . prg)</code></a> +<dd>Executes <code>prg</code>, and issues an <code><a +href="ref.html#errors">error</a></code> if the result does not <code><a +href="refM.html#match">match</a></code> the <code>any</code> argument. + +<pre><code> +: (test 12 (* 3 4)) +-> NIL +: (test 12 (+ 3 4)) +((+ 3 4)) +12 -- fail +? +</code></pre> + +<dt><a name="text"><code>(text 'any1 'any ..) -> sym</code></a> +<dd>Builds a new transient symbol (string) from the string representation of +<code>any1</code>, by replacing all occurrences of an at-mark "<code>@</code>", +followed by one of the letters "<code>1</code>" through "<code>9</code>", and +"<code>A</code>" through "<code>Z</code>", with the corresponding +<code>any</code> argument. In this context "<code>@A</code>" refers to the 10th +argument. A literal at-mark in the text can be represented by two successive +at-marks. See also <code><a href="refP.html#pack">pack</a></code> and <code><a +href="refG.html#glue">glue</a></code>. + +<pre><code> +: (text "abc @1 def @2" 'XYZ 123) +-> "abc XYZ def 123" +: (text "a@@bc.@1" "de") +-> "a@bc.de" +</code></pre> + +<dt><a name="tim$"><code>(tim$ 'tim ['flg]) -> sym</code></a> +<dd>Formats a <code><a href="refT.html#time">time</a></code> <code>tim</code>. +If <code>flg</code> is <code>NIL</code>, the format is HH:MM, otherwise it is +HH:MM:SS. See also <code><a href="ref_.html#$tim">$tim</a></code> and <code><a +href="refD.html#dat$">dat$</a></code>. + +<pre><code> +: (tim$ (time)) +-> "10:57" +: (tim$ (time) T) +-> "10:57:56" +</code></pre> + +<dt><a name="timeout"><code>(timeout ['num])</code></a> +<dd>Sets or refreshes a timeout value in the <code><a +href="refR.html#*Run">*Run</a></code> global, so that the current process +executes <code><a href="refB.html#bye">bye</a></code> after the given period. If +called without arguments, the timeout is removed. See also <code><a +href="refT.html#task">task</a></code>. + +<pre><code> +: (timeout 3600000) # Timeout after one hour +-> (-1 3600000 (bye)) +: *Run # Look after a few seconds +-> ((-1 3574516 (bye))) +</code></pre> + +<dt><a name="throw"><code>(throw 'sym 'any)</code></a> +<dd>Non-local jump into a previous <code><a +href="refC.html#catch">catch</a></code> environment with the jump label +<code>sym</code> (or <code>T</code> as a catch-all). Any pending <code><a +href="refF.html#finally">finally</a></code> 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 <code>catch</code> was called. Then <code>any</code> is returned +from that <code>catch</code>. + +<pre><code> +: (de foo (N) + (println N) + (throw 'OK) ) +-> foo +: (let N 1 (catch 'OK (foo 7)) (println N)) +7 +1 +-> 1 +</code></pre> + +<dt><a name="tick"><code>(tick (cnt1 . cnt2) . prg) -> any</code></a> +<dd>Executes <code>prg</code>, then (destructively) adds the number of elapsed +user ticks to the <code>cnt1</code> parameter, and the number of elapsed system +ticks to the <code>cnt2</code> parameter. Thus, <code>cnt1</code> and +<code>cnt2</code> will finally contain the total number of user and system time +ticks spent in <code>prg</code> and all functions called (this works also for +recursive functions). For execution profiling, <code>tick</code> is usually +inserted into words with <code>prof</code>, and removed with +<code>unprof</code>. See also <code><a href="refU.html#usec">usec</a></code>. + +<pre><code> +: (de foo () # Define function with empty loop + (tick (0 . 0) (do 100000000)) ) +-> foo +: (foo) # Execute it +-> NIL +: (pp 'foo) +(de foo NIL + (tick (97 . 0) (do 100000000)) ) # 'tick' incremented 'cnt1' by 97 +-> foo +</code></pre> + +<dt><a name="till"><code>(till 'any ['flg]) -> lst|sym</code></a> +<dd>Reads from the current input channel till a character contained in +<code>any</code> is found (or until end of file if <code>any</code> is +<code>NIL</code>). If <code>flg</code> is <code>NIL</code>, a list of +single-character transient symbols is returned. Otherwise, a single string is +returned. See also <code><a href="refF.html#from">from</a></code> and <code><a +href="refL.html#line">line</a></code>. + +<pre><code> +: (till ":") +abc:def +-> ("a" "b" "c") +: (till ":" T) +abc:def +-> "abc" +</code></pre> + +<dt><a name="time"><code>(time ['T]) -> tim</code></a> +<dt><code>(time 'tim) -> (h m s)</code> +<dt><code>(time 'h 'm ['s]) -> tim | NIL</code> +<dt><code>(time '(h m [s])) -> tim | NIL</code> +<dd>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 <code>T</code> argument, the time of the last call to +<code><a href="refD.html#date">date</a></code> is returned. When called with a +single number <code>tim</code>, 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 <code>NIL</code> if +they do not represent a legal time). See also <code><a +href="refU.html#usec">usec</a></code>, <code><a +href="refT.html#tim$">tim$</a></code> and <code><a +href="ref_.html#$tim">$tim</a></code>. + +<pre><code> +: (time) # Now +-> 32334 +: (time 32334) # Now +-> (8 58 54) +: (time 25 30) # Illegal time +-> NIL +</code></pre> + +<dt><a name="tmp"><code>(tmp ['any ..]) -> sym</code></a> +<dd>Returns the path name to the <code><a +href="refP.html#pack">pack</a></code>ed <code>any</code> arguments in a +process-local temporary directory. The directory name consists of "tmp/" +followed by the current process ID <code><a +href="refP.html#*Pid">*Pid</a></code>. This directory is automatically created +if necessary, and removed upon termination of the process (<code><a +href="refB.html#bye">bye</a></code>). See also <code><a +href="refT.html#*Tmp">*Tmp</a></code> and <code><a +href="refB.html#*Bye">*Bye</a></code> . + +<pre><code> +: *Bye +-> ((saveHistory) (and *Tmp (call 'rm "-r" *Tmp))) +: *Pid +-> 27140 +: (tmp "foo" 123) +-> "tmp/27140/foo123" +: (dir "tmp/") +-> ("27140") +: (out (tmp "foo" 123) (println 'OK)) +-> OK +: (dir (tmp)) +-> ("foo123") +: (in (tmp "foo" 123) (read)) +-> OK +</code></pre> + +<dt><a name="tolr/3"><code>tolr/3</code></a> +<dd><a href="ref.html#pilog">Pilog</a> predicate that succeeds if the first +argument is either a <i>substring</i> or a <code><a +href="refS.html#+Sn">+Sn</a></code> <i>soundex</i> match of the result of +applying the <code><a href="refG.html#get">get</a></code> algorithm to the +following arguments. Typically used as filter predicate in <code><a +href="refS.html#select/3">select/3</a></code> database queries. See also +<code><a href="refI.html#isa/2">isa/2</a></code>, <code><a +href="refS.html#same/3">same/3</a></code>, <code><a +href="refB.html#bool/3">bool/3</a></code>, <code><a +href="refR.html#range/3">range/3</a></code>, <code><a +href="refH.html#head/3">head/3</a></code>, <code><a +href="refF.html#fold/3">fold/3</a></code> and <code><a +href="refP.html#part/3">part/3</a></code>. + +<pre><code> +: (? + @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={2-2} @Name="Seven Oaks Ltd." +</code></pre> + +<dt><a name="touch"><code>(touch 'sym) -> sym</code></a> +<dd>When <code>sym</code> is an external symbol, it is marked as "modified" so +that upon a later <code><a href="refC.html#commit">commit</a></code> it will be +written to the database file. An explicit call of <code>touch</code> is only +necessary when the value or properties of <code>sym</code> are indirectly +modified. + +<pre><code> +: (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) +</code></pre> + +<dt><a name="trace"><code>(trace 'sym) -> sym</code></a> +<dt><code>(trace 'sym 'cls) -> sym</code> +<dt><code>(trace '(sym . cls)) -> sym</code> +<dd>Inserts a <code><a href="ref_.html#$">$</a></code> trace function call at +the beginning of the function or method body of <code>sym</code>, so that trace +information will be printed before and after execution. Built-in functions +(C-function pointer) are automatically converted to Lisp expressions (see +<code><a href="refE.html#expr">expr</a></code>). See also <code><a +href="refD.html#*Dbg">*Dbg</a></code>, <code><a +href="refT.html#traceAll">traceAll</a></code> and <code><a +href="refU.html#untrace">untrace</a></code>, <code><a +href="refD.html#debug">debug</a></code> and <code><a +href="refL.html#lint">lint</a></code>. + +<pre><code> +: (trace '+) +-> + +: (+ 3 4) + + : 3 4 + + = 7 +-> 7 +</code></pre> + +<dt><a name="traceAll"><code>(traceAll ['lst]) -> sym</code></a> +<dd>Traces all Lisp level functions by inserting a <code><a +href="ref_.html#$">$</a></code> function call at the beginning. <code>lst</code> +may contain symbols which are to be excluded from that process. In addition, all +symbols in the global variable <code>*NoTrace</code> are excluded. See also +<code><a href="refT.html#trace">trace</a></code>, <code><a +href="refU.html#untrace">untrace</a></code> and <code><a +href="refD.html#*Dbg">*Dbg</a></code>. + +<pre><code> +: (traceAll) # Trace all Lisp level functions +-> balance +</code></pre> + +<dt><a name="tree"><code>(tree 'var 'cls ['hook]) -> tree</code></a> +<dd>Returns a data structure specifying a database index tree. <code>var</code> +and <code>cls</code> determine the relation, with an optional <code>hook</code> +object. See also <code><a href="refR.html#root">root</a></code>, <code><a +href="refF.html#fetch">fetch</a></code>, <code><a +href="refS.html#store">store</a></code>, <code><a +href="refC.html#count">count</a></code>, <code><a +href="refL.html#leaf">leaf</a></code>, <code><a +href="refM.html#minKey">minKey</a></code>, <code><a +href="refM.html#maxKey">maxKey</a></code>, <code><a +href="refI.html#init">init</a></code>, <code><a +href="refS.html#step">step</a></code>, <code><a +href="refS.html#scan">scan</a></code>, <code><a +href="refI.html#iter">iter</a></code>, <code><a +href="refP.html#prune">prune</a></code>, <code><a +href="refZ.html#zapTree">zapTree</a></code> and <code><a +href="refC.html#chkTree">chkTree</a></code>. + +<pre><code> +: (tree 'nm '+Item) +-> (nm . +Item) +</code></pre> + +<dt><a name="trim"><code>(trim 'lst) -> lst</code></a> +<dd>Returns a copy of <code>lst</code> with all trailing white space characters +or <code>NIL</code> elements removed. See also <code><a +href="refC.html#clip">clip</a></code>. + +<pre><code> +: (trim (1 NIL 2 NIL NIL)) +-> (1 NIL 2) +: (trim '(a b " " " ")) +-> (a b) +</code></pre> + +<dt><a name="true/0"><code>true/0</code></a> +<dd><a href="ref.html#pilog">Pilog</a> predicate that always succeeds. See also +<code><a href="refF.html#fail/0">fail/0</a></code> and <code><a +href="refR.html#repeat/0">repeat/0</a></code>. + +<pre><code> +: (? (true)) +-> T +</code></pre> + +<dt><a name="try"><code>(try 'msg 'obj ['any ..]) -> any</code></a> +<dd>Tries to send the message <code>msg</code> to the object <code>obj</code>, +optionally with arguments <code>any</code>. If <code>any</code> is not an +object, or if the message cannot be located in <code>obj</code>, its classes and +superclasses, <code>NIL</code> is returned. See also <code><a +href="ref.html#oop">OO Concepts</a></code>, <code><a +href="refS.html#send">send</a></code>, <code><a +href="refM.html#method">method</a></code>, <code><a +href="refM.html#meth">meth</a></code>, <code><a +href="refS.html#super">super</a></code> and <code><a +href="refE.html#extra">extra</a></code>. + +<pre><code> +: (try 'msg> 123) +-> NIL +: (try 'html> 'a) +-> NIL +</code></pre> + +<dt><a name="type"><code>(type 'any) -> lst</code></a> +<dd>Return the type (list of classes) of the object <code>sym</code>. See also +<code><a href="ref.html#oop">OO Concepts</a></code>, <code><a +href="refI.html#isa">isa</a></code>, <code><a +href="refC.html#class">class</a></code>, <code><a +href="refN.html#new">new</a></code> and <code><a +href="refO.html#object">object</a></code>. + +<pre><code> +: (type '{1A;3}) +(+Address) +: (type '+DnButton) +-> (+Tiny +Rid +JS +Able +Button) +</code></pre> + +</dl> + +</body> +</html> diff --git a/doc/refU.html b/doc/refU.html @@ -0,0 +1,356 @@ +<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.0 Transitional//EN" "http://www.w3.org/TR/1998/REC-html40-19980424/loose.dtd"> +<html lang="en"> +<head> +<meta http-equiv="Content-Type" content="text/html; charset=utf-8"> +<title>U</title> +<link rel="stylesheet" href="doc.css" type="text/css"> +</head> +<body> + +<h1>U</h1> + +<dl> + +<dt><a name="*Uni"><code>*Uni</code></a> +<dd>A global variable holding an <code><a href="refI.html#idx">idx</a></code> +tree, with all unique data that were collected with the comma (<code>,</code>) +read-macro. Typically used for localization. See also <code><a +href="ref.html#macro-io">Read-Macros</a></code> and <code><a +href="refL.html#locale">locale</a></code>. + +<pre><code> +: (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)) +</code></pre> + +<dt><a name="u"><code>(u) -> T</code></a> +<dd>Removes <code><a href="ref_.html#!">!</a></code> all breakpoints in all +subexpressions of the current breakpoint. Typically used when single-stepping a +function or method with <code><a href="refD.html#debug">debug</a></code>. See +also <code><a href="refD.html#d">d</a></code> and <code><a +href="refU.html#unbug">unbug</a></code>. + +<pre><code> +! (u) # Unbug subexpression(s) at breakpoint +-> T +</code></pre> + +<dt><a name="udp"><code>(udp 'any1 'cnt 'any2) -> any</code></a> +<dt><code>(udp 'cnt) -> any</code> +<dd>Simple unidirectional sending/receiving of UDP packets. In the first form, +<code>any2</code> is sent to a UDP server listening at host <code>any1</code>, +port <code>cnt</code>. In the second form, one item is received from a UDP +socket <code>cnt</code>, established with <code><a +href="refP.html#port">port</a></code>. See also <code><a +href="refC.html#connect">connect</a></code>. + +<pre><code> +# 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) +</code></pre> + +<dt><a name="ultimo"><code>(ultimo 'y 'm) -> cnt</code></a> +<dd>Returns the <code><a href="refD.html#date">date</a></code> of the last day +of the month <code>m</code> in the year <code>y</code>. See also <code><a +href="refD.html#day">day</a></code> and <code><a +href="refW.html#week">week</a></code>. + +<pre><code> +: (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) +</code></pre> + +<dt><a name="unbug"><code>(unbug 'sym) -> T</code></a> +<dt><code>(unbug 'sym 'cls) -> T</code> +<dt><code>(unbug '(sym . cls)) -> T</code> +<dd>Removes all <code><a href="ref_.html#!">!</a></code> breakpoints in the +function or method body of sym, as inserted with <code><a +href="refD.html#debug">debug</a></code> or <code><a +href="refD.html#d">d</a></code>, or directly with <code><a +href="refE.html#edit">edit</a></code>. See also <code><a +href="refU.html#u">u</a></code>. + +<pre><code> +: (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)) ) +</code></pre> + +<dt><a name="undef"><code>(undef 'sym) -> fun</code></a> +<dt><code>(undef 'sym 'cls) -> fun</code> +<dt><code>(undef '(sym . cls)) -> fun</code> +<dd>Undefines the function or method <code>sym</code>. Returns the previous +definition. See also <code><a href="refD.html#de">de</a></code>, <code><a +href="refD.html#dm">dm</a></code>, <code><a href="refD.html#def">def</a></code> +and <code><a href="refR.html#redef">redef</a></code>. + +<pre><code> +: (de hello () "Hello world!") +-> hello +: hello +-> (NIL "Hello world!") +: (undef 'hello) +-> (NIL "Hello world!") +: hello +-> NIL +</code></pre> + +<dt><a name="unify"><code>(unify 'any) -> lst</code></a> +<dd>Unifies <code>any</code> with the current <a href="ref.html#pilog">Pilog</a> +environment at the current level and with a value of <code>NIL</code>, and +returns the new environment or <code>NIL</code> if not successful. See also +<code><a href="refP.html#prove">prove</a></code> and <code><a +href="ref_.html#->">-&gt</a></code>. + +<pre><code> +: (? (@A unify '(@B @C))) + @A=(((NIL . @C) 0 . @C) ((NIL . @B) 0 . @B) T) +</code></pre> + +<dt><a name="uniq"><code>(uniq 'lst) -> lst</code></a> +<dd>Returns a unique list, by eleminating all duplicate elements from +<code>lst</code>. See also <a href="ref.html#cmp">Comparing</a>, <code><a +href="refS.html#sort">sort</a></code> and <code><a +href="refG.html#group">group</a></code>. + +<pre><code> +: (uniq (2 4 6 1 2 3 4 5 6 1 3 5)) +-> (2 4 6 1 3 5) +</code></pre> + +<dt><a name="uniq/2"><code>uniq/2</code></a> +<dd><a href="ref.html#pilog">Pilog</a> predicate that succeeds if the first +argument is not yet stored in the second argument's index structure. <code><a +href="refI.html#idx">idx</a></code> is used internally storing for the values +and checking for uniqueness. See also <code><a +href="refM.html#member/2">member/2</a></code>. + +<pre><code> +: (? (uniq a @Z)) # Remember 'a' + @Z=NIL # Succeeded + +: (? (uniq b @Z)) # Remember 'b' + @Z=NIL # Succeeded + +: (? (uniq a @Z)) # Remembered 'a'? +-> NIL # Yes: Not unique +</code></pre> + +<dt><a name="unless"><code>(unless 'any . prg) -> any</code></a> +<dd>Conditional execution: When the condition <code>any</code> evaluates to +non-<code>NIL</code>, <code>NIL</code> is returned. Otherwise <code>prg</code> +is executed and the result returned. See also <code><a +href="refW.html#when">when</a></code>. + +<pre><code> +: (unless (= 3 3) (println 'Strange 'result)) +-> NIL +: (unless (= 3 4) (println 'Strange 'result)) +Strange result +-> result +</code></pre> + +<dt><a name="until"><code>(until 'any . prg) -> any</code></a> +<dd>Conditional loop: While the condition <code>any</code> evaluates to +<code>NIL</code>, <code>prg</code> is repeatedly executed. If <code>prg</code> +is never executed, <code>NIL</code> is returned. Otherwise the result of +<code>prg</code> is returned. See also <code><a +href="refW.html#while">while</a></code>. + +<pre><code> +: (until (=T (setq N (read))) + (println 'square (* N N)) ) +4 +square 16 +9 +square 81 +T +-> 81 +</code></pre> + +<dt><a name="untrace"><code>(untrace 'sym) -> sym</code></a> +<dt><code>(untrace 'sym 'cls) -> sym</code> +<dt><code>(untrace '(sym . cls)) -> sym</code> +<dd>Removes the <code><a href="ref_.html#$">$</a></code> trace function call at +the beginning of the function or method body of <code>sym</code>, so that no +more trace information will be printed before and after execution. Built-in +functions (C-function pointer) are automatically converted to their original +form (see <code><a href="refS.html#subr">subr</a></code>). See also <code><a +href="refT.html#trace">trace</a></code> and <code><a +href="refT.html#traceAll">traceAll</a></code>. + +<pre><code> +: (trace '+) # Trace the '+' function +-> + +: + +-> (@ ($ + @ (pass $385455126))) # Modified for tracing +: (untrace '+) # Untrace '+' +-> + +: + +-> 67319120 # Back to original form +</code></pre> + +<dt><a name="up"><code>(up [cnt] sym ['val]) -> any</code></a> +<dd>Looks up (or modifies) the <code>cnt</code>'th previously saved value of +<code>sym</code> in the corresponding enclosing environment. If <code>cnt</code> +is not given, 1 is used. See also <code><a +href="refE.html#eval">eval</a></code>, <code><a +href="refR.html#run">run</a></code> and <code><a +href="refE.html#env">env</a></code>. + +<pre><code> +: (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 +</code></pre> + +<dt><a name="upd"><code>(upd sym ..) -> lst</code></a> +<dd>Synchronizes the internal state of all passed (external) symbols by passing +them to <code><a href="refW.html#wipe">wipe</a></code>. <code>upd</code> is the +standard function passed to <code><a href="refC.html#commit">commit</a></code> +during database <code><a href="ref.html#trans">transactions</a></code>. + +<pre><code> +(commit 'upd) # Commit changes, informing all sister processes +</code></pre> + +<dt><a name="update"><code>(update 'obj ['var]) -> obj</code></a> +<dd>Interactive database function for modifying external symbols. When called +only with an <code>obj</code> argument, <code>update</code> steps through the +value and all properties of that object (and recursively also through +substructures) and allows to edit them with the console line editor. When the +<code>var</code> argument is given, only that single property is handed to the +editor. To delete a propery, <code>NIL</code> must be explicitly entered. +<code>update</code> will correctly handle all <a +href="ref.html#er">entity/relation</a> mechanisms. See also <code><a +href="refS.html#select">select</a></code>, <code><a +href="refE.html#edit">edit</a></code> and <code><a +href="ref.html#dbase">Database</a></code>. + +<pre><code> +: (show '{3-1}) # Show item 1 +{3-1} (+Item) + nr 1 + pr 29900 + inv 100 + sup {2-1} + nm "Main Part" +-> {3-1} + +: (update '{3-1} 'pr) # Update the prices of that item +{3-1} pr 299.00 # The cursor is right behind "299.00" +-> {3-1} +</code></pre> + +<dt><a name="upp?"><code>(upp? 'any) -> sym | NIL</code></a> +<dd>Returns <code>any</code> when the argument is a string (symbol) that starts +with an uppercase character. See also <code><a +href="refU.html#uppc">uppc</a></code>. + +<pre><code> +: (upp? "A") +-> T +: (upp? "a") +-> NIL +: (upp? 123) +-> NIL +: (upp? ".") +-> NIL +</code></pre> + +<dt><a name="uppc"><code>(uppc 'any) -> any</code></a> +<dd>Upper case conversion: If <code>any</code> is not a symbol, it is returned +as it is. Otherwise, a new transient symbol with all characters of +<code>any</code>, converted to upper case, is returned. See also <code><a +href="refL.html#lowc">lowc</a></code>, <code><a +href="refF.html#fold">fold</a></code> and <code><a +href="refU.html#upp?">upp?</a></code>. + +<pre><code> +: (uppc 123) +-> 123 +: (uppc "abc") +-> "ABC" +: (uppc 'car) +-> "CAR" +</code></pre> + +<dt><a name="use"><code>(use sym . prg) -> any</code></a> +<dt><code>(use (sym ..) . prg) -> any</code> +<dd>Defines local variables. The value of the symbol <code>sym</code> - or the +values of the symbols <code>sym</code> in the list of the second form - are +saved, <code>prg</code> is executed, then the symbols are restored to their +original values. During execution of <code>prg</code>, the values of the symbols +can be temporarily modified. The return value is the result of <code>prg</code>. +See also <code><a href="refB.html#bind">bind</a></code>, <code><a +href="refJ.html#job">job</a></code> and <code><a +href="refL.html#let">let</a></code>. + +<pre><code> +: (setq X 123 Y 456) +-> 456 +: (use (X Y) (setq X 3 Y 4) (* X Y)) +-> 12 +: X +-> 123 +: Y +-> 456 +</code></pre> + +<dt><a name="useKey"><code>(useKey 'var 'cls ['hook]) -> num</code></a> +<dd>Generates or reuses a key for a database tree, by randomly trying to locate +a free number. See also <code><a href="refG.html#genKey">genKey</a></code>. + +<pre><code> +: (maxKey (tree 'nr '+Item)) +-> 8 +: (useKey 'nr '+Item) +-> 12 +</code></pre> + +<dt><a name="usec"><code>(usec) -> num</code></a> +<dd>Returns the number the microseconds since interpreter startup. See also +<code><a href="refT.html#time">time</a></code> and <code><a +href="refT.html#tick">tick</a></code>. + +<pre><code> +: (usec) +-> 1154702479219050 +</code></pre> + +</dl> + +</body> +</html> diff --git a/doc/refV.html b/doc/refV.html @@ -0,0 +1,163 @@ +<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.0 Transitional//EN" "http://www.w3.org/TR/1998/REC-html40-19980424/loose.dtd"> +<html lang="en"> +<head> +<meta http-equiv="Content-Type" content="text/html; charset=utf-8"> +<title>V</title> +<link rel="stylesheet" href="doc.css" type="text/css"> +</head> +<body> + +<h1>V</h1> + +<dl> + +<dt><a name="val"><code>(val 'var) -> any</code></a> +<dd>Returns the current value of <code>var</code>. See also <code><a +href="refS.html#setq">setq</a></code>, <code><a +href="refS.html#set">set</a></code> and <code><a +href="refD.html#def">def</a></code>. + +<pre><code> +: (setq L '(a b c)) +-> (a b c) +: (val 'L) +-> (a b c) +: (val (cdr L)) +-> b +</code></pre> + +<dt><a name="val/3"><code>val/3</code></a> +<dd><a href="ref.html#pilog">Pilog</a> 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 <code><a +href="refG.html#get">get</a></code> algorithm to that object. See also <code><a +href="refD.html#db/3">db/3</a></code> and <code><a +href="refS.html#select/3">select/3</a></code>. + +<pre><code> +: (? + (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={3-2} @Nm="Spare Part" @Sup="Seven Oaks Ltd." @Item={3-3} @Nm="Auxiliary Construction" @Sup="Active Parts Inc." + @Item={3-4} @Nm="Enhancement Additive" @Sup="Seven Oaks Ltd." + @Item={3-5} @Nm="Metal Fittings" @Sup="Active Parts Inc." +-> NIL +</code></pre> + +<dt><a name="var"><code>(var sym . any) -> any</code></a> +<dd>Defines a class variable <code>sym</code> with the initial value +<code>any</code> for the current class (in <code><a +href="refC.html#*Class">*Class</a></code>). See also <code><a +href="ref.html#oop">OO Concepts</a></code> and <code><a +href="refV.html#var:">var:</a></code>. + +<pre><code> +: (class +A) +-> +A +: (var a . 1) +-> 1 +: (var b . 2) +-> 2 +: (show '+A) ++A NIL + b 2 + a 1 +-> +A +</code></pre> + +<dt><a name="var:"><code>(var: sym) -> any</code></a> +<dd>Fetches the value of a class variable <code>sym</code> for the current +object <code><a href="refT.html#This">This</a></code>, by searching the property +lists of its class(es) and supperclasses. See also <code><a +href="ref.html#oop">OO Concepts</a></code>, <code><a +href="refV.html#var">var</a></code>, <code><a +href="refW.html#with">with</a></code>, <code><a +href="refM.html#meta">meta</a></code>, <code><a href="ref_.html#:">:</a></code>, +<code><a href="ref_.html#=:">=:</a></code> and <code><a +href="ref_.html#::">::</a></code>. + +<pre><code> +: (object 'O '(+A) 'a 9 'b 8) +-> O +: (with 'O (list (: a) (: b) (var: a) (var: b))) +-> (9 8 1 2) +</code></pre> + +<dt><a name="version"><code>(version ['flg]) -> lst</code></a> +<dd>(64-bit version only) Prints the current version as a string of +dot-separated numbers, and returns the current version as a list of numbers. +When <code>flg</code> is non-NIL, printing is suppressed. + +<pre><code> +$ ./p -version +3.0.1.22 +: (version T) +-> (3 0 1 22) +</code></pre> + +<dt><a name="vi"><code>(vi 'sym) -> sym</code></a> +<dt><code>(vi 'sym 'cls) -> sym</code> +<dt><code>(vi '(sym . cls)) -> sym</code> +<dt><code>(vi) -> NIL</code> +<dd>Opens the "vi" editor on the function or method definition of +<code>sym</code>. A call to <code><a href="refL.html#ld">ld</a></code> +thereafter will <code><a href="refL.html#load">load</a></code> the modified +file. See also <code><a href="refD.html#doc">doc</a></code>, <code><a +href="refP.html#pp">pp</a></code>, <code><a +href="refD.html#*Dbg">*Dbg</a></code>, <code><a +href="refD.html#debug">debug</a></code> and <code><a +href="refP.html#pp">pp</a></code>. + +<pre><code> +: (vi 'url> '+CuSu) # Edit the method's source code, then exit from 'vi' +-> T +</code></pre> + +<dt><a name="view"><code>(view 'lst) -> any</code></a> +<dd>Views <code>lst</code> as tree-structured ASCII graphics. See also <code><a +href="refP.html#pretty">pretty</a></code> and <code><a +href="refS.html#show">show</a></code>. + +<pre><code> +: (view '(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 +</code></pre> + +</dl> + +</body> +</html> diff --git a/doc/refW.html b/doc/refW.html @@ -0,0 +1,196 @@ +<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.0 Transitional//EN" "http://www.w3.org/TR/1998/REC-html40-19980424/loose.dtd"> +<html lang="en"> +<head> +<meta http-equiv="Content-Type" content="text/html; charset=utf-8"> +<title>W</title> +<link rel="stylesheet" href="doc.css" type="text/css"> +</head> +<body> + +<h1>W</h1> + +<dl> + +<dt><a name="wait"><code>(wait ['cnt] . prg) -> any</code></a> +<dd>Waits for a condition. While the result of the execution of <code>prg</code> +returns non-<code>NIL</code>, a <code>select</code> system call is executed for +all file descriptors and timers in the <code>VAL</code> of the global variable +<code><a href="refR.html#*Run">*Run</a></code>. When <code>cnt</code> is +non-<code>NIL</code>, the waiting time is limited to <code>cnt</code> +milliseconds. See also <code><a href="refK.html#key">key</a></code> and <code><a +href="refS.html#sync">sync</a></code>. + +<pre><code> +: (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 +</code></pre> + +<dt><a name="week"><code>(week 'dat) -> num</code></a> +<dd>Returns the number of the week for a given <code><a +href="refD.html#date">date</a></code> <code>dat</code>. See also <code><a +href="refD.html#day">day</a></code>, <code><a +href="refU.html#ultimo">ultimo</a></code>, <code><a +href="refD.html#datStr">datStr</a></code> and <code><a +href="refS.html#strDat">strDat</a></code>. + +<pre><code> +: (datStr (date)) +-> <u>2007-06-01</u> +: (week (date)) +-> 22 +</code></pre> + +<dt><a name="when"><code>(when 'any . prg) -> any</code></a> +<dd>Conditional execution: When the condition <code>any</code> evaluates to +non-<code>NIL</code>, <code>prg</code> is executed and the result is returned. +Otherwise <code>NIL</code> is returned. See also <code><a +href="refU.html#unless">unless</a></code>. + +<pre><code> +: (when (> 4 3) (println 'OK) (println 'Good)) +OK +Good +-> Good +</code></pre> + +<dt><a name="while"><code>(while 'any . prg) -> any</code></a> +<dd>Conditional loop: While the condition <code>any</code> evaluates to +non-<code>NIL</code>, <code>prg</code> is repeatedly executed. If +<code>prg</code> is never executed, <code>NIL</code> is returned. Otherwise the +result of <code>prg</code> is returned. See also <code><a +href="refU.html#until">until</a></code>. + +<pre><code> +: (while (read) + (println 'got: @) ) +abc +got: abc +1234 +got: 1234 +NIL +-> 1234 +</code></pre> + +<dt><a name="what"><code>(what 'sym) -> lst</code></a> +<dd>Returns a list of all internal symbols that match the pattern string +<code>sym</code>. See also <code><a href="refM.html#match">match</a></code>, +<code><a href="refW.html#who">who</a></code> and <code><a +href="refC.html#can">can</a></code>. + +<pre><code> +: (what <u>cd@dr</u>) +-> (cdaddr cdaadr cddr cddddr cdddr cddadr cdadr) +</code></pre> + +<dt><a name="who"><code>(who 'any) -> lst</code></a> +<dd>Returns a list of all functions or method definitions that contain the atom +or pattern <code>any</code>. See also <code><a +href="refM.html#match">match</a></code>, <code><a +href="refW.html#what">what</a></code> and <code><a +href="refC.html#can">can</a></code>. + +<pre><code> +: (who 'caddr) # Who is using 'caddr'? +-> ($dat lint1 expDat datStr $tim tim$ mail _gen dat$ datSym) + +: (who <u>Type error</u>) +-> ((mis> . +Link) *Uni (mis> . +Joint)) + +: (more (who <u>Type error</u>) pp) # Pretty print all results +(dm (mis> . +Link) (Val Obj) + (and + Val + (nor (isa (: type) Val) (canQuery Val)) + <u>Type error</u> ) ) +. # Stop +-> T +</code></pre> + +<dt><a name="wipe"><code>(wipe 'sym|lst) -> sym|lst</code></a> +<dd>Clears the <code>VAL</code> and the property list of <code>sym</code>, or of +all symbols in the list <code>lst</code>. When a symbol is an external symbol, +its state is also set to "not loaded". Does nothing when <code>sym</code> is an +external symbol that has been modified or deleted ("dirty"). + +<pre><code> +: (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 +</code></pre> + +<dt><a name="with"><code>(with 'sym . prg) -> any</code></a> +<dd>Saves the current object <code>This</code> and sets it to the new value +<code>sym</code>. Then <code>prg</code> is executed, and <code>This</code> is +restored to its previous value. The return value is the result of +<code>prg</code>. Used typically to access the local data of <code>sym</code> in +the same manner as inside a method body. <code>prg</code> is not executed (and +<code>NIL</code> is returned) when <code>sym</code> is <code>NIL</code>. +<code>(with 'X . prg)</code> is equivalent to <code>(let? This 'X . prg)</code>. + +<pre><code> +: (put 'X 'a 1) +-> 1 +: (put 'X 'b 2) +-> 2 +: (with 'X (list (: a) (: b))) +-> (1 2) +</code></pre> + +<dt><a name="wr"><code>(wr 'cnt ..) -> cnt</code></a> +<dd>Writes all <code>cnt</code> arguments as raw bytes to the current output +channel. See also <code><a href="refR.html#rd">rd</a></code> and <code><a +href="refP.html#pr">pr</a></code>. + +<pre><code> +: (out <u>x</u> (wr 1 255 257)) # Write to "x" +-> 257 +: (hd <u>x</u>) +00000000 01 FF 01 ... +-> NIL +</code></pre> + +<dt><a name="wrap"><code>(wrap 'cnt 'lst) -> sym</code></a> +<dd>Returns a transient symbol with all characters in <code>lst</code> <code><a +href="refP.html#pack">pack</a></code>ed in lines with a maximal length of +<code>cnt</code>. See also <code><a href="refT.html#tab">tab</a></code>, +<code><a href="refA.html#align">align</a></code> and <code><a +href="refC.html#center">center</a></code>. + +<pre><code> +: (wrap 20 (chop <u>The quick brown fox jumps over the lazy dog</u>)) +-> <u>The quick brown fox^Jjumps over the lazy^Jdog</u> +: (wrap 8 (chop <u>The quick brown fox jumps over the lazy dog</u>)) +-> <u>The^Jquick^Jbrown^Jfox^Jjumps^Jover the^Jlazy dog</u> +</code></pre> + +</dl> + +</body> +</html> diff --git a/doc/refX.html b/doc/refX.html @@ -0,0 +1,57 @@ +<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.0 Transitional//EN" "http://www.w3.org/TR/1998/REC-html40-19980424/loose.dtd"> +<html lang="en"> +<head> +<meta http-equiv="Content-Type" content="text/html; charset=utf-8"> +<title>X</title> +<link rel="stylesheet" href="doc.css" type="text/css"> +</head> +<body> + +<h1>X</h1> + +<dl> + +<dt><a name="xchg"><code>(xchg 'var 'var ..) -> any</code></a> +<dd>Exchange the values of successive <code>var</code> argument pairs. + +<pre><code> +: (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) +</code></pre> + +<dt><a name="xor"><code>(xor 'any 'any) -> flg</code></a> +<dd>Returns T if exactly one of the arguments evaluates to non-<code>NIL</code>. + +<pre><code> +: (xor T NIL) +-> T +: (xor T T) +-> NIL +</code></pre> + +<dt><a name="x|"><code>(x| 'num ..) -> num</code></a> +<dd>Returns the bitwise <code>XOR</code> of all <code>num</code> arguments. When +one of the arguments evaluates to <code>NIL</code>, it is returned immediately. +See also <code><a href="ref_.html#&">&</a></code>, <code><a +href="ref_.html#|">|</a></code> and <code><a +href="refB.html#bit?">bit?</a></code>. + +<pre><code> +: (x| 2 7) +-> 5 +: (x| 2 7 1) +-> 4 +</code></pre> + +</dl> + +</body> +</html> diff --git a/doc/refY.html b/doc/refY.html @@ -0,0 +1,30 @@ +<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.0 Transitional//EN" "http://www.w3.org/TR/1998/REC-html40-19980424/loose.dtd"> +<html lang="en"> +<head> +<meta http-equiv="Content-Type" content="text/html; charset=utf-8"> +<title>Y</title> +<link rel="stylesheet" href="doc.css" type="text/css"> +</head> +<body> + +<h1>Y</h1> + +<dl> + +<dt><a name="yoke"><code>(yoke 'any ..) -> any</code></a> +<dd>Inserts one or several new elements <code>any</code> in front of the list in +the current <code><a href="refM.html#make">make</a></code> environment. +<code>yoke</code> returns the last inserted argument. See also <code><a +href="refL.html#link">link</a></code>, <code><a +href="refC.html#chain">chain</a></code> and <code><a +href="refM.html#made">made</a></code>. + +<pre><code> +: (make (link 2 3) (yoke 1) (link 4)) +-> (1 2 3 4) +</code></pre> + +</dl> + +</body> +</html> diff --git a/doc/refZ.html b/doc/refZ.html @@ -0,0 +1,102 @@ +<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.0 Transitional//EN" "http://www.w3.org/TR/1998/REC-html40-19980424/loose.dtd"> +<html lang="en"> +<head> +<meta http-equiv="Content-Type" content="text/html; charset=utf-8"> +<title>Z</title> +<link rel="stylesheet" href="doc.css" type="text/css"> +</head> +<body> + +<h1>Z</h1> + +<dl> + +<dt><a name="*Zap"><code>*Zap</code></a> +<dd>A global variable holding a list and a pathname. If given, and the value of +<code><a href="refS.html#*Solo">*Solo</a></code> is <code>NIL</code>, 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 <code><a +href="refC.html#commit">commit</a></code>. A (typically periodic) call to +<code><a href="refZ.html#zap_">zap_</a></code> will clean them up later. + +<pre><code> +: (setq *Zap '(NIL . "db/app/_zap")) +-> "db/app/_zap" +</code></pre> + +<dt><a name="zap"><code>(zap 'sym) -> sym</code></a> +<dd>"Delete" the symbol <code>sym</code>. For internal symbols, that means to +remove it from the internal index, effectively transforming it to a transient +symbol. For external symbols, it means to mark it as "deleted", so that upon a +later <code><a href="refC.html#commit">commit</a></code> it will be removed from +the database file. See also <code><a href="refI.html#intern">intern</a></code>. + +<pre><code> +: (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 +? +</code></pre> + +<dt><a name="zapTree"><code>(zapTree 'sym)</code></a> +<dd>Recursively deletes a tree structure from the database. See also <code><a +href="refT.html#tree">tree</a></code>, <code><a +href="refC.html#chkTree">chkTree</a></code> and <code><a +href="refP.html#prune">prune</a></code>. + +<pre><code> +: (zapTree (cdr (root (tree 'nm '+Item)))) +</code></pre> + +<dt><a name="zap_"><code>(zap_)</code></a> +<dd>Delayed deletion (with <code><a href="refZ.html#zap">zap</a></code>) 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 <code><a +href="refZ.html#*Zap">*Zap</a></code>, concatenated with a "<code>_</code>" +character) is used as an intermediary file. + +<pre><code> +: *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_ +... +</code></pre> + +<dt><a name="zero"><code>(zero var ..) -> 0</code></a> +<dd>Stores <code>0</code> in all <code>var</code> arguments. See also <code><a +href="refO.html#one">one</a></code>, <code><a href="refO.html#on">on</a></code>, +<code><a href="refO.html#off">off</a></code> and <code><a +href="refO.html#onOff">onOff</a></code>. + +<pre><code> +: (zero A B) +-> 0 +: A +-> 0 +: B +-> 0 +</code></pre> + +</dl> + +</body> +</html> diff --git a/doc/ref_.html b/doc/ref_.html @@ -0,0 +1,546 @@ +<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.0 Transitional//EN" "http://www.w3.org/TR/1998/REC-html40-19980424/loose.dtd"> +<html lang="en"> +<head> +<meta http-equiv="Content-Type" content="text/html; charset=utf-8"> +<title>Other</title> +<link rel="stylesheet" href="doc.css" type="text/css"> +</head> +<body> + +<h1>Other</h1> + +<dl> + +<dt><a name="!"><code>(! . exe) -> any</code></a> +<dd>Low level breakpoint function: The current execution environment is saved +and the I/O channels are redirected to the console. Then <code>exe</code> is +displayed, and a read-eval-print-loop is entered (with <code>!</code> 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 <code>exe</code> is +returned. <code>!</code> is normally inserted into existing programs with the +<code><a href="refD.html#debug">debug</a></code> function. See also <code><a +href="refE.html#e">e</a></code>, <code><a href="ref_.html#^">^</a></code> and +<code><a href="refD.html#*Dbg">*Dbg</a></code>. + +<pre><code> +: (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 +</code></pre> + +<dt><a name="$"><code>($ sym|lst lst . prg) -> any</code></a> +<dd>Low level trace function: The first argument <code>sym|lst</code> is printed +to the console with a proper indentation, followed by a colon <code>:</code>. 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 +<code>lst</code> 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 <code>prg</code> is executed, and its return value printed in a +similar way (this time with an equals sign <code>=</code> instead of a colon) +and returned. <code>$</code> is normally inserted into existing programs with +the <code><a href="refT.html#trace">trace</a></code> function. + +<pre><code> +: (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 +</code></pre> + +<dt><a name="$dat"><code>($dat 'sym1 ['sym2]) -> dat</code></a> +<dd>Converts a string <code>sym1</code> in ISO format to a <code><a +href="refD.html#date">date</a></code>, optionally using a delimiter character +<code>sym2</code>. See also <code><a href="refD.html#dat$">dat$</a></code>, +<code><a href="ref_.html#$tim">$tim</a></code>, <code><a +href="refS.html#strDat">strDat</a></code> and <code><a +href="refE.html#expDat">expDat</a></code>. + +<pre><code> +: ($dat "20070601") +-> 733134 +: ($dat "2007-06-01" "-") +-> 733134 +</code></pre> + +<dt><a name="$tim"><code>($tim 'sym) -> tim</code></a> +<dd>Converts a string to a <code><a href="refT.html#time">time</a></code>. The +minutes and seconds are optional and default to zero. See also <code><a +href="refT.html#tim$">tim$</a></code> and <code><a +href="ref_.html#$dat">$dat</a></code>. + +<pre><code> +: (time ($tim "10:57:56")) +-> (10 57 56) +: (time ($tim "10:57")) +-> (10 57 0) +: (time ($tim "10")) +-> (10 0 0) +</code></pre> + +<dt><a name="%"><code>(% 'num ..) -> num</code></a> +<dd>Returns the remainder from the divisions of successive <code>num</code> +arguments. The sign of the result is that of the first argument. When one of the +arguments evaluates to <code>NIL</code>, it is returned immediately. See also +<code><a href="ref_.html#/">/</a></code> and <code><a +href="ref_.html#*/">*/</a></code> . + +<pre><code> +: (% 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 +</code></pre> + +<dt><a name="&"><code>(& 'num ..) -> num</code></a> +<dd>Returns the bitwise <code>AND</code> of all <code>num</code> arguments. When +one of the arguments evaluates to <code>NIL</code>, it is returned immediately. +See also <code><a href="ref_.html#|">|</a></code>, <code><a +href="refX.html#x|">x|</a></code> and <code><a +href="refB.html#bit?">bit?</a></code>. + +<pre><code> +: (& 6 3) +-> 2 +: (& 7 3 1) +-> 1 +</code></pre> + +<dt><a name="*"><code>(* 'num ..) -> num</code></a> +<dd>Returns the product of all <code>num</code> arguments. When one of the +arguments evaluates to <code>NIL</code>, it is returned immediately. See also +<code><a href="ref_.html#/">/</a></code>, <code><a +href="ref_.html#*/">*/</a></code>, <code><a href="ref_.html#+">+</a></code> and +<code><a href="ref_.html#-">-</a></code>. + +<pre><code> +: (* 1 2 3) +-> 6 +: (* 5 3 2 2) +-> 60 +</code></pre> + +<dt><a name="**"><code>(** 'num1 'num2) -> num</code></a> +<dd>Returns <code>num1</code> to the power of <code>num2</code>. + +<pre><code> +: (** 2 3) +-> 8 +: (** 100 100) +-> 10000000000000000000000000000000000000000000000000000000000000000000000000000 +00000000000000000000000000000000000000000000000000000000000000000000000000000000 +00000000000000000000000000000000000000000000 +</code></pre> + +<dt><a name="*/"><code>(*/ 'num1 ['num2 ..] 'num3) -> num</code></a> +<dd>Returns the product of <code>num1</code> and all following <code>num2</code> +arguments, divided by the <code>num3</code> argument. The result is rounded to +the nearest integer value. When one of the arguments evaluates to +<code>NIL</code>, it is returned immediately. Note that <code>*/</code> is +especially useful for fixed point arithmetic, by multiplying with (or dividing +by) the scale factor. See also <code><a href="ref_.html#*">*</a></code>, +<code><a href="ref_.html#/">/</a></code>, <code><a +href="ref_.html#+">+</a></code> and <code><a href="ref_.html#-">-</a></code>. + +<pre><code> +: (*/ 3 4 2) +-> 6 +: (*/ 1234 2 10) +-> 247 +: (*/ 100 6) +-> 17 + +: (setq *Scl 2) +-> 2 +: (format (*/ 3.0 1.5 1.0) *Scl) +-> "4.50" +</code></pre> + +<dt><a name="+"><code>(+ 'num ..) -> num</code></a> +<dd>Returns the sum of all <code>num</code> arguments. When one of the arguments +evaluates to <code>NIL</code>, it is returned immediately. See also <code><a +href="refI.html#inc">inc</a></code>, <code><a href="ref_.html#-">-</a></code>, +<code><a href="ref_.html#*">*</a></code>, <code><a +href="ref_.html#/">/</a></code> and <code><a href="ref_.html#*/">*/</a></code>. + +<pre><code> +: (+ 1 2 3) +-> 6 +</code></pre> + +<dt><a name="-"><code>(- 'num ..) -> num</code></a> +<dd>Returns the difference of the first <code>num</code> argument and all +following arguments. If only a single argument is given, it is negated. When one +of the arguments evaluates to <code>NIL</code>, it is returned immediately. See +also <code><a href="refD.html#dec">dec</a></code>, <code><a +href="ref_.html#+">+</a></code>, <code><a href="ref_.html#*">*</a></code>, +<code><a href="ref_.html#/">/</a></code> and <code><a +href="ref_.html#*/">*/</a></code>. + +<pre><code> +: (- 7) +-> -7 +: (- 7 2 1) +-> 4 +</code></pre> + +<dt><a name="->"><code>(-&gt sym [num]) -> any</code></a> +<dd>Searches for the current value of the pattern variable <code>sym</code> at +top level (or level <code>num</code>) in the current <a +href="ref.html#pilog">Pilog</a> environment. See also <code><a +href="refP.html#prove">prove</a></code> and <code><a +href="refU.html#unify">unify</a></code>. + +<pre><code> +: (? (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 +</code></pre> + +<dt><a name="/"><code>(/ 'num ..) -> num</code></a> +<dd>Returns the first <code>num</code> argument successively divided by all +following arguments. When one of the arguments evaluates to <code>NIL</code>, it +is returned immediately. See also <code><a href="ref_.html#*">*</a></code>, +<code><a href="ref_.html#*/">*/</a></code>, <code><a +href="ref_.html#%">%</a></code>, <code><a href="ref_.html#+">+</a></code> and +<code><a href="ref_.html#-">-</a></code>. + +<pre><code> +: (/ 12 3) +-> 4 +: (/ 60 -3 2 2) +-> -5 +</code></pre> + +<dt><a name=":"><code>(: sym|0 [sym1|cnt ..]) -> any</code></a> +<dd>Fetches a value <code>any</code> from the properties of a symbol, or from a +list, by applying the <code><a href="refG.html#get">get</a></code> algorithm to +<code>This</code> and the following arguments. Used typically in methods or +<code><a href="refW.html#with">with</a></code> bodies. <code>(: ..)</code> is +equivalent to <code>(; This ..)</code>. See also <code><a +href="ref_.html#;">;</a></code>, <code><a href="ref_.html#=:">=:</a></code> and +<code><a href="ref_.html#::">::</a></code>. + +<pre><code> +: (put 'X 'a 1) +-> 1 +: (with 'X (: a)) +-> 1 +</code></pre> + +<dt><a name="::"><code>(:: sym [sym1|cnt .. sym2]) -> lst|sym</code></a> +<dd>Fetches a property for a property key <code>sym</code> or <code>sym2</code> +from a symbol. That symbol is <code>This</code> (if no other arguments are +given), or a symbol found by applying the <code><a +href="refG.html#get">get</a></code> algorithm to <code>This</code> and the +following arguments. The property (the cell, not just its value) is returned, +suitable for direct (destructive) manipulations. Used typically in methods or +<code><a href="refW.html#with">with</a></code> bodies. See also <code><a +href="ref_.html#=:">=:</a></code>, <code><a +href="refP.html#prop">prop</a></code> and <code><a +href="ref_.html#:">:</a></code>. + +<pre><code> +: (with 'X (=: cnt 0) (inc (:: cnt)) (: cnt)) +-> 1 +</code></pre> + +<dt><a name=";"><code>(; 'sym1|lst [sym2|cnt ..]) -> any</code></a> +<dd>Fetches a value <code>any</code> from the properties of a symbol, or from a +list, by applying the <code><a href="refG.html#get">get</a></code> algorithm to +<code>sym1|lst</code> and the following arguments. See also <code><a +href="ref_.html#:">:</a></code>, <code><a href="ref_.html#=:">=:</a></code> and +<code><a href="ref_.html#::">::</a></code>. + +<pre><code> +: (put 'A 'a 1) +-> 1 +: (put 'A 'b 'B) +-> B +: (put 'B 'c 7) +-> 7 +: (; 'A a) +-> 1 +: (; 'A b c) +-> 7 +</code></pre> + +<dt><a name="<"><code>(< 'any ..) -> flg</code></a> +<dd>Returns <code>T</code> when all arguments <code>any</code> are in strictly +increasing order. See also <a href="ref.html#cmp">Comparing</a>. + +<pre><code> +: (< 3 4) +-> T +: (< 'a 'b 'c) +-> T +: (< 999 'a) +-> T +</code></pre> + +<dt><a name="<="><code>(<= 'any ..) -> flg</code></a> +<dd>Returns <code>T</code> when all arguments <code>any</code> are in strictly +non-decreasing order. See also <a href="ref.html#cmp">Comparing</a>. + +<pre><code> +: (<= 3 3) +-> T +: (<= 1 2 3) +-> T +: (<= "abc" "abc" "def") +-> T +</code></pre> + +<dt><a name="<>"><code>(<&gt 'any ..) -> flg</code></a> +<dd>Returns <code>T</code> when not all <code>any</code> arguments are equal +(structure equality). <code>(<&gt 'any ..)</code> is equivalent to <code>(not (= +'any ..))</code>. See also <a href="ref.html#cmp">Comparing</a>. + +<pre><code> +: (<&gt 'a 'b) +-> T +: (<&gt 'a 'b 'b) +-> T +: (<&gt 'a 'a 'a) +-> NIL +</code></pre> + +<dt><a name="="><code>(= 'any ..) -> flg</code></a> +<dd>Returns <code>T</code> when all <code>any</code> arguments are equal +(structure equality). See also <a href="ref.html#cmp">Comparing</a>. + +<pre><code> +: (= 6 (* 1 2 3)) +-> T +: (= "a" "a") +-> T +: (== "a" "a") +-> T +: (= (1 (2) 3) (1 (2) 3)) +-> T +</code></pre> + +<dt><a name="=0"><code>(=0 'any) -> 0 | NIL</code></a> +<dd>Returns <code>0</code> when <code>any</code> is a number with value zero. +See also <code><a href="refN.html#n0">n0</a></code>, <code><a +href="refL.html#lt0">lt0</a></code>, <code><a +href="refG.html#ge0">ge0</a></code> and <code><a +href="refG.html#gt0">gt0</a></code>. + +<pre><code> +: (=0 (- 6 3 2 1)) +-> 0 +: (=0 'a) +-> NIL +</code></pre> + +<dt><a name="=:"><code>(=: sym|0 [sym1|cnt .. sym2|0] 'any)</code></a> +<dd>Stores a new value <code>any</code> for a property key <code>sym</code> or +<code>sym2</code> (or in the value cell for zero) in a symbol. That symbol is +<code>This</code> (if no other arguments are given), or a symbol found by +applying the <code><a href="refG.html#get">get</a></code> algorithm to +<code>This</code> and the following arguments. Used typically in methods or +<code><a href="refW.html#with">with</a></code> bodies. See also <code><a +href="refP.html#put">put</a></code>, <code><a href="ref_.html#:">:</a></code> +and <code><a href="ref_.html#::">::</a></code>. + +<pre><code> +: (with 'X (=: a 1) (=: b 2)) +-> 2 +: (get 'X 'a) +-> 1 +: (get 'X 'b) +-> 2 +</code></pre> + +<dt><a name="=="><code>(== 'any ..) -> flg</code></a> +<dd>Returns <code>T</code> when all <code>any</code> arguments are the same +(pointer equality). See also <code><a href="refN.html#n==">n==</a></code> and <a +href="ref.html#cmp">Comparing</a>. + +<pre><code> +: (== 'a 'a) +-> T +: (== 'NIL NIL (val NIL) (car NIL) (cdr NIL)) +-> T +: (== (1 2 3) (1 2 3)) +-> NIL +</code></pre> + +<dt><a name="===="><code>(==== ['sym ..]) -> NIL</code></a> +<dd>Close the current transient scope by clearing the transient index. All +transient symbols become hidden and inaccessible by the reader. Then any +optional <code>sym</code> arguments are (re-)inserted into the transient index. +See also <code><a href="refE.html#extern">extern</a></code> and <code><a +href="refI.html#intern">intern</a></code>. + +<pre><code> +: (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 +</code></pre> + +<dt><a name="=T"><code>(=T 'any) -> flg</code></a> +<dd>Returns <code>T</code> when <code>any</code> is the symbol <code>T</code>. +<code>(=T X)</code> is equivalent to <code>(== T X)</code>. See also <a +href="refN.html#nT">nT</a>. + +<pre><code> +: (=T 0) +-> NIL +: (=T "T") +-> NIL +: (=T T) +-> T +</code></pre> + +<dt><a name=">"><code>(> 'any ..) -> flg</code></a> +<dd>Returns <code>T</code> when all arguments <code>any</code> are in strictly +decreasing order. See also <a href="ref.html#cmp">Comparing</a>. + +<pre><code> +: (> 4 3) +-> T +: (> 'A 999) +-> T +</code></pre> + +<dt><a name=">="><code>(>= 'any ..) -> flg</code></a> +<dd>Returns <code>T</code> when all arguments <code>any</code> are in strictly +non-increasing order. See also <a href="ref.html#cmp">Comparing</a>. + +<pre><code> +: (>= 'A 999) +-> T +: (>= 3 2 2 1) +-> T +</code></pre> + +<dt><a name=">>"><code>(>> 'cnt 'num) -> num</code></a> +<dd>Shifts right the <code>num</code> argument by <code>cnt</code> +bit-positions. If <code>cnt</code> is negative, a corresponding left shift is +performed. + +<pre><code> +: (>> 1 8) +-> 4 +: (>> 3 16) +-> 2 +: (>> -3 16) +-> 128 +: (>> -1 -16) +-> -32 +</code></pre> + +<dt><a name="?"><code>(? [sym ..] [pat 'any ..] . lst) -> flg</code></a> +<dd>Top-level function for interactive <a href="ref.html#pilog">Pilog</a> +queries. <code>?</code> is a non-evaluating front-end to the <code><a +href="refQ.html#query">query</a></code> function. It displays each result, waits +for console input, and terminates when a non-empty line is entered. If a +preceding list of (non-pattern-) symbols is given, they will be taken as rules +to be traced by <code><a href="refP.html#prove">prove</a></code>. The list of +variable/value pairs is passed to <code><a href="refG.html#goal">goal</a></code> +for an initial Pilog environment. See also <code><a +href="refP.html#pilog">pilog</a></code> and <code><a +href="refS.html#solve">solve</a></code>. + +<pre><code> +: (? (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). # Stopped +-> 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 +</code></pre> + +<dt><a name="@"><code>@</code></a> +<dd>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 <code><a href="ref.html#atres">@ +Result</a></code>). When <code>@</code> is used as a formal parameter in <a +href="ref.html#lambda">lambda expressions</a>, it denotes a variable number of +evaluated arguments. + +<dt><a name="@@"><code>@@</code></a> +<dd>Holds the result of the second last top level expression in the current +read-eval-print loop (see <code><a href="ref.html#atres">@ Result</a></code>). + +<dt><a name="@@@"><code>@@@</code></a> +<dd>Holds the result of the third last top level expression in the current +read-eval-print loop (see <code><a href="ref.html#atres">@ Result</a></code>). + +<dt><a name="^"><code>^</code></a> +<dd>Holds the currently executed expression during a breakpoint or an error. See +also <code><a href="refD.html#debug">debug</a></code>, <code><a +href="ref_.html#!">!</a></code>, <code><a href="refE.html#e">e</a></code> and +<code><a href="refD.html#*Dbg">*Dbg</a></code>. + +<pre><code> +: (* (+ 3 4) (/ 7 0)) +!? (/ 7 0) +Div/0 +? ^ +-> (/ 7 0) +</code></pre> + +<dt><a name="|"><code>(| 'num ..) -> num</code></a> +<dd>Returns the bitwise <code>OR</code> of all <code>num</code> arguments. When +one of the arguments evaluates to <code>NIL</code>, it is returned immediately. +See also <code><a href="refX.html#x|">x|</a></code>, <code><a +href="ref_.html#&">&</a></code> and <code><a +href="refB.html#bit?">bit?</a></code>. + +<pre><code> +: (| 1 2) +-> 3 +: (| 1 2 4 8) +-> 15 +</code></pre> + +</dl> + +</body> +</html> diff --git a/doc/rlook.html b/doc/rlook.html @@ -0,0 +1,67 @@ +<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN" + "http://www.w3.org/TR/html4/loose.dtd"> +<html> +<head> + <meta http-equiv="content-type" content="text/html; charset=utf-8"> + <title>PicoLisp RefLook</title> + <meta name="generator" content="BBEdit 8.6"> + <style type="text/css"> + <!-- +body { + margin-left: 0.5em; + margin-right: 0; + background-color: #eee; +} +ul { + margin-left: 0; + padding-left: 1.1em; +} +li { + margin-bottom: 0.4em; +} +ul.sub { + padding-left: 0.5em; + font-size: 75%; +} +ul.sub li { + margin-bottom: 0.3em; +} +input { + margin-top: 0.3em; +} + --> + </style> + <script type="text/javascript" language="javascript"> + <!-- +function searchKeyup(searchField) { + try { + var sWord = searchField.value; + if (sWord) { + var sUrl; + if (sWord == "NIL") { + sUrl = "ref.html#nilSym"; + } else if (sWord.match(/^[a-zA-Z_]/)) { + sUrl = "ref" + sWord.substring(0, 1).toUpperCase() + ".html#" + sWord; + } else if (sWord.match(/^\*[a-zA-Z_]/)) { + sUrl = "ref" + sWord.substring(1, 2) + ".html#" + sWord; + } else { + sUrl = "ref_.html#" + sWord; + } + window.top.lower.location = sUrl; + } + } catch (e) { + alert(e); + } +} + //--> + </script> +</head> +<body> + <ul> + <li> + <a href="ref.html" target="lower">Reference</a> lookup<br> + <input type="text" size="13" onkeyup="searchKeyup(this)"> + </li> + </ul> +</body> +</html> diff --git a/doc/select.html b/doc/select.html @@ -0,0 +1,490 @@ +<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.0 Transitional//EN" "http://www.w3.org/TR/REC-html40/loose.dtd"> +<html lang="en"> +<head> +<meta http-equiv="Content-Type" content="text/html; charset=utf-8"> +<title>The 'select' Predicate</title> +<link rel="stylesheet" href="doc.css" type="text/css"> +</head> +<body> +<a href="mailto:abu@software-lab.de">abu@software-lab.de</a> + +<h1>The 'select' Predicate</h1> + +<p align=right>(c) Software Lab. Alexander Burger + +<p>The <a href="ref.html#pilog">Pilog</a> <a +href="refS.html#select/3">select/3</a> predicate is rather complex, and quite +different from other predicates. This document tries to explain it in detail, +and shows some typical use cases. + +<p><ul> +<li><a href="#syntax">Syntax</a> +<li><a href="#example1">First Example</a> +<li><a href="#univar">Unification Variables</a> +<li><a href="#gencl">Generator Clauses</a> + <ul> + <li><a href="#db">B-Tree Stepping</a> + <li><a href="#interaction">Interaction of Generator Clauses</a> + <li><a href="#combined">Combined Indexes</a> + <li><a href="#associations">Indirect Object Associations</a> + <li><a href="#nested">Nested Pilog Queries</a> + </ul> +<li><a href="#filcl">Filter Clauses</a> + <ul> + <li><a href="#little">A Little Report</a> + <li><a href="#filpr">Filter Predicates</a> + </ul> +</ul> + + +<p><hr> +<h2><a name="syntax">Syntax</a></h2> + +<p><code>select</code> takes at least three arguments: + +<p><ul> +<li>A list of unification variables, +<li>a list of generator clauses +<li>and an arbitrary number of filter clauses +</ul> + +<p>We will describe these arguments in the following, but demonstrate them first +on a concrete example. + + +<p><hr> +<h2><a name="example1">First Example</a></h2> + +<p>The examples in this document will use the demo application in "app/*.l" (see +also "<a href="app.html#minApp">A Minimal Complete Application</a>"). To get an +interactive prompt, simply start it as + +<pre><code> +$ ./dbg app/main.l -main +: +</code></pre> + +<p>As ever, you can terminate the interpreter by hitting ENTER. + +<p>For a first, typical example, let's write a complete call to <a +href="refS.html#solve">solve</a> that returns a list of articles with numbers +between 1 and 4, which contain "Part" in their description, and have a price +less than 100: + +<pre><code> +(let (Nr (1 . 4) Nm <u>Part</u> 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 ) ) +</code></pre> + +<p>This expression will return, with the default database setup of "app/init.l", +a list of exactly one item <code>({3-2})</code>, the item with the number 2. + +<p>The <code><a href="refL.html#let">let</a></code> statement assigns values to +the search parameters for number <code>Nr</code>, description <code>Nm</code> +and price <code>Pr</code>. The Pilog query (the first argument to +<code>solve</code>) passes these values to the Pilog variables <code>@Nr</code>, +<code>@Nm</code> and <code>@Pr</code>. Ranges of values are always specified by +cons pairs, so <code>(1 . 4)</code> includes the numbers 1 through 4, while +<code>(NIL . 100.00)</code> includes prices from minus infinite up to one +hundred. + +<p>The list of unification variables is + +<pre><code> + <code>(@Item)</code> +</code></pre> + +<p>The list of generator clauses is + +<pre><code> + ((nr +Item @Nr) (nm +Item @Nm) (pr +Item @Pr)) +</code></pre> + +<p>The filter clauses are + +<pre><code> + (range @Nr @Item nr) + (part @Nm @Item nm) + (range @Pr @Item pr) +</code></pre> + + +<p><hr> +<h2><a name="univar">Unification Variables</a></h2> + +<p>As stated above, the first argument to <code>select</code> should be a list +of variables. These variables communicate values (via <code><a +href="refU.html#unify">unify</a></code>) from the <code>select</code> +environment to the enclosing Pilog environment. + +<p>The first variable in this list (<code>@Item</code> in the above example) is +mandatory, it takes the direct return value of <code>select</code>. Additional +optional variables may be unified by clauses in the body of <code>select</code>, +and return further values. + + +<p><hr> +<h2><a name="gencl">Generator Clauses</a></h2> + +<p>The second argument to <code>select</code> is a list of "generator clauses". +Each of these clauses specifies some kind of database B-Tree <code><a +href="refI.html#+index">+index</a></code>, to be traversed by +<code>select</code>, 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. <code>nr</code>), a class (e.g. <code>+Item</code>), an optional hook +specifier (not in this example), and a pattern (values or ranges, e.g. (1 . 4) +or "Part"). + +<p>The generator clauses are the core of 'select'. In some way, they behave +analog to <code><a href="refO.html#or/2">or/2</a></code>, 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 +<code>select</code>'s filter clauses. + + +<p><hr> +<h3><a name="db">B-Tree Stepping</a></h3> + +<p>In its basic form, a generator clause is equivalent to the <code><a +href="refD.html#db/3">db/3</a></code> predicate, stepping through a single +B-Tree. The clause + +<pre><code> +(nr +Item @Nr) +</code></pre> + +<p>generates the same values as would be produced by a stand-alone Pilog clause + +<pre><code> +(db nr +Item @Nr @Item) +</code></pre> + +<p>as can be seen in the following two calls: + +<pre><code> +: (? (db nr +Item (1 . 4) @Item)) + @Item={3-1} + @Item={3-2} + @Item={3-3} + @Item={3-4} +-> NIL +: (? (select (@Item) ((nr +Item (1 . 4))))) + @Item={3-1} + @Item={3-2} + @Item={3-3} + @Item={3-4} +-> NIL +</code></pre> + + +<p><hr> +<h3><a name="interaction">Interaction of Generator Clauses</a></h3> + +<p><code>select</code> is mostly useful if more than one generator clause is +involved. The tree search parameters of all clauses are meant to form a logical +<code>AND</code>. 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 +<code>select</code> will terminate, because further values returned from other +generator clauses cannot be part of the result set. + +<p>Therefore, <code>select</code> 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. + +<p>Instead, <code>select</code> 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. + + +<p><hr> +<h3><a name="combined">Combined Indexes</a></h3> + +<p>A generator clause can also combine several (similar) indexes into a single +one. Then the clause is written actually as a list of clauses. + +<p>For example, a generator clause to search for a customer by phone number is + +<pre><code> +(tel +CuSu @Tel) +</code></pre> + +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 + +<pre><code> +((tel +CuSu @Tel mob +CuSu @Tel)) +</code></pre> + +<p>The generator will first traverse all matching entries in the <code><a +href="refR.html#+Ref">+Ref</a></code> tree of the <code>tel</code> relation, and +then, when these are exhausted, all matching entries in the <code>mob</code> +index tree. + + +<p><hr> +<h3><a name="associations">Indirect Object Associations</a></h3> + +<p>But generator clauses are not limited to the direct B-Tree interaction of +<code><a href="refD.html#db/3">db/3</a></code>. They can also traverse trees of +associated objects, and then follow <code><a +href="refL.html#+Link">+Link</a></code> / <code><a +href="refJ.html#+Joint">+Joint</a></code> relations, or tree relations like +<code><a href="refR.html#+Ref">+Ref</a></code> to arrive at database objects +with a type suitable for return values from <code>select</code>. + +<p>To locate appropriate objects from associated objects, the generator clause +can contain - in addition to the standard relation/class/pattern specification +(see <a href="#gencl">Generator Clauses</a> above) - an arbitrary number of +association specifiers. Each association specifier can be + +<ol> +<li>A symbol. Then a <code><a href="refL.html#+Link">+Link</a></code> or +<code><a href="refJ.html#+Joint">+Joint</a></code> will be followed, or a +<code><a href="refL.html#+List">+List</a></code> of those will be traversed to +locate appropriate objects. + +<li>A list. Then this list should hold a relation and a class (and an optional +hook) which specify some B-Tree <code><a +href="refI.html#+index">+index</a></code> to be traversed to locate appropriate +objects. + +</ol> + +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 <code>+Ord</code> (order) objects. Orders can +be searched for order number and date, customer name and city, item description +and supplier name: + +<pre><code> +(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) ) +</code></pre> + +<p>While <code>(nr +Ord @Nr)</code> and <code>(dat +Ord @Dat)</code> are direct +index traversals, <code>(nm +CuSu @Cus (cus +Ord))</code> iterates the +<code>nm</code> (name) index of customers/suppliers <code>+CuSu</code>, and then +follows the <code><a href="refR.html#+Ref">+Ref</a></code> <code><a +href="refL.html#+Link">+Link</a></code> of the <code>cus</code> relation to the +orders. The same applies to the search for city names via <code>ort</code>. + +<p>The most complex example is <code>(nm +CuSu @Sup (sup +Item) (itm +Pos) +ord)</code>, where the supplier name is searched in the <code>nm</code> tree of +<code>+CuSu</code>, then the <code><a href="refR.html#+Ref">+Ref</a></code> tree +<code>(sup +Item)</code> tree is followed to locate items of that supplier, then +all positions for those items are found using <code>(itm +Pos)</code>, and +finally the <code>ord</code> <code><a href="refJ.html#+Joint">+Joint</a></code> +is followed to arrive at the order object(s). + + +<p><hr> +<h3><a name="nested">Nested Pilog Queries</a></h3> + +<p>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 <code><a +href="refR.html#remote/2">remote/2</a></code> predicate, or some other resource +not accessible via database indexes, like iterating a <code><a +href="refL.html#+List">+List</a></code> of <code><a +href="refL.html#+Link">+Link</a></code>s or <code><a +href="refJ.html#+Joint">+Joint</a></code>s. + +<p>Syntactically, such a generator clause is recognized by the fact that its CAR +is a Pilog variable to denote the return value. + +<p>The second argument is a list of Pilog variables to communicate values (via +<code><a href="refU.html#unify">unify</a></code>) from the surrounding +<code>select</code> environment. + +<p>The third argument is the actual list of clauses for the nested query. + +<p>Finally, an arbitrary number of association specifiers may follow, as +described in the <a href="#associations">Indirect Object Associations</a> +section. + +<p>We can illustrate this with a somewhat useless (but simple) example, which +replaces the standard generators for item number and supplier name + +<pre><code> +(select (@Item) + ( + (nr +Item @Nr) + (nm +CuSu @Sup (sup +Item)) + ) + ... +</code></pre> + +<p>with the equivalent form + +<pre><code> +(select (@Item) + ( + (@A (@Nr) ((db nr +Item @Nr @A))) + (@B (@Sup) ((db nm +CuSu @Sup @B)) (sup +Item)) + ) +</code></pre> + +<p>That is, a query with the <code><a href="refD.html#db/3">db/3</a></code> tree +iteration predicate is used to generate appropriate values. + + +<p><hr> +<h2><a name="filcl">Filter Clauses</a></h2> + +<p>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 <code>select</code> 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 <a href="#gencl">Generator Clauses</a>). + +<p><code>select</code> 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. + +<p>Technically, the filters are normal Pilog clauses, which just happen to be +evaluated in the context of <code>select</code>. Arbitrary Pilog predicates can +be used, though there exist some predicates (e.g. <code><a +href="refI.html#isa/2">isa/2</a></code>, <code><a +href="refS.html#same/3">same/3</a></code>, <code><a +href="refB.html#bool/3">bool/3</a></code>, <code><a +href="refR.html#range/3">range/3</a></code>, <code><a +href="refH.html#head/3">head/3</a></code>, <code><a +href="refF.html#fold/3">fold/3</a></code>, <code><a +href="refP.html#part/3">part/3</a></code> or <code><a +href="refT.html#tolr/3">tolr/3</a></code>) especially suited for that task. + + +<p><hr> +<h3><a name="little">A Little Report</a></h3> + +<p>Assume we want to know how many pieces of item #2 were sold in the year 2007. +Then we must find all <code>+Pos</code> (position) objects referring to that +item and at the same time belonging to orders of the year 2007 (see the class +definition for <code>+Pos</code> in "app/er.l"). The number of sold pieces is +then in the <code>cnt</code> property of the <code>+Pos</code> objects. + +<p>As shown in the complete <code>select</code> below, we will hold the item +number in the variable <code>@Nr</code> and the date range for the year in +<code>@Year</code>. + +<p>Now, all positions referred by item #2 can be found by the generator clause + +<pre><code> +(nr +Item @Nr (itm +Pos)) +</code></pre> + +<p>and all positions sold in 2007 can be found by + +<pre><code> +(dat +Ord @Year pos) +</code></pre> + +<p>However, the combination of both generator clauses + +<pre><code> +(select (@Pos) + ((nr +Item @Nr (itm +Pos)) (dat +Ord @Year pos)) ) +</code></pre> + +<p>will probably generate too many results, namely all positions with item #3 +<u>OR</u> from the year 2007. Thus, we need two filter clauses. With them, the +full search expression will be: + +<pre><code> +(? + @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 +</code></pre> + +<p>For completeness, let's calculate the total count of sold items: + +<pre><code> +(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 +</code></pre> + + +<p><hr> +<h3><a name="filpr">Filter Predicates</a></h3> + +<p>As mentioned under <a href="#filcl">Filter Clauses</a>, some predicates +exists mainly for <code>select</code> filtering. + +<p>Some of these predicates are of general use: <code><a +href="refI.html#isa/2">isa/2</a></code> can be used to check for a type, +<code><a href="refS.html#same/3">same/3</a></code> checks for a definite vaue, +<code><a href="refB.html#bool/3">bool/3</a></code> looks if the value is +non-<code>NIL</code>. These predicates are rather independent of the <code><a +href="refR.html#+relation">+relation</a></code> type. + +<p><code><a href="refR.html#range/3">range/3</a></code> checks whether a value +is within a given range. This could be used with any <code><a +href="refR.html#+relation">+relation</a></code> type, but typically it will be +used for numeric (<code><a href="refN.html#+Number">+Number</a></code>) or time +( <code><a href="refD.html#+Date">+Date</a></code> and <code><a +href="refT.html#+Time">+Time</a></code>) relations. + +<p>Other predicates make only sense in the context of a certain <code><a +href="refR.html#+relation">+relation</a></code> type: + +<ul> +<li><code><a href="refH.html#head/3">head/3</a></code> is mainly intended for +<code>(<a href="refK.html#+Key">+Key</a> <a +href="refS.html#+String">+String</a>)</code> or <code>(<a +href="refR.html#+Ref">+Ref</a> <a href="refS.html#+String">+String</a>)</code> +relations, + +<li><code><a href="refF.html#fold/3">fold/3</a></code> is useful for <code>(<a +href="refF.html#+Fold">+Fold</a> <a href="refR.html#+Ref">+Ref</a> <a +href="refS.html#+String">+String</a>)</code> relations, + +<li><code><a href="refP.html#part/3">part/3</a></code> for <code>(<a +href="refF.html#+Fold">+Fold</a> <a href="refI.html#+Idx">+Idx</a> <a +href="refS.html#+String">+String</a>)</code> relations, and + +<li><code><a href="refT.html#tolr/3">tolr/3</a></code> for <code>(<a +href="refS.html#+Sn">+Sn</a> <a href="refI.html#+Idx">+Idx</a> <a +href="refS.html#+String">+String</a>)</code> relations. + +</ul> + +</body> +</html> diff --git a/doc/shape.l b/doc/shape.l @@ -0,0 +1,59 @@ +# 25jun07abu +# (c) Software Lab. Alexander Burger + +# The Shape base class +(class +Shape) +# x y + +(dm T (X Y) + (=: x X) + (=: y Y) ) + +(dm move> (DX DY) + (inc (:: x) DX) + (inc (:: y) DY) ) + + +# The Rectangle class +(class +Rectangle +Shape) +# dx dy + +(dm T (X Y DX DY) + (super X Y) + (=: dx DX) + (=: dy DY) ) + +(dm area> () + (* (: dx) (: dy)) ) + +(dm perimeter> () + (* 2 (+ (: dx) (: dy))) ) + +(dm draw> () + (drawRect (: x) (: y) (: dx) (: dy)) ) # Hypothetical function 'drawRect' + + +# The Circle class +(class +Circle +Shape) +# r + +(dm T (X Y R) + (super X Y) + (=: r R) ) + +(dm area> () + (*/ (: r) (: r) 31415927 10000000) ) + +(dm perimeter> () + (*/ 2 (: r) 31415927 10000000) ) + +(dm draw> () + (drawCircle (: x) (: y) (: r)) ) # Hypothetical function 'drawCircle' + + +# The Fixed prefix class +(class +Fixed) + +(dm move> (DX DY)) # A do-nothing method + +# vi:et:ts=3:sw=3 diff --git a/doc/structures b/doc/structures @@ -0,0 +1,90 @@ + + Primary data types: + + xxxxxxxxxxxxxxxxxxxxxxxxxxxxx010 Number + xxxxxxxxxxxxxxxxxxxxxxxxxxxxx100 Symbol + xxxxxxxxxxxxxxxxxxxxxxxxxxxxx000 Cell + + + Number + | + V + +-----+-----+ +-----+-----+ +-----+-----+ + |'DIG'| ---+---> |'DIG'| ---+---> |'DIG'| / | + +-----+-----+ +-----+-----+ +-----+-----+ + + + Cell + | + V + +-----+-----+ + | CAR | CDR | + +-----+-----+ + + + Symbol + | + V + +-----+-----+ + | | | VAL | + +--+--+-----+ + | tail + | + V name + +-----+-----+ +-----+-----+ +-----+-----+ +-----+-----+ + | | | ---+---> | KEY | ---+---> | | | ---+---> |'cba'| / | + +--+--+-----+ +-----+-----+ +--+--+-----+ +-----+-----+ + | | + V V + +-----+-----+ +-----+-----+ + | VAL | KEY | | VAL | KEY | + +-----+-----+ +-----+-----+ + + + NIL: / + | + V + +-----+-----+-----+-----+ + | / | / | / | / | + +-----+--+--+-----+-----+ + + + + External Symbols: + + +-------------+-+-------------+-+----+ + 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 bits per byte + - word: sizeof(void*) == sizeof(unsigned long) + - word2: sizeof(unsigned long long) == 2 * sizeof(unsigned long) + - gcc + Functions aligned to 4-byte boundaries + Zero- or variable-length arrays + Conditionals with Omitted Operands + Unused argument attributes + Noreturn attributes diff --git a/doc/toc.html b/doc/toc.html @@ -0,0 +1,41 @@ +<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN" + "http://www.w3.org/TR/html4/loose.dtd"> +<html> +<head> + <meta http-equiv="content-type" content="text/html; charset=utf-8"> + <title>PicoLisp Doc TOC</title> + <meta name="generator" content="BBEdit 8.6"> + <style type="text/css"> + <!-- +body { + margin-left: 0.5em; + margin-right: 0; + background-color: #eee; +} +ul { + margin-left: 0; + padding-left: 1.1em; +} +li { + margin-bottom: 0.4em; +} +ul.sub { + padding-left: 0.5em; + font-size: 75%; +} +ul.sub li { + margin-bottom: 0.3em; +} + --> + </style> +</head> +<body> + <h3>PicoLisp Docs</h3> + <ul id="upperul"> + <li><a href="ref.html#fun" target="upper">Function Ref.</a></li> + <li><a href="tut.html" target="upper">Tutorial</a></li> + <li><a href="app.html" target="upper">Application Dev.</a></li> + <li><a href="faq.html" target="upper">FAQ</a></li> + </ul> +</body> +</html> diff --git a/doc/travel b/doc/travel @@ -0,0 +1,24 @@ + + Rheine Osnabrueck + O-----------42----------O-----------------48-------------+ + | | | + |39 +--------+ | + | | |43 | + | +---51---+ | | + | | | Warendorf Guetersloh | + O-----+-----28--------+-O-+--------27--------O-----16----O Bielefeld + | Muenster | | | | | + | | | | +-----+ | + | +--+ | +--+ | | | + | | | | Rheda | | | + | 27| |27 +-24---O---10---+ | | + |46 +---+ | | |31 | + | | | +--+-----+ | |39 + | | | Beckum | | | | | + +--------------O---11---O-----24-+ | |32 | | + Ahlen | | | | | | + | 26| | +--------+-----+ + | +-----38----+ | + | | | + +---27---O---------------41---------------+ + Soest Paderborn diff --git a/doc/tut.html b/doc/tut.html @@ -0,0 +1,2402 @@ +<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.0 Transitional//EN" "http://www.w3.org/TR/1998/REC-html40-19980424/loose.dtd"> +<html lang="en"> +<head> +<meta http-equiv="Content-Type" content="text/html; charset=utf-8"> +<title>PicoLisp Tutorial</title> +<link rel="stylesheet" href="doc.css" type="text/css"> +</head> +<body> +<a href="mailto:abu@software-lab.de">abu@software-lab.de</a> + +<h1>A PicoLisp Tutorial</h1> + +<p align=right>(c) Software Lab. Alexander Burger + +<p>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 <a +href="ref.html">PicoLisp Reference</a>. + +<p>This is <i>not</i> a Lisp tutorial, as it assumes some working knowledge of +Lisp (and programming in general). It concentrates on the specialties of +PicoLisp, and its differences to other Lisp dialects. + +<p>If not stated otherwise, all examples assume that PicoLisp was started in the +installation directory from the shell prompt as + +<pre><code> +$ ./dbg +: +</code></pre> + +<p>It loads the PicoLisp base system and the debugging environment, and waits +for you to enter input lines at the interpreter prompt (<code>:</code>). You can +terminate the interpreter and return to the shell at any time, by either hitting +the ENTER key (i.e. by entering an empty line), or by executing the function +<code><a href="refB.html#bye">(bye)</a></code>. + +<p>It is very helpful - though not absolutely necessary - when you know how to +use the <code>vi</code> editor. + +<p>We notice that some people try to use Emacs - or some other IDE - as a +front-end to the PicoLisp console. This is not recommended, because the PicoLisp +debugging environment will set the console (tty) to raw mode by itself and do +some special handling during character input. + +<p>If you feel that you absolutely have to use an input front-end, please remove +the entry "@lib/led.l" from "dbg.l". Note that in this case, however, you will +not have the TAB symbol completion feature available during command line +editing. + +<p>We recommend that you have a terminal window open, and try the examples by +yourself. You may either type them in, directly to the PicoLisp interpreter, or +edit a separate source file (e.g. <code>"test.l"</code>) in a second terminal +window and load it into PicoLisp with + +<pre><code> +: (load "test.l") +</code></pre> + +<p>each time you have modified and saved it. + +<p>Once a function is loaded from a source file, you can call 'vim' directly on +that function with + +<pre><code> +: (vi 'foo) +</code></pre> + +<p>The function 'vi' opens the appropriate source file, and jumps to the right +line where 'foo' is defined. When you modify it, you can simply call 'ld' to +(re)load that source file + +<pre><code> +: (ld) +</code></pre> + +<p>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. + +<p><ul> +<li><a href="#ledit">Command Line Editing</a> +<li><a href="#brw">Browsing</a> +<li><a href="#fun">Defining Functions</a> +<li><a href="#dbg">Debugging</a> +<li><a href="#funio">Functional I/O</a> +<li><a href="#script">Scripting</a> +<li><a href="#oop">Objects and Classes</a> +<li><a href="#ext">Persistence (External Symbols)</a> +<li><a href="#db">Database Programming</a> +<li><a href="#gui">User Interface (GUI) Programming</a> +<li><a href="#pilog">Pilog -- PicoLisp Prolog</a> +<li><a href="#sql">Poor Man's SQL</a> +<li><a href="#ref">References</a> +</ul> + + +<p><hr> +<h2><a name="ledit">Command Line Editing</a></h2> + +<p>PicoLisp permanently reads input from the current input channel (i.e. the +console in interactive mode), evaluates it, and prints the result to the current +output channel. This is called a "read-eval-print-loop" (REPL). + +<p>To alleviate the task of manual line input, a command line editor is provided +which is similar to (though much simpler than) the <code>readline</code> feature +of the <code>bash</code> shell. Only a subset of the <code>vi</code> mode is +supported, which is restricted to single-key commands (the "real" +<code>vi</code> supports multi-key commands and the modification of most +commands with count prefixes). It is loaded at startup via "dbg.l", you find its +source in "lib/led.l". + +<p>You can enter lines in the normal way, correcting mistypes with the BACKSPACE +key, and terminating them with the ENTER key. This is the <i>Insert Mode</i>. + +<p>If you hit ESC, you get into <i>Command Mode</i>. Now you can navigate +horizontally in the current input line, or vertically in the history of +previously entered lines, with key commands borrowed from the <code>vi</code> +editor. Note, however, that there is always only a single line visible. + +<p>Let's say you did some calculation + +<pre><code> +: (* (+ 2 3) (- 7 2)) +-> 25 +: +</code></pre> + +<p>If you want to repeat a modified version of this command, using +<code>8</code> instead of <code>7</code>, you don't have to re-type the +whole command, but type + +<p><ul> +<li>ESC to get into <i>Command Mode</i> +<li><code>k</code> to get one line "up" +<li><code>f</code> and <code>7</code> to "find" the character <code>7</code> +<li><code>r</code> and <code>8</code> to "replace" with <code>8</code> +</ul> + +<p>Then you hit ENTER to execute the modified line. Instead of jumping to the +<code>7</code> with the "find" command, you may also type <code>l</code> (move +"right") repeatedly till you reach the correct position. + +<p>The key commands in the <i>Command Mode</i> are listed below. Some commands +change the mode back to <i>Insert Mode</i> as indicated in parentheses. Commands +which operate on a "word" take either the current atom (number or symbol), or a +whole expression when the cursor is at a left parenthesis. + +<p><ul> +<li><code>k</code> - Go up one line +<li><code>j</code> - Go down one line +<li><code>l</code> - Go right one character +<li><code>h</code> - Go left one character +<li><code>w</code> - Go right one word +<li><code>b</code> - Go back (left) one word +<li><code>0</code> - Go to the beginning of the line +<li><code>$</code> - Go to the end of the line +<li><code>i</code> - Enter <i>Insert Mode</i> at the cursor position +<li><code>a</code> - Append (<i>Insert Mode</i>) after the cursor position +<li><code>A</code> - Append (<i>Insert Mode</i>) at the end of the line +<li><code>I</code> - Insert (<i>Insert Mode</i>) at the beginning of the line +<li><code>x</code> - Delete the character at the cursor position +<li><code>X</code> - Delete the character left of the cursor position +<li><code>r</code> - Replace the character at the cursor position with the next key +<li><code>s</code> - Substitute the character at the cursor position (<i>Insert Mode</i>) +<li><code>S</code> - Substitute the whole line (<i>Insert Mode</i>) +<li><code>d</code> - Delete the word at the cursor position (<i>Insert Mode</i>) +<li><code>D</code> - Delete the rest of the line +<li><code>c</code> - Change the word at the cursor position (<i>Insert Mode</i>) +<li><code>C</code> - Change the rest of the line (<i>Insert Mode</i>) +<li><code>f</code> - Find next key in the rest of the current line +<li><code>p</code> - Paste data deleted with <code>x</code>, <code>X</code>, <code>d</code> or <code>D</code> after the cursor position +<li><code>P</code> - Paste data deleted with <code>x</code>, <code>X</code>, <code>d</code> or <code>D</code> before the cursor position +<li><code>/</code> - Accept an input pattern and search the history for it +<li><code>n</code> - Search for next occurrence of pattern (as entered with <code>/</code>) +<li><code>N</code> - Search for previous occurrence of pattern +<li><code>%</code> - Go to matching parenthesis +<li><code>~</code> - Convert character to opposite (lower or upper) case and move right +<li><code>u</code> - Undo the last change (one level only) +<li><code>U</code> - Undo all changes of the current line +<li><code>g</code> - Display current contents of cut buffer (not in <code>vi</code>) +</ul> + +<p>Notes: +<ul> + +<li>The <code>d</code> command corresponds to the <code>dw</code> command of the +<code>vi</code> editor, and <code>c</code> corresponds to <code>cw</code>. + +<li>Search patterns may contain "<code>@</code>" characters as wildcards. + +<li>Lines shorter than 3 characters, lines beginning with a space character, or +duplicate lines are not entered into the history. + +<li>The history is stored in a file named ".picoHistory" in the PicoLisp home +directory. The length of the history is limited to 1000 lines. + +</ul> + +<p>The following two key-combinations work both in Insert and Command Mode: + +<p><ul> + +<li><code>Ctrl-D</code> will immediately terminate the current process, and also +all of its sister processes (i.e. children of the same parent process, typically +an application server during debugging). + +<li><code>Ctrl-X</code> discards all input, abandons further processing, and +returns to the interpreter's top level (equivalent to invoking <code><a +href="refQ.html#quit">quit</a></code>). This is also useful when the program +stopped at a breakpoint, or after program execution was interrupted with +<code>Ctrl-C</code>. + +</ul> + +<p>Besides these two keys, in <i>Insert Mode</i> only the following keys have a +special meaning: + +<p><ul> + +<li>BACKSPACE (<code>Ctrl-H</code>) and DEL erase the character to the left + +<li><code>Ctrl-V</code> inserts the next key literally + +<li>TAB performs symbol and/or path completion: When a symbol (or path) name is +entered partially and TAB is pressed subsequently, all internal symbols (and/or +path names in the file system) matching the partial input are shown in sequence. + +<li>ESC terminates <i>Input Mode</i> and enters <i>Command Mode</i> + +</ul> + +<p>Please take some time to experiment and to get used to command line editing. +It will make life much easier in the future :-) + + +<p><hr> +<h2><a name="brw">Browsing</a></h2> + +<p>PicoLisp provides some functionality for inspecting pieces of data and code +within the running system. + +<p>Most commonly used is probably the <code><a +href="refS.html#show">show</a></code> function. It takes a symbolic argument, +and shows the symbol's name (if any), followed by its value cell, and then the +contents of the property list on the following lines. + +<pre><code> +: (setq A '(This is the value)) # Set the value cell 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 +</code></pre> + +<p><code>show</code> accepts an arbitrary number of arguments which are +processed according to the rules of <code><a +href="refG.html#get">get</a></code>, resulting in a symbol which is showed then. + +<pre><code> +: (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 +</code></pre> + +<p>Similar to <code>show</code> is <code><a +href="refE.html#edit">edit</a></code>. It takes an arbitrary number of symbolic +arguments, writes them to a temporary file in a format similar to +<code>show</code>, and starts the <code>vim</code> editor with that file. + +<pre><code> +: (edit 'A 'B) +</code></pre> + +<p>The <code>vim</code> window will look like + +<pre><code> +A (This is the value) +key1 val1 +key2 val2 + +(********) + +B NIL +a A # (This is the value) + +(********) +</code></pre> + +<p>Now you can modify values or properties. You should not touch the +parenthesized asterisks, as they serve as delimiters. If you position the cursor +on the first character of a symbol name and type '<code>K</code>' ("Keyword +lookup"), the editor will be restarted with that symbol added to the editor +window. '<code>Q</code>' (for "Quit") will bring you back to the previous view. + +<p><code>edit</code> is also very useful to browse in a database. You can follow +the links between objects with '<code>K</code>', 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 <code><a href="refC.html#commit">commit</a></code> +when you are done). + +<p><code><a href="refM.html#more">more</a></code> 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, <code>more</code> continues with the next element, +otherwise (usually I type a dot (<code>.</code>) followed by ENTER) it +terminates. + +<pre><code> +: (more (1 2 3 4 5 6)) +1 # Hit ENTER +2. # Hit '.' and ENTER +-> T # stopped +</code></pre> + +<p>Optionally <code>more</code> takes a function as a second argument and +applies that function to each element (instead of the default <code><a +href="refP.html#print">print</a></code>). Here, often <code>show</code> or +<code>pp</code> (see below) is used. + +<pre><code> +: (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 +</code></pre> + +<p>The <i>pretty-print</i> function <code><a href="refP.html#pp">pp</a></code> +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. + +<pre><code> +: (pp 'pretty) +(de pretty (X N . @) + (setq N (abs (space (or N 0)))) + (while (args) + (printsp (next)) ) + (if (or (atom X) (>= 12 (size X))) + (print X) + (while (== 'quote (car X)) + (prin "'") + (pop 'X) ) + (let Z X + (prin "(") + (when (memq (print (pop 'X)) "*PP") + (cond + ((memq (car Z) "*PP1") + (if (and (pair (car X)) (pair (cdar X))) + (when (>= 12 (size (car X))) + (space) + (print (pop 'X)) ) + (space) + (print (pop 'X)) + (when (or (atom (car X)) (>= 12 (size (car X)))) + (space) + (print (pop 'X)) ) ) ) + ((memq (car Z) "*PP2") + (inc 'N 3) + (loop + (prinl) + (pretty (cadr X) N (car X)) + (NIL (setq X (cddr X)) (space)) ) ) + ((or (atom (car X)) (>= 12 (size (car X)))) + (space) + (print (pop 'X)) ) ) ) + (when X + (loop + (T (== Z X) (prin " .")) + (T (atom X) (prin " . ") (print X)) + (prinl) + (pretty (pop 'X) (+ 3 N)) + (NIL X) ) + (space) ) + (prin ")") ) ) ) +-> pretty +</code></pre> + +<p>The style is the same as we use in source files: + +<ul> + +<li>The indentation level is three spaces + +<li>If a list is too long (to be precise: if its <code><a +href="refS.html#size">size</a></code> is greater than 12), pretty-print the CAR +on the current line, and each element of the CDR recursively on its own line. + +<li>A closing parenthesis a preceded by a space if the corresponding open +parenthesis is not on the same line + +</ul> + +<p>The <code><a href="refW.html#what">what</a></code> function returns a list of +all internal symbols in the system which match a given pattern (with +'<code>@</code>' wildcard characters). + +<pre><code> +: (what "prin@") +-> (prin print prinl print> printsp println) +</code></pre> + +<p>The function <code><a href="refW.html#who">who</a></code> returns <i>"who +contains that"</i>, i.e. a list of symbols that contain a given argument +somewhere in their value or property list. + +<pre><code> +: (who 'print) +-> ((print> . +relation) query show select pretty "edit" msg rules pp more +(print> . +Date)) </code></pre> + +<p>A dotted pair indicates either a method definition or a property entry. So +<code>(print> . +relation)</code> denotes the <code>print&gt;</code> method of +the <code><a href="refR.html#+relation">+relation</a></code> class. + +<p><code>who</code> can be conveniently combined with <code>more</code> and +<code>pp</code>: + +<pre><code> +: (more (who 'print) pp) +(dm (print> . +relation) (Val) # Pretty-print these functions one by one + (print Val) ) + +(de query ("Q" "Dbg") + ... +</code></pre> + +<p>The argument to <code>who</code> may also be a pattern list (see <code><a +href="refM.html#match">match</a></code>): + +<pre><code> +: (who '(print @ (val @))) +-> (show) + +: (more (who '(% @ 7)) pp) +(de day (Dat Lst) + (get + (or Lst *DayFmt) + (inc (% (inc Dat) 7)) ) ) + +(de _week (Dat) + (/ (- Dat (% (inc Dat) 7)) 7) ) +</code></pre> + +<p>The function <code><a href="refC.html#can">can</a></code> returns a list +which indicates which classes <i>can</i> accept a given message. Again, this +list is suitable for iteration with <code>pp</code>: + +<pre><code> +: (can 'del>) # Which classes accept 'del>' ? +-> ((del> . +relation) (del> . +Entity) (del> . +List)) +: (more (can 'del>) pp) # Inspect the methods with 'pp' +(dm (del> . +relation) (Obj Old Val) + (and (&lt;> Old Val) Val) ) + +(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 @)) ) + (upd> This Var Old) ) ) ) + +(dm (del> . +List) (Obj Old Val) + (and (&lt;> Old Val) (delete Val Old)) ) +</code></pre> + +<p><code><a href="refD.html#dep">dep</a></code> 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. + +<p>To view the complete hierarchy of input fields, we start with the root class +<code><a href="refR.html#+relation">+relation</a></code>: + +<pre><code> +: (dep '+relation) ++relation + +Number + +Time + +Date + +Symbol + +String + +Blob + +Link + +Joint + +Bool + +Any + +Bag +-> +relation +</code></pre> + +<p>If we are interested in <code>+Link</code>: + +<pre><code> +: (dep '+Link) + +relation ++Link + +Joint +-> +Link +</code></pre> + +<p>This says that <code>+Link</code> is a subclass of <code><a +href="refR.html#+relation">+relation</a></code>, and has a single subclass +(<code>+Joint</code>). + + +<p><hr> +<h2><a name="fun">Defining Functions</a></h2> + +<p>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 <code>dm</code> instead of <code>de</code>. + +<p>The notorious "Hello world" function must be defined: + +<pre><code> +: (de hello () + (prinl "Hello world") ) +-> hello +</code></pre> + +<p>The <code>()</code> 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 <code>de</code>. From now on we +will omit the return values of examples when they are unimportant. + +<p>You'll know that you can call this function as + +<pre><code> +: (hello) +Hello world +</code></pre> + +<p>A function with an argument might look this way: + +<pre><code> +: (de hello (X) + (prinl "Hello " X) ) +# hello redefined +</code></pre> + +<p>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. + +<pre><code> +: (hello "world") +Hello world +</code></pre> + +<pre><code> +: (hello "Alex") +Hello Alex +</code></pre> + +<p>Normally, PicoLisp evaluates the arguments before it passes them to a +function: + +<pre><code> +: (hello (+ 1 2 3)) +Hello 6 +</code></pre> + +<pre><code> +: (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' +</code></pre> + +<p>In some cases you don't want that. For some functions (<code><a +href="refS.html#setq">setq</a></code> for example) it is better if the function +gets all arguments unevaluated, and can decide for itself what to do with them. + +<p>For such cases you do not define the function with a <i>list</i> of +parameters, but give it a <i>single atomic</i> parameter instead. PicoLisp will +then bind all (unevaluated) arguments as a list to that parameter. + +<pre><code> +: (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)' +</code></pre> + +<p>As a logical consequence, you can combine these principles. To define a +function with 2 evaluated and an arbitrary number of unevaluated arguments: + +<pre><code> +: (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 +</code></pre> + +<p>More common, in fact, is the case where you want to pass an arbitrary number +of <i>evaluated</i> arguments to a function. For that, PicoLisp recognizes the +symbol <code>@</code> as a single atomic parameter and remembers all evaluated +arguments in an internal frame. This frame can then be accessed sequentially +with the <code><a href="refA.html#args">args</a></code>, <code><a +href="refN.html#next">next</a></code>, <code><a +href="refA.html#arg">arg</a></code> and <code><a +href="refR.html#rest">rest</a></code> functions. + +<pre><code> +: (de foo @ + (list (next) (next)) ) # Get the first two arguments + +: (foo A B) +-> (1 2) +</code></pre> + +<p>Again, this can be combined: + +<pre><code> +: (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 +</code></pre> + +<p>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: + +<pre><code> +: (de foo @ + (while (args) + (println (next) (* (arg) (arg))) ) ) + +: (foo (+ 2 3) (- 7 1) 1234 (* 9 9)) +5 25 +6 36 +1234 1522756 +81 6561 +-> 6561 +</code></pre> + +<p>Finally, it is possible to pass all these evaluated argument to another +function, using <code><a href="refP.html#pass">pass</a></code>: + +<pre><code> +: (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 +</code></pre> + + +<p><hr> +<h2><a name="dbg">Debugging</a></h2> + +<p>There are two major ways to debug functions (and methods) at runtime: +<i>Tracing</i> and <i>single-stepping</i>. + +<p><i>Tracing</i> 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. + +<p>For demonstration, let's define the unavoidable factorial function (or just +<code><a href="refL.html#load">load</a></code> the file "<code><a +href="fun.l">doc/fun.l</a></code>"): + +<pre><code> +(de fact (N) + (if (=0 N) + 1 + (* N (fact (- N 1))) ) ) +</code></pre> + +<p>With <code><a href="refT.html#trace">trace</a></code> we can put it in trace +mode: + +<pre><code> +: (trace 'fact) +-> fact +</code></pre> + +<p>Calling <code>fact</code> now will display its execution trace. + +<pre><code> +: (fact 3) + fact : 3 + fact : 2 + fact : 1 + fact : 0 + fact = 1 + fact = 1 + fact = 2 + fact = 6 +-> 6 +</code></pre> + +<p>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 (<code>:</code>), and upon function exit with an equals sign +(<code>=</code>) from the return value. + +<p>Trace works by modifying the function body, so generally only for functions +defined as lists (lambda expressions, see <a href="ref.html#ev">Evaluation</a>). +Tracing a C-function is possible, however, when it is a function that evaluates +all its arguments. + +<p>So let's trace the functions <code><a href="ref_.html#=0">=0</a></code> and +<code><a href="ref_.html#*">*</a></code>: + +<pre><code> +: (trace '=0) +-> =0 +: (trace '*) +-> * +</code></pre> + +<p>If we call <code>fact</code> again, we see the additional output: + +<pre><code> +: (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 +</code></pre> + +<p>To reset a function to its untraced state, call <code><a +href="refU.html#untrace">untrace</a></code> + +<pre><code> +: (untrace 'fact) +-> fact +: (untrace '=0) +-> =0 +: (untrace '*) +-> * +</code></pre> + +<p>or simply + +<pre><code> +: (mapc untrace '(fact =0 *)) +-> * +</code></pre> + +<p><i>Single-stepping</i> means to execute a function step by step, giving the +programmer an opportunity to look more closely at what is happening. The +function <code><a href="refD.html#debug">debug</a></code> 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 <code><a +href="ref_.html#^">^</a></code>) and enters a read-eval-loop. The programmer can +then + +<ul> + +<li>inspect the current environment by typing variable names or calling +functions + +<li>execute <code>(<a href="refD.html#d">d</a>)</code> to recursively debug the +next expression + +<li>execute <code>(<a href="refE.html#e">e</a>)</code> to evaluate the next +expression, to see what will happen without actually advancing on + +<li>type ENTER (: enter an empty line) to leave the read-eval loop and continue +with the next expression + +</ul> + +<p>Thus, in the simplest case, single-stepping consists of just hitting ENTER +repeatedly to step through the function. + +<p>To try it out, let's look at the <code><a +href="refS.html#stamp">stamp</a></code> system function. + +<pre><code> +: (pp 'stamp) +(de stamp (Dat Tim) + (default Dat (date) Tim (time T)) + (pack (dat$ Dat "-") " " (tim$ Tim T)) ) +-> stamp +</code></pre> + +<pre><code> +: (debug 'stamp) # Debug it +-> T +: (stamp) # Call it again +(default Dat (date) Tim (time T)) # stopped at first expression +! # ENTER +(pack (dat$ Dat "-") " " (tim$ ... # second 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 2 expressions +</code></pre> + +<p>Now we execute it again, but this time we want to look at what's happening +inside the second expression. + +<pre><code> +: (stamp) # Call it again +(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 +</code></pre> + +<p>The breakpoints still remain in the function body. We can see them when we +pretty-print it: + +<pre><code> +: (pp 'stamp) +(de stamp (Dat Tim) + (! default Dat (date) Tim (time T)) + (! pack + (! dat$ Dat "-") + " " + (! tim$ Tim T) ) ) +-> stamp +</code></pre> + +<p>To reset the function to its normal state, call + +<pre><code> +: (unbug 'stamp) +</code></pre> + +<p>Often, you will not want to single-step a whole function. Just use +<code>edit</code> (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. + + +<p><hr> +<h2><a name="funio">Functional I/O</a></h2> + +<p>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. + +<p>Standard input and standard output are the default channels. Try reading a +single expression: + +<pre><code> +: (read) +(a b c) # Console input +-> (a b c) +</code></pre> + +<p>To read from a file, we redirect the input with <code><a +href="refI.html#in">in</a></code>. Note that comments and white space are +automatically skipped by <code>read</code>: + +<pre><code> +: (in "doc/fun.l" (read)) +-> (de fact (N) (if (=0 N) 1 (* N (fact (- N 1))))) +</code></pre> + +<p>The <code><a href="refS.html#skip">skip</a></code> function can also be used +directly. To get the first non-white character in the file with <code><a +href="refC.html#char">char</a></code>: + +<pre><code> +: (in "doc/fun.l" (skip "#") (char)) +-> "(" +</code></pre> + +<p><code><a href="refF.html#from">from</a></code> 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 <code>fact</code> in the file, + +<pre><code> +: (in "doc/fun.l" (make (while (from "fact ") (link (read))))) +-> ((N) (- N 1)) +</code></pre> + +<p>or the word following "(de " with <code><a +href="refT.html#till">till</a></code>: + +<pre><code> +: (in "doc/fun.l" (from "(de ") (till " " T))) +-> "fact" +</code></pre> + + +<p>With <code><a href="refL.html#line">line</a></code>, a line of characters is +read, either into a single transient symbol, + +<pre><code> +: (in "doc/tut.html" (line T)) +-> "&lt;!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.0 Transitional//EN" "http://..." +</code></pre> + +<p>or into a list of symbols (characters): + +<pre><code> +: (in "doc/tut.html" (line)) +-> ("&lt;" "!" "D" "O" "C" "T" "Y" "P" "E" " " "H" "T" "M" "L" ... +</code></pre> + +<p><code>line</code> is typically used to read tabular data from a file. +Additional arguments can split the line into fixed-width fields, as described in +the <code><a href="refL.html#line">reference manual</a></code>. If, however, the +data are of variable width, delimited by some special character, the <code><a +href="refS.html#split">split</a></code> function can be used to extract the +fields. A typical way to import the contents of such a file is: + +<pre><code> +(load "lib/import.l") + +(in '("bin/utf2" "importFile.txt") # Pipe: Convert to UTF-8 + (until (eof) # Process whole file + (let L (split (line) "^I") # TAB-delimited data + ... use 'getStr', 'getNum' etc ... # process them +</code></pre> + +<p>Some more examples: + +<pre><code> +(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 "&lt;body>") ) + +(out "file.mac" # Convert to Macintosh + (in "file.txt" # from Unix or DOS format: + (while (char) + (prin + (case @ + ("^M" NIL) # ignore CR + ("^J" "^M") # convert CR to LF + (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" +</code></pre> + + +<p><hr> +<h2><a name="script">Scripting</a></h2> + +<p>There are two possibilities to get the PicoLisp interpreter into doing useful +work: Via command line arguments, or as a stand-alone script. + +<p>The command line can specify either files for execution, or arbitrary Lisp +expressions for direct evaluation (see <code><a +href="ref.html#invoc">Invocation</a></code>): If an argument starts with a +hyphen, it is evaluated, otherwise <code><a +href="refL.html#load">load</a></code>ed as a file. A typical invocation might +look like: + +<pre><code> +$ ./dbg app/file1.l -main app/file2.l +</code></pre> + +<p>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: + +<pre><code> +$ ./dbg app/file1.l -"trace 'foo" -main -"debug 'bar" app/file2.l +</code></pre> + +<p>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: + +<pre><code> +$ ./dbg app/file1.l -main app/file2.l -go -'login "name" "password"' +</code></pre> + +<p>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. + +<p>For small utility programs, however, this is overkill. 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 "<code>#!</code>", 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. + +<p>Let's assume you installed PicoLisp in the directory "/home/foo/picolisp/", +and put links to the executable and the installation directory as: + +<pre><code> +$ ln -s /home/foo/picolisp /usr/lib/picolisp +$ ln -s /usr/lib/picolisp/bin/picolisp /usr/bin/picolisp +</code></pre> + +Then a simple hello-world script might look like: + +<pre><code> +#!/usr/bin/picolisp /usr/lib/picolisp/lib.l +(prinl "Hello world!") +(bye) +</code></pre> + +<p>If you write this into a text file, and use <code>chmod</code> to set it to +"executable", it can be executed like any other command. Note that - because +<code>#</code> 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). + +<p>The fact that a hyphen causes evaluation of command line arguments can be +used to simulate something like command line options. The following script +defines two functions <code>a</code> and <code>f</code>, and then calls +<code>(<a href="refL.html#load">load</a> T)</code> to process the rest of the +command line (which otherwise would be ignored because of the <code>(<a +href="refB.html#bye">bye</a>)</code> statement): + +<pre><code> +#!/usr/bin/picolisp /usr/lib/picolisp/lib.l + +(de a () + (println '-a '-> (opt)) ) + +(de f () + (println '-f '-> (opt)) ) + +(load T) +(bye) +</code></pre> + +(<code><a href="refO.html#opt">opt</a></code> retrieves the next command line +option) + +<p>Calling this script (let's say we named it "testOpts") gives: + +<pre><code> +$ ./testOpts -f abc +-f -> "abc" +$ ./testOpts -a xxx -f yyy +-a -> "xxx" +-f -> "yyy" +</code></pre> + +<p>We have to be aware of the fact, however, that the aggregation of arguments +like + +<pre><code> +$ ./testOpts -axxx -fyyy +</code></pre> + +<p>or + +<pre><code> +$ ./testOpts -af yyy +</code></pre> + +<p>cannot be achieved with this simple and general mechanism of command line +processing. + +<p>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 "dbg.l" or "app/file1.l" will +be properly found. + +<p>To allow utilities to run in arbitrary places on the host file system, the +concept of <i>home directory substitution</i> was introduced. The interpreter +remembers internally at start-up the pathname of its first argument (usually +"lib.l"), and substitutes any leading "<code>@</code>" character in subsequent +file names with that pathname. Thus, to run the above example in some other +place, simply write: + +<pre><code> +$ /home/foo/picolisp/dbg @app/file1.l -main @app/file2.l +</code></pre> + +<p>that is, supply a full path name to the initial command (here 'p'), or put it +into your <code>PATH</code> variable, and prefix each file which has to be +loaded from the PicoLisp home directory with a <code>@</code> character. +"Normal" files (not prefixed by <code>@</code>) will be opened or created +relative to the current working directory as usual. + +<p>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 + +<pre><code> +(load "@lib/misc.l") +</code></pre> + +<p>(note the home directory substitution) will be included near the beginning of +the script. + +<p>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: + +<pre><code> +#!/usr/bin/picolisp /usr/lib/picolisp/lib.l + +(load "@lib/misc.l" "@lib/http.l") + +(use (@Date @Name @Size) + (when + (match + '(@Date " " "-" " " @Name " " "(" @Size ")") + (client "software-lab.de" 80 "down.html" + (from "Release Archive") + (from ".tgz">") + (till "") ) ) + (prinl @Name) + (prinl @Date " -- " @Size) ) ) + +(bye) +</code></pre> + + +<p><hr> +<h2><a name="oop">Objects and Classes</a></h2> + +<p>The PicoLisp object model is very simple, yet flexible and powerful. Objects +as well as classes are both implemented as symbols. In fact, there is no formal +difference between objects and classes; classes are more a conceptual design +consideration in the head of the programmer than a physical reality. + +<p>Having said this, we declare that normally: + +<ol> +<li>A Class + <ul> + <li>Has a name (interned symbol) + <li>Has method definitions and superclass(es) in the value cell + <li>May have class variables (attributes) in the property list + </ul> +<li>An Object + <ul> + <li>Has no name (anonymous symbol) or is an external symbol + <li>Has class(es) (and optionally method definitions) in the value cell + <li>Has instance variables (attributes) in the property list + </ul> +</ol> + +<p>So the main difference between classes and objects is that the former ones +usually are internal symbols. By convention, their names start with a +'<code>+</code>'. Sometimes it makes sense, however, to create named objects (as +global singletons, for example), or even anonymous classes. + +<p>Both classes and objects have a list in their value cell, consisting of +method definitions (often empty for objects) and (super)class(es). And both +classes and objects have local data in their property lists (often empty for +classes). This implies, that any given object (as an instance of a class) may +have private (object-local) methods defined. + +<p>It is rather difficult to contrive a simple OOP example. We constructed a +hierarchy of geometric shapes, with a base class <code>+Shape</code> and two +subclasses <code>+Rectangle</code> and <code>+Circle</code>. + +<p>The source code is included as "<code><a +href="shape.l">doc/shape.l</a></code>" in the PicoLisp distribution, so you +don't have to type it in. Just <code><a href="refL.html#load">load</a></code> +the file, or start it from the shell as: + +<pre><code> +$ ./dbg doc/shape.l +</code></pre> + +<p>Let's look at it piece by piece. Here's the base class: + +<pre><code> +(class +Shape) +# x y + +(dm T (X Y) + (=: x X) + (=: y Y) ) + +(dm move> (DX DY) + (inc (:: x) DX) + (inc (:: y) DY) ) +</code></pre> + +<p>The first line '<code>(class +Shape)</code>' defines the symbol +<code>+Shape</code> as a class without superclasses. The following method +definitions will go to that class. + +<p>The comment '<code># x y</code>' in the second line is just a convention, to +indicate what instance variables (properties) that class uses. As PicoLisp is a +dynamic language, a class can be extended at runtime with any number of +properties, and there is nothing like a fixed object size or structure. This +comment is a hint of what the programmer thinks to be essential and typical for +that class. In the case of <code>+Shape</code>, <code>x</code> and +<code>y</code> are the coordinates of the shape's origin. + +<p>Then we have two method definitions, using the keyword <code><a +href="refD.html#dm">dm</a></code> for "define method". The first method is +special, in that its name is <code>T</code>. Each time a new object is created, +and a method with that name is found in its class hierarchy, that method will be +executed. Though this looks like a "constructor" in other programming languages, +it should probably better be called "initializer". The <code>T</code> method of +<code>+Shape</code> takes two arguments <code>X</code> and <code>Y</code>, and +stores them in the object's property list. + +<p>The second method <code>move&gt;</code> changes the object's origin by adding +the offset values <code>DX</code> and <code>DY</code> to the object's origin. + +<p>Now to the first derived class: + +<pre><code> +(class +Rectangle +Shape) +# dx dy + +(dm T (X Y DX DY) + (super X Y) + (=: dx DX) + (=: dy DY) ) + +(dm area> () + (* (: dx) (: dy)) ) + +(dm perimeter> () + (* 2 (+ (: dx) (: dy))) ) + +(dm draw> () + (drawRect (: x) (: y) (: dx) (: dy)) ) +</code></pre> + +<p><code>+Rectangle</code> is defined as a subclass of <code>+Shape</code>. +The comment '<code># dx dy</code>' indicates that <code>+Rectangle</code> has a +width and a height in addition to the origin coordinates inherited from +<code>+Shape</code>. + +<p>The <code>T</code> method passes the origin coordinates <code>X</code> and +<code>Y</code> to the <code>T</code> method of the superclass +(<code>+Shape</code>), then stores the width and height parameters into +<code>dx</code> and <code>dy</code>. + +<p>Next we define the methods <code>area&gt;</code> and +<code>perimeter&gt;</code> which do some obvious calculations, and a method +<code>draw&gt;</code> which is supposed to draw the shape on the screen by +calling some hypothetical function <code>drawRect</code>. + +<p>Finally, we define a <code>+Circle</code> class in an analog way, postulating +the hypothetical function <code>drawCircle</code>: + +<pre><code> +(class +Circle +Shape) +# r + +(dm T (X Y R) + (super X Y) + (=: r R) ) + +(dm area> () + (*/ (: r) (: r) 31415927 10000000) ) + +(dm perimeter> () + (*/ 2 (: r) 31415927 10000000) ) + +(dm draw> () + (drawCircle (: x) (: y) (: r)) ) +</code></pre> + +<p>Now we can experiment with geometrical shapes. We create a rectangle at point +(0,0) with a width of 30 and a height of 20, and keep it in the variable +<code>R</code>: + +<pre><code> +: (setq R (new '(+Rectangle) 0 0 30 20)) # New rectangle +-> $134432824 # returned anonymous symbol +: (show R) +$134432824 (+Rectangle) # Show the rectangle + dy 20 + dx 30 + y 0 + x 0 +</code></pre> + +<p>We see that the symbol <code>$134432824</code> has a list of classes +'<code>(+Rectangle)</code>' in its value cell, and the coordinates, width and +height in is property list. + +<p>Sending messages to that object + +<pre><code> +: (area> R) # Calculate area +-> 600 +: (perimeter> R) # and perimeter +-> 100 +</code></pre> + +<p>will return the values for area and perimeter, respectively. + +<p>Then we move the object's origin: + +<pre><code> +: (move> R 10 5) # Move 10 right and 5 down +-> 5 +: (show R) +$134432824 (+Rectangle) + y 5 # Origin changed (0,0) -> (10,5) + x 10 + dy 20 + dx 30 +</code></pre> + +<p>Though a method <code>move&gt;</code> wasn't defined for the +<code>+Rectangle</code> class, it is inherited from the <code>+Shape</code> +superclass. + +<p>Similarly, we create and use a circle object: + +<pre><code> +: (setq C (new '(+Circle) 10 10 30)) # New circle +-> $134432607 # returned anonymous symbol +: (show C) +$134432607 (+Circle) # Show the circle + r 30 + y 10 + x 10 +-> $134432607 +: (area> C) # Calculate area +-> 2827 +: (perimeter> C) # and perimeter +-> 188 +: (move> C 10 5) # Move 10 right and 5 down +-> 15 +: (show C) +$134432607 (+Circle) # Origin changed (10,10) -> (20,15) + y 15 + x 20 + r 30 +</code></pre> + +<p>It is also easy to send messages to objects in a list: + +<pre><code> +: (mapcar 'area> (list R C)) # Get list of areas +-> (600 2827) +: (mapc + '((Shape) (move> Shape 10 10)) # Move all 10 right and down + (list R C) ) +-> 25 +: (show R) +$134431493 (+Rectangle) + y 15 + x 20 + dy 20 + dx 30 +-> $134431493 +: (show C) +$134431523 (+Circle) + y 25 + x 30 + r 30 +</code></pre> + +<p>Assume that we want to extend our shape system. From time to time, we need +shapes that behave exactly like the ones above, but are tied to a fixed +position. That is, they do not change their position even if they receive a +<code>move&gt;</code> message. + +<p>One solution would be to modify the <code>move&gt;</code> method in the +<code>+Shape</code> class to a no-operation. But this would require to duplicate +the whole shape hierarchy (e.g. by defining <code>+FixedShape</code>, +<code>+FixedRectangle</code> and <code>+FixedCircle</code> classes). + +<p>The PicoLisp Way is the use of <u>Prefix Classes</u> through multiple +inheritance. It uses the fact that searching for method definitions is a +depth-first, left-to-right search of the class tree. We define a prefix class: + +<pre><code> +: (class +Fixed) + +(dm move> (DX DY)) # A do-nothing method +</code></pre> + +<p>We can now create a fixed rectangle, and try to move it: + +<pre><code> +: (setq R (new '(+Fixed +Rectangle) 0 0 30 20)) # '+Fixed' prefix class +-> $134432881 +: (move> R 10 5) # Send 'move>' message +-> NIL +: (show R) +$134432881 (+Fixed +Rectangle) + dy 20 + dx 30 + y 0 # Did not move! + x 0 +</code></pre> + +<p>We see, prefix classes can surgically change the inheritance tree for +selected objects or classes. + +<p>Alternatively, if fixed rectangles are needed often, it might make sense to +define a new class <code>+FixRect</code>: + +<pre><code> +: (class +FixRect +Fixed +Rectangle) +-> +FixRect +</code></pre> + +<p>and then use it directly: + +<pre><code> +: (setq R (new '(+FixRect) 0 0 30 20)) +-> $13455710 +</code></pre> + + +<p><hr> +<h2><a name="ext">Persistence (External Symbols)</a></h2> + +<p>PicoLisp has persistent objects built-in as a first class data type. With +"first class" we mean not just the ability of being passed around, or returned +from functions (that's a matter of course), but that they are a primary data +type with their own interpreter tag bits. They are, in fact, a special type of +symbolic atoms (called "<a href="ref.html#external">External Symbols</a>"), that +happen to be read from pool file(s) when accessed, and written back +automatically when modified. + +<p>In all other aspects they are normal symbols. They have a value cell, a +property list and a name. + +<p>The name cannot be directly controlled by the programmer, as it is assigned +when the symbol is created. It is an encoded index of the symbol's location in +its database file. In its visual representation (output by the <code><a +href="refP.html#print">print</a></code> functions and input by the <code><a +href="refR.html#read">read</a></code> functions) it is surrounded by braces. + +<p>To make use of external symbols, you need to open a database first: + +<pre><code> +: (pool "test.db") +</code></pre> + +<p>If a file with that name did not exist, it got created now. Also created at +the same moment was <code>{1}</code>, the very first symbol in the file. This +symbol is of great importance, and is handled especially by PicoLisp. Therefore +a global constant <code><a href="refD.html#*DB">*DB</a></code> exists, which +points to that symbol <code>{1}</code>, which should be used exclusively to +access the symbol <code>{1}</code>, and which should never be modified by the +programmer. + +<pre><code> +: *DB # The value of '*DB' +-> {1} # is '{1}' +: (show *DB) +{1} NIL # Value of '{1}' is NIL, property list empty +</code></pre> + +<p>Now let's put something into the value cell and property list of +<code>{1}</code>. + +<pre><code> +: (set *DB "Hello world") # Set value of '{1}' to a transient symbol (string) +-> "Hello world" +: (put *DB 'a 1) # Property 'a' to 1 +-> 1 +: (put *DB 'b 2) # Property 'b' to 2 +-> 2 +: (show *DB) # Now show the symbol '{1}' +{1} "Hello world" + b 2 + a 1 +</code></pre> + +<p>Note that instead of '<code>(set *DB "Hello world")</code>', we might +also have written '<code>(setq {1} "Hello world")</code>', and instead of +'<code>(put *DB 'a 1)</code>' we might have written '<code>(put '{1} 'a +1)</code>'. This would have the same effect, but as a rule external symbols +should never be be accessed literally in application programs, because the +garbage collector might not be able to free these symbols and all symbols +connected to them (and that might well be the whole database). It is all right, +however, to access external symbols literally during interactive debugging. + +<p>Now we can create our first own external symbol. This can be done with +<code><a href="refN.html#new">new</a></code> when a <code>T</code> argument is +supplied: + +<pre><code> +: (new T) +-> {2} # Got a new symbol +</code></pre> + +<p>We store it in the database root <code>{1}</code>: + +<pre><code> +: (put *DB 'newSym '{2}) # Literal '{2}' (ok during debugging) +-> {2} +: (show *DB) +{1} "Hello world" + newSym {2} # '{2}' is now stored in '{1}' + b 2 + a 1 +</code></pre> + +<p>Put some property value into '{2}' + +<pre><code> +: (put *DB 'newSym 'x 777) # Put 777 as 'x'-property of '{2}' +-> 777 +: (show *DB 'newSym) # Show '{2}' (indirectly) +{2} NIL + x 777 +-> {2} +: (show '{2}) # Show '{2}' (directly) +{2} NIL + x 777 +</code></pre> + +<p>All modifications to - and creations of - external symbols done so far are +not written to the database yet. We could call <code><a +href="refR.html#rollback">rollback</a></code> (or simply exit PicoLisp) to undo +all the changes. But as we want to keep them: + +<pre><code> +: (commit) # Commit all changes +-> T +: (bye) # Exit picolisp +$ # back to the shell +</code></pre> + +<p>So, the next time when .. + +<pre><code> +$ ./dbg # .. we start PicoLisp +: (pool "test.db") # and open the database file, +-> T +: (show *DB) # our two symbols are there again +{1} "Hello world" + newSym {2} + b 2 + a 1 +-> {1} +: (show *DB 'newSym) +{2} NIL + x 777 +-> {2} +</code></pre> + + +<p><hr> +<h2><a name="db">Database Programming</a></h2> + +<p>To a database, there is more than just persistence. PicoLisp includes an +entity/relation class framework (see also <a href="ref.html#dbase">Database</a>) +which allows a close mapping of the application data structure to the database. + +<p>We provided a simple yet complete database and GUI demo application in +<code><a href="family.l">doc/family.l</a></code>. We recommend to start it up +for test purposes in the following way: + +<pre><code> +$ ./dbg doc/family.l -main +: +</code></pre> + +<p>This loads the source file, initializes the database by calling the +<code>main</code> function, and prompts for user input. + +<p>The data model is small and simple. We define a class <code>+Person</code> +and two subclasses <code>+Man</code> and <code>+Woman</code>. + +<pre><code> +(class +Person +Entity) +</code></pre> + +<p><code>+Person</code> is a subclass of the <code><a +href="refE.html#+Entity">+Entity</a></code> system class. Usually all objects in +a database are of a direct or indirect subclass of <code><a +href="refE.html#+Entity">+Entity</a></code>. We can then define the relations to +other data with the <code><a href="refR.html#rel">rel</a></code> function. + +<pre><code> +(rel nm (+Need +Sn +Idx +String)) # Name +</code></pre> + +<p>This defines the name property (<code>nm</code>) of a person. The first +argument to <code>rel</code> is always a list of relation classes (subclasses of +<code><a href="refR.html#+relation">+relation</a></code>), optionally followed +by further arguments, causing relation daemon objects be created and stored in +the class definition. These daemon objects control the entity's behavior later +at runtime. + +<p>Relation daemons are a kind of <i>metadata</i>, controlling the interactions +between entities, and maintaining database integrity. Like other classes, +relation classes can be extended and refined, and in combination with proper +prefix classes a fine-grained description of the application's structure can be +produced. + +<p>Besides primitive relation classes, like <code>+Number</code>, +<code>+String</code> or <code>+Date</code>, there are + +<ul> + +<li>relations between entities, like <code>+Link</code> (unidirectional link), +<code>+Joint</code> (bidirectional link) or <code>+Hook</code> (object-local +index trees) + +<li>relations that bundle other relations into a single unit (<code>+Bag</code>) + +<li>a <code>+List</code> prefix class + +<li>a <code>+Blob</code> class for "binary large objects" + +<li>prefix classes that maintain index trees, like <code>+Key</code> (unique +index), <code>+Ref</code> (non-unique index) or <code>+Idx</code> (full text +index) + +<li>prefix classes which in turn modify index class behavior, like +<code>+Sn</code> (modified soundex algorithm [<a href="#knuth73">knuth73</a>] +for tolerant searches) + +<li>a <code>+Need</code> prefix class, for existence checks + +<li>a <code>+Dep</code> prefix class controlling dependencies between other +relations + +</ul> + +<p>In the case of the person's name (<code>nm</code>) above, the relation object +is of type <code>(+Need +Sn +Idx +String)</code>. Thus, the name of each person +in this demo database is a mandatory attribute (<code>+Need</code>), searchable +with the soundex algorithm (<code>+Sn</code>) and a full index +(<code>+Idx</code>) of type <code>+String</code>. + +<pre><code> +(rel pa (+Joint) kids (+Man)) # Father +(rel ma (+Joint) kids (+Woman)) # Mother +(rel mate (+Joint) mate (+Person)) # Partner +</code></pre> + +<p>The attributes for <i>father</i> (<code>pa</code>), <i>Mother</i> +(<code>ma</code>) and <i>partner</i> (<code>mate</code>) are all defined as +<code>+Joint</code>s. A <code>+Joint</code> is probably the most powerful +relation mechanism in PicoLisp; it establishes a bidirectional link between two +objects. + +<p>The above declarations say that the <i>father</i> (<code>pa</code>) attribute +points to an object of type <code>+Man</code>, and is joined with that object's +<code>kids</code> attribute (which is a list of joints back to all his +children). + +<p>The consistency of <code>+Joint</code>s is maintained automatically by the +relation daemons. These become active whenever a value is stored to a person's +<code>pa</code>, <code>ma</code>, <code>mate</code> or <code>kids</code> +property. + +<p>For example, interesting things happen when a person's <code>mate</code> is +changed to a new value. Then the <code>mate</code> property of the old mate's +object is cleared (she has no mate after that). Now when the person pointed to +by the new value already has a mate, then that mate's <code>mate</code> property +gets cleared, and the happy new two mates now get their joints both set +correctly. + +<p>The programmer doesn't have to care about all that. He just declares these +relations as <code>+Joint</code>s. + +<p>The last four attributes of person objects are just static data: + +<pre><code> +(rel job (+Ref +String)) # Occupation +(rel dat (+Ref +Date)) # Date of birth +(rel fin (+Ref +Date)) # Date of death +(rel txt (+String)) # Info +</code></pre> + +<p>They are all searchable via a non-unique index (<code>+Ref</code>). Date +values in PicoLisp are just numbers, representing the numbers of days since +first of March in the year zero. + +<p>A method <code>url&gt;</code> is defined: + +<pre><code> +(dm url> () + (list "@person" '*ID This) ) +</code></pre> + +<p>It is needed later in the GUI, to cause a click on a link to switch to that +object. + +<p>The classes <code>+Man</code> and <code>+Woman</code> are subclasses of +<code>+Person</code>: + +<pre><code> +(class +Man +Person) +(rel kids (+List +Joint) pa (+Person)) # Children + +(class +Woman +Person) +(rel kids (+List +Joint) ma (+Person)) # Children +</code></pre> + +<p>They inherit everything from <code>+Person</code>, except for the +<code>kids</code> attribute. This attribute joins with the <code>pa</code> or +<code>ma</code> attribute of the child, depending on the parent's gender. + +<p>That's the whole data model for our demo database application. + +<p>It is followed by a call to <code><a href="refD.html#dbs">dbs</a></code> +("database sizes"). This call is optional. If it is not present, the whole +database will reside in a single file, with a block size of 256 bytes. If it is +given, it should specify a list of items, each having a number in its CAR, and a +list in its CDR. The CARs taken together will be passed later to <a +href="refP.html#pool">pool</a>, causing an individual database file with that +size to be created. The CDRs tell what entity classes (if an item is a symbol) +or index trees (if an item is a list with a class in its CAR and a list of +relations in its CDR) should be placed into that file. + + +<p>A handful of access functions is provided, that know about database +relationships and thus allows higher-level access modes to the external symbols +in a database. + +<p>For one thing, the B-Trees created and maintained by the index daemons can be +used directly. Though this is rarely done in a typical application, they form +the base mechanisms of other access modes and should be understood first. + +<p>The function <code><a href="refT.html#tree">tree</a></code> returns the tree +structure for a given relation. To iterate over the whole tree, the functions +<code><a href="refI.html#iter">iter</a></code> and <code><a +href="refS.html#scan">scan</a></code> can be used: + +<pre><code> +(iter (tree 'dat '+Person) '((P) (println (datStr (get P 'dat)) (get P 'nm)))) +"1770-08-03" "Friedrich Wilhelm III" +"1776-03-10" "Luise Augusta of Mecklenburg-Strelitz" +"1797-03-22" "Wilhelm I" +... +</code></pre> + +<p>They take a function as the first argument. It will be applied to all objects +found in the tree (to show only a part of the tree, an optional begin- and +end-value can be supplied), producing a simple kind of report. + +<p>More useful is <code><a href="refC.html#collect">collect</a></code>; it +returns a list of all objects that fall into a range of index values: + +<pre><code> +: (collect 'dat '+Person (date 1982 1 1) (date 1988 12 31)) +-> ({2-M} {2-L} {2-E}) +</code></pre> + +<p>This returns all persons born between 1982 and 1988. Let's look at them with +<code><a href="refS.html#show">show</a></code>: + +<pre><code> +: (more (collect 'dat '+Person (date 1982 1 1) (date 1988 12 31)) show) +{2-M} (+Man) + nm "William" + dat 724023 + ma {2-K} + pa {2-J} + job "Heir to the throne" + +{2-L} (+Man) + nm "Henry" + dat 724840 + ma {2-K} + pa {2-J} + job "Prince" + +{2-E} (+Woman) + nm "Beatrice" + dat 726263 + ma {2-D} + job "Princess" + pa {2-B} +</code></pre> + +<p>If you are only interested in a certain attribute, e.g. the name, you can +return it directly: + +<pre><code> +: (collect 'dat '+Person (date 1982 1 1) (date 1988 12 31) 'nm) +-> ("William" "Henry" "Beatrice") +</code></pre> + +<p>To find a single object in the database, the function <code><a +href="refD.html#db">db</a></code> is used: + +<pre><code> +: (db 'nm '+Person "Edward") +-> {2-;} +</code></pre> + +<p>If the key is not unique, additional arguments may be supplied: + +<pre><code> +: (db 'nm '+Person "Edward" 'job "Prince" 'dat (date 1964 3 10)) +-> {2-;} +</code></pre> + +<p>The programmer must know which combination of keys will suffice to specify +the object uniquely. The tree search is performed using the first value +("Edward"), while all other attributes are used for filtering. Later, in +the <a href="#pilog">Pilog</a> section, we will show how more general (and +possibly more efficient) searches can be performed. + + +<p><hr> +<h2><a name="gui">User Interface (GUI) Programming</a></h2> + +<p>The only types of GUI supported by the PicoLisp application server framework +is either dynamically generated (but static by nature) HTML, or an interactive +XHTML/CSS framework with the optional use of JavaScript. + +<p>Before we explain the GUI of our demo database application, we present a +minimal example for a plain HTML-GUI in <code><a +href="hello.l">doc/hello.l</a></code>. Start the application server as: + +<pre><code> +$ ./p lib/http.l -'server 8080 "doc/hello.l"' -wait +</code></pre> + +<p>Now point your browser to the address '<code><a +href="http://localhost:8080">http://localhost:8080</a></code>'. You should see a +very simple HTML page. You can come back here with the browser's BACK button. + +<p>You can call the page repeatedly, or concurrently with many clients if you +like. To terminate the server, you have to send it a TERM signal (e.g. +'<code>killall picolisp</code>'), or type the <code>Ctrl-C</code> key in the +console window. + +<p>In our demo database application, a single function <code>person</code> is +responsible for the whole GUI. Again, please look at <code><a +href="family.l">doc/family.l</a></code>. + +<p>To start the database <i>and</i> the application server, call: + +<pre><code> +$ ./dbg doc/family.l -main -go +</code></pre> + +<p>As before, the database is opened with <code>main</code>. The function +<code>go</code> is also defined in <code>doc/family.l</code>: + +<pre><code> +(de go () + (server 8080 "@person") ) +</code></pre> + +<p>It starts the HTTP server listening on TCP port 8080 (we did a similar thing +in our minimal GUI example above directly on the command line). Each connect to +that port will cause the function <code>person</code> to be invoked. + +<p>Again, point your browser to the address '<code><a +href="http://localhost:8080" target="GUI">http://localhost:8080</a></code>'. + +<p>You should see a new browser window with an input form created by the +function <code>person</code>. We provided an initial database in +"doc/family/[1-4]". You can navigate through it by clicking on the pencil icons +besides the input fields. + +<p>The chart with the children data can be scrolled using the down +(<code>v</code>) and up (<code>^</code>) buttons. + +<p>A click on the button "Select" below opens a search dialog. You can scroll +through the chart as before. Again, a click on a pencil will jump to that +person. You can abort the dialog with a click on the "Cancel"-button. + +<p>The search fields in the upper part of the dialog allow a conjunctive search. +If you enter "Edward" in the "Name" field and click "Search", you'll see all +persons having the string "Edward" in their name. If you also enter "Duke" in +the "Occupation" field, the result list will reduce to only two entries. + +<p>To create a new person, press the "New Man" or "New Woman" button. A new +empty form will be displayed. Please type a name into the first field, and +perhaps also an occupation and birth date. Any change of contents should be +followed by a press on the "Done" button, though any other button (also Scroll +or Select-buttons) will also do. + +<p>To assign a <i>father</i> attribute, you can either type a name directly into +the field (if that person already exists in the database and you know the exact +spelling), or use the "Set"-button (<code>-&gt;</code>) to the left of that +field to open the search dialog. If you type in the name directly, your input +must exactly match upper and lower case. + +<p>Alternatively, you may create a new person and assign a child in the +"Children" chart. + +<p>On the console where you started PicoLisp, there should a prompt have +appeared just when the browser connected. You can debug the application +interactively while it is running. For example, the global variable +<code>*Top</code> always contains the top level GUI object: + +<pre><code> +: (show *Top) +</code></pre> + +<p>To take a look at the first field on the form: + +<pre><code> +: (show *Top 'gui 1) +</code></pre> + +<p>A production application would be started in a slightly different way: + +<pre><code> +$ ./p doc/family.l -main -go -wait +</code></pre> + +<p>In that case, no debug prompt will appear. In both cases, however, two +<code>picolisp</code> processes will be running now. One is the initial server +process which will continue to run until it is killed. The other is a child +process holding the state of the GUI in the browser. It will terminate some time +after the browser is closed, or when <code>(<a +href="refB.html#bye">bye</a>)</code> or a plain ENTER is entered at the PicoLisp +prompt. + +<p>Now back to the explanation of the GUI function <code>person</code>: + +<pre><code> +(de person () + (app) + (action + (html 0 (get (default *ID (seq (db: +Person))) 'nm) "lib.css" NIL + (form NIL + (&lt;h3&gt; (&lt;id&gt; (: nm))) +</code></pre> + +<p>For an in-depth explanation of that startup code, please refer to the guide +to <a href="app.html">PicoLisp Application Development</a>. + +<p>All components like fields and buttons are controlled by <code>form</code>. +The function <code>gui</code> creates a single GUI component and takes the type +(a list of classes) and a variable number of arguments depending on the needs of +these classes. + +<pre><code> + (gui '(+E/R +TextField) '(nm : home obj) 40 "Name") +</code></pre> + +<p>This creates a <code>+TextField</code> with the label "Name" and a length of +40 characters. The <code>+E/R</code> (: Entity/Relation) prefix class connects +that field to a database object, the <code>nm</code> attribute of a person in +this case, so that the person's name is displayed in that text field, and any +changes entered into that field are propagated to the database automatically. + +<pre><code> + (gui '(+ClassField) '(: home obj) '(("Male" +Man) ("Female" +Woman))) +</code></pre> + +<p>A <code>+ClassField</code> displays and changes the class of an object, in +this case the person's sex from <code>+Man</code> to <code>+Woman</code> and +vice versa. + +<p>As you see, there is no place where explicit accesses to the database have to +be programmed, no <code>select</code> or <code>update</code>. This is all +encapsulated in the GUI components, mainly in the <code>+E/R</code> prefix +class. The above function <code>person</code> is fully functional as we present +it and allows creation, modification and deletion of person objects in the +database. + +<p>The two buttons on the bottom right generate simple reports: + +<p>The first one shows all contemporaries of the person that is currently +displayed, i.e. all persons who did not die before, or were not born after that +person. This is a typical PicoLisp report, in that in addition to the report's +HTML page, a temporary file may be generated, suitable for download (and import +into a spread sheet), and from which a PDF can be produced for print-out. + +<p>In PicoLisp, there is not a real difference between a plain HTML-GUI and a +report. Again, the function <code>html</code> is used to generate the page. + +<p>The second report is much simpler. It produces a recursive structure of the +family. + +<p>In both reports, links to the person objects are created which allow easy +navigation through the database. + + +<p><hr> +<h2><a name="pilog">Pilog -- PicoLisp Prolog</a></h2> + +<p>This sections explains some cases of using Pilog in typical application +programming, in combination with persistent objects and databases. Please refer +to the <a href="ref.html#pilog">Pilog</a> section of the PicoLisp Reference for +the basic usage of Pilog. + +<p>Again, we use our demo application <code><a +href="family.l">doc/family.l</a></code> that was introduced in the <a +href="#db">Database Programming</a> section. + +<p>Normally, Pilog is used either interactively to query the database during +debugging, or in applications to generate export data and reports. In the +following examples we use the interactive query front-end functions <code><a +href="ref_.html#?">?</a></code> and <code><a +href="refS.html#select">select</a></code>. An application will use <code><a +href="refG.html#goal">goal</a></code> and <code><a +href="refP.html#prove">prove</a></code> directly, or use convenience functions +like <code><a href="refP.html#pilog">pilog</a></code> or <code><a +href="refS.html#solve">solve</a></code>. + +<p>All Pilog access to external symbols is done via the two predicates <code><a +href="refD.html#db/3">db/3</a></code> and <code><a +href="refS.html#select/3">select/3</a></code>. + +<ul> + +<li><code><a href="refD.html#db/3">db/3</a></code> corresponds to the Lisp-level +functions <code><a href="refD.html#db">db</a></code> and <code><a +href="refC.html#collect">collect</a></code>, as it derives its data from a +single relation. It can be used for simple database queries. + +<li><code><a href="refS.html#select/3">select/3</a></code> provides for +self-optimizing parallel access to an arbitrary number of relations. There is +also a Lisp front-end function <code><a +href="refS.html#select">select</a></code>, for convenient calls to the Pilog +<code>select</code> predicate. + +</ul> + +<p>A predicate <code><a href="refS.html#show/1">show/1</a></code> is pre-defined +for debugging purposes (a simple glue to the Lisp-level function +<code>show</code>, see <a href="#brw">Browsing</a>). Searching with <code><a +href="refD.html#db/3">db/3</a></code> for all persons having the string "Edward" +in their name: + +<pre><code> +: (? (db nm +Person "Edward" @P) (show @P)) +{2-;} (+Man) + nm "Edward" + ma {2-:} + pa {2-A} + dat 717346 + job "Prince" + @P={2-;} +{2-1B} (+Man) + nm "Albert Edward" + kids ({2-1C} {2-1D} {2-1E} {2-1F} {2-1G} {2-1H} {2-1I} {2-g} {2-a}) + job "Prince" + mate {2-f} + fin 680370 + dat 664554 + @P={2-1B} +... # more results +</code></pre> + +<p>To search for all persons with "Edward" in their name who are married to +somebody with occupation "Queen": + +<pre><code> +: (? (db nm +Person "Edward" @P) (val "Queen" @P mate job) (show @P)) +{2-1B} (+Man) + mate {2-f} + nm "Albert Edward" + kids ({2-1C} {2-1D} {2-1E} {2-1F} {2-1G} {2-1H} {2-1I} {2-g} {2-a}) + job "Prince" + fin 680370 + dat 664554 + @P={2-1B} +-> NIL # only one result +</code></pre> + +<p>If you are interested in the names of "Albert Edward"'s children: + +<pre><code> +: (? (db nm +Person "Albert Edward" @P) (lst @K @P kids) (val @Kid @K nm)) + @P={2-1B} @K={2-1C} @Kid="Beatrice Mary Victoria" + @P={2-1B} @K={2-1D} @Kid="Leopold George Duncan" + @P={2-1B} @K={2-1E} @Kid="Arthur William Patrick" + @P={2-1B} @K={2-1F} @Kid="Louise Caroline Alberta" + @P={2-1B} @K={2-1G} @Kid="Helena Augusta Victoria" + @P={2-1B} @K={2-1H} @Kid="Alfred Ernest Albert" + @P={2-1B} @K={2-1I} @Kid="Alice Maud Mary" + @P={2-1B} @K={2-g} @Kid="Victoria Adelaide Mary" + @P={2-1B} @K={2-a} @Kid="Edward VII" +-> NIL +</code></pre> + +<p><code><a href="refD.html#db/3">db/3</a></code> can do a direct index access +only for a single attribute (<code>nm</code> of <code>+Person</code> above). To +search for several criteria at the same time, <code><a +href="refS.html#select/3">select/3</a></code> has to be used: + +<pre><code> +: (? + (select (@P) + ((nm +Person "Edward") (nm +Person "Augusta" pa)) # Generator clauses + (tolr "Edward" @P nm) # Filter clauses + (tolr "Augusta" @P kids nm) ) + (show @P) ) +{2-1B} (+Man) + kids ({2-1C} {2-1D} {2-1E} {2-1F} {2-1G} {2-1H} {2-1I} {2-g} {2-a}) + mate {2-f} + nm "Albert Edward" + job "Prince" + fin 680370 + dat 664554 + @P={2-1B} +-> NIL +</code></pre> + +<p><code><a href="refS.html#select/3">select/3</a></code> takes a list of +generator clauses which are used to retrieve objects from the database, and a +number of normal Pilog filter clauses. In the example above the generators are + +<ul> + +<li><code>(nm +Person "Edward")</code> to generate persons with "Edward" in +their names, and + +<li><code>(nm +Person "Augusta" pa)</code> to find persons with "Augusta" +in their names and generate persons using the <code>pa</code> ("father") +attribute. + +</ul> + +<p>All persons generated are possible candidates for our selection. The +<code>nm</code> index tree of <code>+Person</code> is traversed twice in +parallel, optimizing the search in such a way that successful hits get higher +priority in the search, depending on the filter clauses. The process will stop +as soon as any one of the generators is exhausted. Note that this is different +from the standard Prolog search algorithm. + +<p>The filter clauses in this example both use the pre-defined predicate +<code><a href="refT.html#tolr/3">tolr/3</a></code> for <i>tolerant</i> string +matches (according either to the soundex algorithm (see the section <a +href="#db">Database Programming</a>) or to substring matches), and filter +objects that + +<ul> + +<li>match "Edward" in their name: <code>(tolr "Edward" @P nm)</code>, and + +<li>match "Augusta" in one of their kids' names: <code>(tolr "Augusta" @P +kids nm)</code> + +</ul> + +<p>A more typical and extensive example for the usage of <code>select</code> can +be found in the <code>qPerson</code> function in <code><a +href="family.l">doc/family.l</a></code>. It is used in the search dialog of the +demo application, and searches for a person with the name, the parents' and +partner's names, the occupation and a time range for the birth date. The +relevant index trees in the database are searched (actually only those trees +where the user entered a search key in the corresponding dialog field), and a +logical AND of the search attributes is applied to the result. + +<p>For example, press the "Select" button, enter "Elizabeth" into the "Mother" +search field and "Phil" in the "Partner" search field, meaning to look for all +persons whose mother's name is like "Elizabeth" and whose partner's name is like +"Phil". As a result, two persons ("Elizabeth II" and "Anne") will show up. + +<p>In principle, <code><a href="refD.html#db/3">db/3</a></code> can be seen as a +special case of <code><a href="refS.html#select/3">select/3</a></code>. The +following two queries are equivalent: + +<pre><code> +: (? (db nm +Person "Edward" @P)) + @P={2-;} + @P={2-1B} + @P={2-R} + @P={2-1K} + @P={2-a} + @P={2-T} +-> NIL +: (? (select (@P) ((nm +Person "Edward")))) + @P={2-;} + @P={2-1B} + @P={2-R} + @P={2-1K} + @P={2-a} + @P={2-T} +-> NIL +</code></pre> + + +<p><hr> +<h2><a name="sql">Poor Man's SQL</a></h2> + +<h3>select</h3> + +<p>For convenience, a <code><a href="refS.html#select">select</a></code> Lisp +glue function is provided as a front-end to the <code>select</code> predicate. +Note that this function does not evaluate its arguments (it is intended for +interactive use), and that it supports only a subset of the predicate's +functionality. The syntax resembles SELECT in the SQL language, for example: + +<pre><code> +# SELECT * FROM Person +: (select +Person) # Step through the whole database +{2-o} (+Man) + nm "Adalbert Ferdinand Berengar Viktor of Prussia" + dat 688253 + ma {2-j} + pa {2-h} + fin 711698 + +{2-1B} (+Man) + nm "Albert Edward" + dat 664554 + job "Prince" + mate {2-f} + kids ({2-1C} {2-1D} {2-1E} {2-1F} {2-1G} {2-1H} {2-1I} {2-g} {2-a}) + fin 680370 +... +</code></pre> + +<pre><code> +# SELECT * FROM Person WHERE nm LIKE "%Edward%" +: (select +Person nm "Edward") # Show all Edwards +{2-;} (+Man) + nm "Edward" + dat 717346 + job "Prince" + ma {2-:} + pa {2-A} + +{2-1B} (+Man) + nm "Albert Edward" + dat 664554 + job "Prince" + kids ({2-1C} {2-1D} {2-1E} {2-1F} {2-1G} {2-1H} {2-1I} {2-g} {2-a}) + mate {2-f} + fin 680370 +... +</code></pre> + +<pre><code> +# SELECT nm, dat FROM Person WHERE nm LIKE "%Edward%" +: (select nm dat +Person nm "Edward") +"Edward" "1964-03-10" {2-;} +"Albert Edward" "1819-08-26" {2-1B} +"George Edward" NIL {2-R} +"Edward Augustus Hanover" NIL {2-1K} +... +</code></pre> + +<pre><code> +# SELECT dat, fin, p1.nm, p2.nm +# FROM Person p1, Person p2 +# WHERE p1.nm LIKE "%Edward%" +# AND p1.job LIKE "King%" +# AND p1.mate = p2.mate -- Actually, in a SQL model we'd need +# -- another table here for the join +: (select dat fin nm (mate nm) +Person nm "Edward" job "King") +"1894-06-23" "1972-05-28" "Edward VIII" "Wallace Simpson" {2-T} +"1841-11-09" NIL "Edward VII" "Alexandra of Denmark" {2-a} +-> NIL +</code></pre> + + +<h3>update</h3> + +<p>In addition (just to stay with the SQL terminology ;-), there is also an +<code><a href="refU.html#update">update</a></code> function. It is a front-end +to the <code><a href="refE.html#entityMesssages">set!></a></code> and <code><a +href="refE.html#entityMesssages">put!></a></code> transaction methods, and +should be used when single objects in the database have to be modified by hand. + +<p>In principle, it would also be possible to use the <code><a +href="refE.html#edit">edit</a></code> function to modify a database object. This +is not recommended, however, because <code>edit</code> does not know about +relations to other objects (like Links, Joints and index trees) and may easily +cause database corruption. + +<p>In the most general case, the value of a property in a database object is +changed with the <code>put!></code> method. Let's look at "Edward" from the +previous examples: + +<pre><code> +: (show '{2-;}) +{2R} (+Man) + job "Prince" + nm "Edward" + dat 717346 + ma {2-:} + pa {20A} +-> {2-;} +</code></pre> + +<p>We might change the name to "Johnny" with <code>put!></code>: + +<pre><code> +: (put!> '{2-;} 'nm "Johnny") +-> "Johnny" +</code></pre> + +<p>However, an easier and less error-prone prone way - especially when more than +one property has to be changed - is using <code><a +href="refU.html#update">update</a></code>. It presents the value cell (the list +of classes) and then each property on its own line, allowing the user to change +it with the <a href="#ledit">command line editor</a>. + +<p>Just hitting ENTER will leave that property unchanged. To modify it, you'll +typically hit ESC to get into command mode, and move the cursor to the point of +change. + +<p>For properties with nested list structures (<code>+List +Bag</code>), +<code>update</code> will recurse into the data structure. + +<pre><code> +: (update '{2-;}) +{2-;} (+Man) # ENTER +nm "Johnny" # Modified the name to "Johnny" +ma {2-:} # ENTER +pa {2-A} # ENTER +dat 1960-03-10 # Modified the year from "1964" to "1960" +job "Prince" # ENTER +-> {2-;} +</code></pre> + +<p>All changes are committed immediately, observing the rules of database +synchronization so that any another user looking at the same object will have +his GUI updated correctly. + +<p>To abort <code>update</code>, hit <code>Ctrl-X</code>. + +<p>If only a single property has to be changed, <code>update</code> can be +called directly for that property: + +<pre><code> +: (update '{2-;} 'nm) +{2-;} nm "Edward" +... +</code></pre> + + +<p><hr> +<h2><a name="ref">References</a></h2> + +<p><a name="knuth73">[knuth73]</a> Donald E. Knuth: ``The Art of Computer +Programming'', Vol.3, Addison-Wesley, 1973, p. 392 + +</body> +</html> diff --git a/doc/utf8 b/doc/utf8 @@ -0,0 +1,39 @@ + UTF-8 Format + +# Encoding for zero is different from Java +# Special character 0xFF (char T) + + 0000 .. 007F 0xxxxxxx + 6 0 + + + 0080 .. 07FF 110xxxxx 10xxxxxx + A 6 5 0 + + + 0800 .. FFFF 1110xxxx 10xxxxxx 10xxxxxx + F C B 6 5 0 + + + + Umlaute + + +äöüÄÖÜß + + +|Ä| # C3 84 <-> C4 +|Ö| # C3 96 <-> D6 +|Ü| # C3 9C <-> DC +|ä| # C3 A4 <-> E4 +|ö| # C3 B6 <-> F6 +|ü| # C3 BC <-> FC +|ß| # C3 9F <-> DF + +Paragraph # C2 A7 <-> A7 +EUR (8364 "20AC") # E2 82 AC <-> A4 + +tr -d '\303' |tr '\204\226\234\244\266\274\237' '' + +(out "Nagoya" + (prinl (char (hex "540D")) (char (hex "53E4")) (char (hex "5C4B"))) ) diff --git a/doc64/README b/doc64/README @@ -0,0 +1,136 @@ +12nov09abu +(c) Software Lab. Alexander Burger + + + 64-bit PicoLisp + =============== + +The 64-bit version of PicoLisp is a complete rewrite of the 32-bit version. + +While the 32-bit version was written in C, the 64-bit version is implemented in +a generic assembler, which in turn is written in PicoLisp. In most respects, the +two versions are compatible (see "Differences" below). + + + Building the Kernel + ------------------- + +No C-compiler is needed to build the interpreter kernel, only a 64-bit version +of the GNU assembler for the target architecture. The kernel sources are the +"*.l" files in the "src64/" directory. The PicoLisp assembler parses them, and +generates a few "*.s" files (already pre-generated in the distribution), which +the GNU assembler accepts to build the executable binary file. + +In case of modifying "*.l" source files, a running PicoLisp system (32-bit or +64-bit) is required to re-generate the "*.s" files. Due to the pre-generated +distribution, it is not necessary to compile a 32-bit version first. + +The generic assembler is in "src64/lib/asm.l". It is driven by the script +"src64/mkAsm" which is called by "src64/Makefile". + +The CPU registers and instruction set of the PicoLisp processor are described in +"doc64/asm", and the internal data structures of the PicoLisp machine in +"doc64/structures". + +Currently, only Linux on the x86-64 architecture is supported. The platform +dependent files are in the "src64/arch/" for the target architecture, and in +"src64/sys/" for the target operating system. + + + Reasons for the Use of Assembly Language + ---------------------------------------- + +Contrary to the common expectation: Runtime execution speed was not a primary +design decision factor. In general, pure code efficiency has not much influence +on the overall execution speed of an application program, as memory bandwidth +(and later I/O bandwidth) is the main bottleneck. + +The reasons to choose assembly language (instead of C) were, in decreasing order +of importance: + + 1. Stack manipulations + Alignment to cell boundaries: To be able to directly express the desired + stack data structures (see "doc64/structures", e.g. "Apply frame"), a + better control over the stack (as compared to C) was required. + + Indefinite pushs and pops: A Lisp interpreter operates on list structures + of unknown length all the time. The C version always required two passes, + the first to determine the length of the list to allocate the necessary + stack structures, and then the second to do the actual work. An assembly + version can simply push as many items as are encountered, and clean up the + stack with pop's and stack pointer arithmetics. + + 2. Alignments and memory layout control + Similar to the stack structures, there are also heap data structures that + can be directly expressed in assembly declarations (built at assembly + time), while a C implementation has to defer that to runtime. + + Built-in functions (SUBRs) need to be aligned to to a multiple of 16+2, + reflecting the data type tag requirements, and thus allow direct jumps to + the SUBR code without further pointer arithmetic and masking, as is + necessary in the C version. + + 3. Multi-precision arithmetics (Carry-Flag) + The bignum functions demand an extensive use of CPU flags. Overflow and + carry/borrow have to emulated in C with awkward comparisons of signed + numbers. + + 4. Register allocation + A manual assembly implementation can probably handle register allocation + more flexibly, with minimal context saves and reduced stack space, and + multiple values can be returned from functions in registers. As mentioned + above, this has no measurable effect on execution speed, but the binary's + overall size is significantly reduced. + + 5. Return status register flags from functions + Functions can return condition codes directly. The callee does not need to + re-check returned values. Again, this has only a negligible impact on + performance. + + 6. Multiple function entry points + Some things can be handled more flexibly, and existing code may be easier + to re-use. This is on the same level as wild jumps within functions + ('goto's), but acceptable in the context of an often-used but rarely + modified program like a Lisp kernel. + +It would indeed be feasible to write only certain parts of the system in +assembly, and the rest in C. But this would be rather unsatisfactory. And it +gives a nice feeling to be independent of a heavy-weight C compiler. + + + Differences to the 32-bit Version + --------------------------------- + +Except for the following six cases, the 64-bit version should behave identically +to the 32-bit version. + +1. Internal format and printed representation of external symbols + This is probably the most significant change. External (i.e. database) + symbols are coded more efficiently internally (occupying only a single cell), + and have a slightly different printed representation. Existing databases need + to be converted. + +2. Short numbers are pointer-equal + As there is now an internal "short number" type, an expression like + + (== 64 64) + + will evaluate to 'T' on a 64-bit system, but to 'NIL' on a 32-bit system. + +3. Bit manipulation functions may differ for negative arguments + Numbers are represented internally in a different format. Bit manipulations + are not really defined for negative numbers, but (& -15 -6) will give -6 on + 32 bits, and 6 on 64 bits. + +4. 'do' takes only a 'cnt' argument (not a bignum) + For the sake of simplicity, a short number (60 bits) is considered to be + enough for counted loops. + +5. Calling native functions is different. Direct calls using the 'lib:fun' + notation is still possible (see the 'ext' and 'ht' libraries), but the + corresponding functions must of course be coded in assembly and not in C. To + call C functions, the new 'native' function should be used, which can + interface to native C functions directly, without the need of glue code to + convert arguments and return values. + +6. Bugs (in the implementation, or in this list ;-) diff --git a/doc64/asm b/doc64/asm @@ -0,0 +1,194 @@ +# 06mar10abu +# (c) Software Lab. Alexander Burger + + + CPU Registers: + + +---+---+---+---+---+---+---+---+ + | A | B | \ [A]ccumulator + +---+---+---+---+---+---+---+---+ D [B]yte register + | C | / [C]ount register + +---+---+---+---+---+---+---+---+ [D]ouble register + | E | [E]xpression register + +---+---+---+---+---+---+---+---+ + + + +---+---+---+---+---+---+---+---+ + | X | [X] Index register + +---+---+---+---+---+---+---+---+ [Y] Index register + | Y | [Z] Index register + +---+---+---+---+---+---+---+---+ + | Z | + +---+---+---+---+---+---+---+---+ + + + +---+---+---+---+---+---+---+---+ + | L | [L]ink register + +---+---+---+---+---+---+---+---+ [S]tack pointer + | S | + +---+---+---+---+---+---+---+---+ + + + +-------------------------------+ + | [z]ero [s]ign [c]arry | [F]lags + +-------------------------------+ + +======================================================================== + + Source Addressing Modes: + ld A 1234 # Immediate + ld A "(a+b-c)" + ld A R # Register + ld A Global # Direct + ld A (R) # Indexed + ld A (R 8) # Indexed with offset + ld A (R OFFS) + ld A (R Global) + ld A (Global) # Indirect + ld A (Global OFFS) # Indirect with offset + ld A ((R)) # Indexed indirect + ld A ((R 8)) # Indexed with offset indirect + ld A ((R 8) OFFS) + ld A ((R Global) OFFS) + ld A ((R OFFS) Global) + ... + + Destination Addressing Modes: + ld R A # Register + ld (R) A # Indexed + ld (R 8) A # Indexed with offset + ld (R OFFS) A + ld (R Global) A + ld (Global) A # Indirect + ld (Global OFFS) A # Indirect with offset + ld ((R)) A # Indexed indirect + ld ((R 8)) A # Indexed with offset indirect + ld ((R 8) OFFS) A + ld ((R Global) OFFS) A + ld ((R OFFS) Global) A + ... + + Target Addressing Modes: + jmp 1234 # Absolute + jmp Label + jmp (R) # Indexed + jmp (Global) # Indirect + +======================================================================== + + Instruction set: + nop # No operation + + Move Instructions: + ld dst src # Load 'dst' from 'src' + ld2 src # Load 'A' from two bytes 'src' (signed) + ld4 src # Load 'A' from four bytes 'src' (signed) + ldc dst src # Load if Carry 'dst' from 'src' + ldnc dst src # Load if not Carry 'dst' from 'src' + ldz dst src # Load if Zero 'dst' from 'src' + ldnz dst src # Load if not Zero 'dst' from 'src' + lea dst src # Load 'dst' with effective address of 'src' + st2 dst # Store two bytes from 'A' into 'dst' + st4 dst # Store four bytes from 'A' into 'dst' + xchg dst dst # Exchange 'dst's + movm dst src end # Move memory between 'src' and 'end' to 'dst' + movn dst src cnt # Move 'cnt' bytes from 'src' to 'dst' + mset dst cnt # Set 'cnt' bytes of memory to B + + Arithmetics: + add dst src # Add 'src' to 'dst' + addc dst src # Add 'src' to 'dst' with Carry + sub dst src # Subtract 'src' from 'dst' + subc dst src # Subtract 'src' from 'dst' with Carry + + not dst # One's complement negation of 'dst' + neg dst # Two's complement negation of 'dst' + + and dst src # Bitwise AND 'dst' with 'src' + or dst src # Bitwise OR 'dst' with 'src' + xor dst src # Bitwise XOR 'dst' with 'src' + off dst src # Clear 'src' bits in 'src' + test dst src # Bit-test 'dst' with 'src' + + shl dst src # Shift 'dst' left into Carry by 'src' bits + shr dst src # Shift 'dst' right into Carry by 'src' bits + rol dst src # Rotate 'dst' left by 'src' bits + ror dst src # Rotate 'dst' right by 'src' bits + rcl dst src # Rotate 'dst' with Carry left by 'src' bits + rcr dst src # Rotate 'dst' with Carry right by 'src' bits + + mul src # Multiplication of 'A' and 'src' into 'D' + div src # Division of 'D' by 'src' into 'A', 'C' + + zxt # Zero-extend 'B' to 'A' + sxt # Sign-extend 'B' to 'A' + int # Sign-extend 32 bits to 64 bits in 'A' + + setc # Set Carry flag + clrc # Clear Carry flag + setz # Set Zero flag + clrz # Clear Zero flag + + Comparisons: + cmp dst src # Compare 'dst' with 'src' + cmp4 src # Compare four bytes in 'A' with 'src' + cmpm dst src end # Compare 'dst' with with memory between 'src' and 'end' + cmpn dst src cnt # Compare 'cnt' bytes 'dst' with 'src' + slen dst src # Set 'dst' to the string length of 'src' + memb src cnt # Find B in 'cnt' bytes of memory + null src # Compare 'src' with 0 + zero src # 'z' if ZERO + nul4 # Compare four bytes in 'A' with 0 + + Byte addressing: + set dst src # Set 'dst' byte to 'src' + nul src # Compare byte 'src' with 0 + + Types: + cnt src # Non-'z' if small number + big src # Non-'z' if bignum + num src # Non-'z' if number + sym src # Non-'z' if symbol + atom src # Non-'z' if atom + + Flow Control: + jmp adr # Jump to 'adr' + jz adr # Jump to 'adr' if Zero + jnz adr # Jump to 'adr' if not Zero + js adr # Jump to 'adr' if Sign + jns adr # Jump to 'adr' if not Sign + jc adr # Jump to 'adr' if Carry + jnc adr # Jump to 'adr' if not Carry + + call adr # Call 'adr' + cc adr(src ..) # C-Call to 'adr' with 'src' arguments + cc adr reg # C-Call to 'adr' with end of stacked args in 'reg' + + ret # Return + begin src # Called from C-function with 'src' arguments + return src # Return to C-function + + Stack Manipulations: + push src # Push 'src' + pop dst # Pop 'dst' + link # Setup frame + tuck src # Extend frame + drop # Drop frame + + Evaluation: + eval # Evaluate expression in 'E' + eval+ # Evaluate expression in partial stack frame + eval/ret # Evaluate expression and return + exec reg # Execute lists in 'reg', ignore results + prog reg # Evaluate expressions in 'reg', return last result + + System: + init # Init runtime system + dbg # Debug breakpoint + +======================================================================== + + Naming conventions: + + Lisp level functions, which would be all of the form 'doXyzE_E', are written + as 'doXyz' for brevity. diff --git a/doc64/structures b/doc64/structures @@ -0,0 +1,308 @@ +# 06mar10abu +# (c) Software Lab. Alexander Burger + + + ### Primary data types ### + + cnt xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxS010 + big xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxS100 + sym xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx1000 + cell xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx0000 + + + Bignum + | + V + +-----+-----+ + | DIG | | | + +-----+--+--+ + | + V + +-----+-----+ + | DIG | | | + +-----+--+--+ + | + V + +-----+-----+ + | DIG | CNT | + +-----+-----+ + + + Cell + | + 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 | V + +-----+-----+--+--+-----+-----+-----+-----+-----+--- ---+-----+ + | | | | | | / | | ... | | | + +-----+-----+-----+-----+-----+-----+-----+-----+--- ---+--+--+ + | + | + +-----> + + + ### Stack ### + + Saved values: + ^ + | + +---> LINK ----+ + | val1 + | val2 + | ... + | valN + +---- LINK <-- L + + + Bind frame: + ^ + Bind | + +---> LINK ----+ + | val1 + | sym1 + | ... + | valN + | symN + +---- LINK <-- L <-- Bind + eswp + + + VarArgs frame: + ^ + Bind | + +---> LINK ----+ + | val1 + | sym1 + | ... + | valN + | symN + +---- LINK <---+ <-- Bind + eswp | + Next | + Args | + +---> LINK ----+ <-- Next + | arg1 + | ... + | argN <-- Args + +---- LINK <-- L + + + Apply args: + ^ + | + +---> LINK ----+ + | ... + | fun <-- Y + | arg1 + | ... + | argN <-- Z + | ... + +---- LINK <-- L + + + Apply frame: + ^ + Apply | + +---> LINK ----+ + | ... + | +-- cdr + | | fun <-- exe + | | val1 <-+ (gc) + | | zero | + | | cdr1 --|---+ (gc) + | +-> car1 --+ | + | ... | + | valN <-+ | (gc) + | zero | | + | NIL | | (gc) + | carN --+ <-+ + +---- LINK <-- L <-- Apply + + + Method frame: + ^ + cls | + key | + LINK ----+ <-- Meth + + + Catch frame: + ^ + X | + Y | + Z | + L | + <III> [env] | + <II> fin | + <I> tag | + LINK ----+ <-- Catch + + + I/O frame: + ^ + <III> put/get | + <II> pid | + <I> fd | + LINK ----+ <-- inFrames, outFrames, ctlFrames + + + + ### Memory ### + + inFile: + --> fd # File descriptor + <I> ix # Read index + <II> cnt # Buffer count + <III> next # Next character + <IV> line # Line number + <V> src # Source line number + <VI> name # Filename + <VII> buf # Buffer [BUFSIZ] + + outFile: + --> fd # File descriptor + <I> ix # Read index + <II> tty # TTY flag + <III> buf # Buffer [BUFSIZ] + + + child: + --> pid # Process ID + <I> hear # Pipe read end + <II> tell # Pipe write end + <III> ofs # Buffer offset + <IV> cnt # Buffer count + <V> buf # Buffer pointer + + +--------------------------+ Mic + | + | +-----------------+ Tell <Child> + | | + | +-----------------> Hear + <Parent> | | + | | + Spkr <---+ | + | | + | | + | +-----------------+ Tell + | | + | +-----------------> Hear <Child> + | + +--------------------------+ 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 + + dbFile: # Size VIII (64 bytes) + --> fd # File descriptor + <I> db # File number + <II> sh # Block shift + <III> siz # Block size (64 << sh) + <IV> flgs # Flags: Lock(0), Dirty(1) + <V> marks # Mark vector size + <VI> mark # Mark bit vector + <VII> fluse # Free list use count + + + ### Assumptions ### + + - 8 bit per byte + - 64 bit per word + - Stack grows downwards, aligned to 64 bit + - Memory access legal also at 4-byte boundaries diff --git a/ext.l b/ext.l @@ -0,0 +1,6 @@ +# 14apr10abu +# (c) Software Lab. Alexander Burger + +(load "@lib/misc.l" "@lib/btree.l" "@lib/db.l" "@lib/pilog.l") + +# vi:et:ts=3:sw=3 diff --git a/favicon.ico b/favicon.ico Binary files differ. diff --git a/games/README b/games/README @@ -0,0 +1,233 @@ +12nov09abu +(c) Software Lab. Alexander Burger + + + PicoLisp Demo Games + =================== + +This directory contains a few simple games. They are neither especially +interesting, nor powerful, but may be useful as programming examples. + + + +'mine' is a simplified version of the minesweeper game. You can start it as: + +$ ./dbg games/mine.l -main -go + +It will display a 12-by-12 field with 24 (default) hidden mines. You can move +around using the standard 'vi'-keys 'j' (down), 'k' (up), 'l' (right) and 'h' +(left). + +Hit ENTER or SPACE to uncover a field, and ESC to terminate the game. In the +latter case (of if a mine exploded), you'll get the PicoLisp prompt. Then you +can continue the game with + +: (go) + +possibly after re-initializing it with + +: (main) + +or exit the PicoLisp interpreter with ENTER. + + + +'nim' and 'ttt' are only testbeds for the general 'game' alpha-beta search +function (normally, these games are better implemented by directly exploring +their underlying principles and strategies). + +Start 'nim' as + +$ ./dbg games/nim.l + +and then find the optimal move path for, let's say, three heaps of four matches +each: + +: (nim 4 4 4) +-> (-100 ((1 . 4) 1 . -4) ((2 . 4) 2 . -4) ((3 . 4) 3 . -4)) + +This is a winning position (a minimal cost of -100), with three moves (in the +CARs of the move list: Take 4 from heap 1, then 4 from heap 2, and finally 4 +from heap 3). + + + +To play Tic-Tac-Toe, enter + +$ ./dbg games/ttt.l -main + +A three-by-three board is displayed. Enter your moves with the 'go' function: + +: (go a 1) + +---+---+---+ + 3 | | | | + +---+---+---+ + 2 | | | | + +---+---+---+ + 1 | T | | | + +---+---+---+ + a b c + +Your positions are marked with 'T', the computer's with '0'. + + + +The 'chess' game is minimalistic (441 lines of code). Nevertheless, it plays +some slow - though correct - chess. Start it as: + +$ ./dbg games/chess.l -main + +---+---+---+---+---+---+---+---+ + 8 |<R>|<N>|<B>|<Q>|<K>|<B>|<N>|<R>| + +---+---+---+---+---+---+---+---+ + 7 |<P>|<P>|<P>|<P>|<P>|<P>|<P>|<P>| + +---+---+---+---+---+---+---+---+ + 6 | | - | | - | | - | | - | + +---+---+---+---+---+---+---+---+ + 5 | - | | - | | - | | - | | + +---+---+---+---+---+---+---+---+ + 4 | | - | | - | | - | | - | + +---+---+---+---+---+---+---+---+ + 3 | - | | - | | - | | - | | + +---+---+---+---+---+---+---+---+ + 2 | P | P | P | P | P | P | P | P | + +---+---+---+---+---+---+---+---+ + 1 | R | N | B | Q | K | B | N | R | + +---+---+---+---+---+---+---+---+ + a b c d e f g h + +The pieces are indicated by the letters 'K'ing, 'Q'ueen, 'R'ook, 'B'ishop, +k'N'ight and 'P'awn, with black pieces in angular brackets. + + +Alternatively, you can also run it through XBoard (in the X Window System): + +$ xboard -fcp games/xchess + +This requires the symbolic links in "/usr/lib/" and "/usr/bin/", as recommended +in INSTALL. If this is not an option, please modify the first line ("#!") of +"games/xchess". + + +Without XBoard, you may enter your moves with the field names (in lower case) +for the "from" and "to" positions: + +: (go e2 e4) + +Castling may be entered by just specifying the king's move: + +: (go e1 g1) + +To undo one or several moves, enter + +: (go -) + +and to redo them + +: (go +) + +To switch sides (and have the computer play against itself), call 'go' without +arguments: + +: (go) + +The initial board position can be restored with + +: (main) + +The global variable '*Depth' holds the maximal depth of the alpha-beta tree +search. It defaults to 5. You may change it to some smaller value for a faster +response, or to a larger value for a deeper search: + +: (setq *Depth 7) + +The same effect can be achieved by passing the desired depth as the first +argument to 'main': + +: (main 7) + +The second (optional) argument to 'main' is your color ('NIL' for white and 'T' +for black). + +To setup some given board position, call 'main' with a list of triples, with +each describing: + + 1. The field + 2. The piece's classes + 3. An optional flag to indicate that the piece did not move yet + +: (main 5 NIL + (quote + (a2 (+White +Pawn) T) + (b1 (+White +King)) + (d4 (+Black +King)) ) ) + +---+---+---+---+---+---+---+---+ + 8 | | - | | - | | - | | - | + +---+---+---+---+---+---+---+---+ + 7 | - | | - | | - | | - | | + +---+---+---+---+---+---+---+---+ + 6 | | - | | - | | - | | - | + +---+---+---+---+---+---+---+---+ + 5 | - | | - | | - | | - | | + +---+---+---+---+---+---+---+---+ + 4 | | - | |<K>| | - | | - | + +---+---+---+---+---+---+---+---+ + 3 | - | | - | | - | | - | | + +---+---+---+---+---+---+---+---+ + 2 | P | - | | - | | - | | - | + +---+---+---+---+---+---+---+---+ + 1 | - | K | - | | - | | - | | + +---+---+---+---+---+---+---+---+ + a b c d e f g h + +At any time, you can print the current board position in the above format to a +file with + +: (ppos "file") + +which later can be restored with + +: (load "file") + + + +There is also a plain 'sudoku' solver: + +$ ./dbg games/sudoku.l + +: (main + (quote + (5 3 0 0 7 0 0 0 0) + (6 0 0 1 9 5 0 0 0) + (0 9 8 0 0 0 0 6 0) + (8 0 0 0 6 0 0 0 3) + (4 0 0 8 0 3 0 0 1) + (7 0 0 0 2 0 0 0 6) + (0 6 0 0 0 0 2 8 0) + (0 0 0 4 1 9 0 0 5) + (0 0 0 0 8 0 0 7 9) ) ) + +---+---+---+---+---+---+---+---+---+ + 9 | 5 3 | 7 | | + + + + + + + + + + + + 8 | 6 | 1 9 5 | | + + + + + + + + + + + + 7 | 9 8 | | 6 | + +---+---+---+---+---+---+---+---+---+ + 6 | 8 | 6 | 3 | + + + + + + + + + + + + 5 | 4 | 8 3 | 1 | + + + + + + + + + + + + 4 | 7 | 2 | 6 | + +---+---+---+---+---+---+---+---+---+ + 3 | 6 | | 2 8 | + + + + + + + + + + + + 2 | | 4 1 9 | 5 | + + + + + + + + + + + + 1 | | 8 | 7 9 | + +---+---+---+---+---+---+---+---+---+ + a b c d e f g h i + +Type + +: (go) + +to let it search for a solution. diff --git a/games/chess.l b/games/chess.l @@ -0,0 +1,566 @@ +# 04aug07abu +# (c) Software Lab. Alexander Burger + +# *Board a1 .. h8 +# *White *Black *WKPos *BKPos *Pinned +# *Depth *Moved *Undo *Redo *Me *You + +(load "@lib/simul.l") + +### Fields/Board ### +# x y color piece whAtt blAtt + +(setq *Board (grid 8 8)) + +(for (X . Lst) *Board + (for (Y . This) Lst + (=: x X) + (=: y Y) + (=: color (not (bit? 1 (+ X Y)))) ) ) + +(de *Straight `west `east `south `north) + +(de *Diagonal + ((This) (: 0 1 1 0 -1 1)) # Southwest + ((This) (: 0 1 1 0 -1 -1)) # Northwest + ((This) (: 0 1 -1 0 -1 1)) # Southeast + ((This) (: 0 1 -1 0 -1 -1)) ) # Northeast + +(de *DiaStraight + ((This) (: 0 1 1 0 -1 1 0 -1 1)) # South Southwest + ((This) (: 0 1 1 0 -1 1 0 1 1)) # West Southwest + ((This) (: 0 1 1 0 -1 -1 0 1 1)) # West Northwest + ((This) (: 0 1 1 0 -1 -1 0 -1 -1)) # North Northwest + ((This) (: 0 1 -1 0 -1 -1 0 -1 -1)) # North Northeast + ((This) (: 0 1 -1 0 -1 -1 0 1 -1)) # East Northeast + ((This) (: 0 1 -1 0 -1 1 0 1 -1)) # East Southeast + ((This) (: 0 1 -1 0 -1 1 0 -1 1)) ) # South Southeast + + +### Pieces ### +(de piece (Typ Cnt Fld) + (prog1 + (def + (pack (mapcar '((Cls) (cdr (chop Cls))) Typ)) + Typ ) + (init> @ Cnt Fld) ) ) + + +(class +White) +# color ahead + +(dm init> (Cnt Fld) + (=: ahead north) + (extra Cnt Fld) ) + +(dm name> () + (pack " " (extra) " ") ) + +(dm move> (Fld) + (adjMove '*White '*WKPos whAtt- whAtt+) ) + + +(class +Black) +# color ahead + +(dm init> (Cnt Fld) + (=: color T) + (=: ahead south) + (extra Cnt Fld) ) + +(dm name> () + (pack '< (extra) '>) ) + +(dm move> (Fld) + (adjMove '*Black '*BKPos blAtt- blAtt+) ) + + +(class +piece) +# cnt field attacks + +(dm init> (Cnt Fld) + (=: cnt Cnt) + (move> This Fld) ) + +(dm ctl> ()) + + +(class +King +piece) + +(dm name> () 'K) + +(dm val> () 120) + +(dm ctl> () + (unless (=0 (: cnt)) -10) ) + +(dm moves> () + (make + (unless + (or + (n0 (: cnt)) + (get (: field) (if (: color) 'whAtt 'blAtt)) ) + (tryCastle west T) + (tryCastle east) ) + (try1Move *Straight) + (try1Move *Diagonal) ) ) + +(dm attacks> () + (make + (try1Attack *Straight) + (try1Attack *Diagonal) ) ) + + +(class +Castled) + +(dm ctl> () 30) + + +(class +Queen +piece) + +(dm name> () 'Q) + +(dm val> () 95) + +(dm moves> () + (make + (tryMoves *Straight) + (tryMoves *Diagonal) ) ) + +(dm attacks> () + (make + (tryAttacks *Straight) + (tryAttacks *Diagonal T) ) ) + + +(class +Rook +piece) + +(dm name> () 'R) + +(dm val> () 50) + +(dm moves> () + (make (tryMoves *Straight)) ) + +(dm attacks> () + (make (tryAttacks *Straight)) ) + + +(class +Bishop +piece) + +(dm name> () 'B) + +(dm val> () 33) + +(dm ctl> () + (when (=0 (: cnt)) -10) ) + +(dm moves> () + (make (tryMoves *Diagonal)) ) + +(dm attacks> () + (make (tryAttacks *Diagonal T)) ) + + +(class +Knight +piece) + +(dm name> () 'N) + +(dm val> () 33) + +(dm ctl> () + (when (=0 (: cnt)) -10) ) + +(dm moves> () + (make (try1Move *DiaStraight)) ) + +(dm attacks> () + (make (try1Attack *DiaStraight)) ) + + +(class +Pawn +piece) + +(dm name> () 'P) + +(dm val> () 10) + +(dm moves> () + (let (Fld1 ((: ahead) (: field)) Fld2 ((: ahead) Fld1)) + (make + (and + (tryPawnMove Fld1 Fld2) + (=0 (: cnt)) + (tryPawnMove Fld2 T) ) + (tryPawnCapt (west Fld1) Fld2 (west (: field))) + (tryPawnCapt (east Fld1) Fld2 (east (: field))) ) ) ) + +(dm attacks> () + (let Fld ((: ahead) (: field)) + (make + (and (west Fld) (link @)) + (and (east Fld) (link @)) ) ) ) + + +### Move Logic ### +(de inCheck (Color) + (if Color (get *BKPos 'whAtt) (get *WKPos 'blAtt)) ) + +(de whAtt+ (This Pce) + (=: whAtt (cons Pce (: whAtt))) ) + +(de whAtt- (This Pce) + (=: whAtt (delq Pce (: whAtt))) ) + +(de blAtt+ (This Pce) + (=: blAtt (cons Pce (: blAtt))) ) + +(de blAtt- (This Pce) + (=: blAtt (delq Pce (: blAtt))) ) + +(de adjMove (Var KPos Att- Att+) + (let (W (: field whAtt) B (: field blAtt)) + (when (: field) + (put @ 'piece NIL) + (for F (: attacks) (Att- F This)) ) + (nond + (Fld (set Var (delq This (val Var)))) + ((: field) (push Var This)) ) + (ifn (=: field Fld) + (=: attacks) + (put Fld 'piece This) + (and (isa '+King This) (set KPos Fld)) + (for F (=: attacks (attacks> This)) (Att+ F This)) ) + (reAtttack W (: field whAtt) B (: field blAtt)) ) ) + +(de reAtttack (W W2 B B2) + (for This W + (unless (memq This W2) + (for F (: attacks) (whAtt- F This)) + (for F (=: attacks (attacks> This)) (whAtt+ F This)) ) ) + (for This W2 + (for F (: attacks) (whAtt- F This)) + (for F (=: attacks (attacks> This)) (whAtt+ F This)) ) + (for This B + (unless (memq This B2) + (for F (: attacks) (blAtt- F This)) + (for F (=: attacks (attacks> This)) (blAtt+ F This)) ) ) + (for This B2 + (for F (: attacks) (blAtt- F This)) + (for F (=: attacks (attacks> This)) (blAtt+ F This)) ) ) + +(de try1Move (Lst) + (for Dir Lst + (let? Fld (Dir (: field)) + (ifn (get Fld 'piece) + (link (list This (cons This Fld))) + (unless (== (: color) (get @ 'color)) + (link + (list This + (cons (get Fld 'piece)) + (cons This Fld) ) ) ) ) ) ) ) + +(de try1Attack (Lst) + (for Dir Lst + (and (Dir (: field)) (link @)) ) ) + +(de tryMoves (Lst) + (for Dir Lst + (let Fld (: field) + (loop + (NIL (setq Fld (Dir Fld))) + (T (get Fld 'piece) + (unless (== (: color) (get @ 'color)) + (link + (list This + (cons (get Fld 'piece)) + (cons This Fld) ) ) ) ) + (link (list This (cons This Fld))) ) ) ) ) + +(de tryAttacks (Lst Diag) + (use (Pce Cls Fld2) + (for Dir Lst + (let Fld (: field) + (loop + (NIL (setq Fld (Dir Fld))) + (link Fld) + (T + (and + (setq Pce (get Fld 'piece)) + (<> (: color) (get Pce 'color)) ) ) + (T (== '+Pawn (setq Cls (last (type Pce)))) + (and + Diag + (setq Fld2 (Dir Fld)) + (= (get Fld2 'y) (get ((get Pce 'ahead) Fld) 'y)) + (link Fld2) ) ) + (T (memq Cls '(+Knight +Queen +King))) + (T (and Pce (xor Diag (== Cls '+Bishop)))) ) ) ) ) ) + +(de tryPawnMove (Fld Flg) + (unless (get Fld 'piece) + (if Flg + (link (list This (cons This Fld))) + (for Cls '(+Queen +Knight +Rook +Bishop) + (link + (list This + (cons This) + (cons + (piece (list (car (type This)) Cls) (: cnt)) + Fld ) ) ) ) ) ) ) + +(de tryPawnCapt (Fld1 Flg Fld2) + (if (get Fld1 'piece) + (unless (== (: color) (get @ 'color)) + (if Flg + (link + (list This + (cons (get Fld1 'piece)) + (cons This Fld1) ) ) + (for Cls '(+Queen +Knight +Rook +Bishop) + (link + (list This + (cons (get Fld1 'piece)) + (cons This) + (cons + (piece (list (car (type This)) Cls) (: cnt)) + Fld1 ) ) ) ) ) ) + (let? Pce (get Fld2 'piece) + (and + (== Pce (car *Moved)) + (= 1 (get Pce 'cnt)) + (isa '+Pawn Pce) + (n== (: color) (get Pce 'color)) + (link (list This (cons Pce) (cons This Fld1))) ) ) ) ) + +(de tryCastle (Dir Long) + (use (Fld1 Fld2 Fld Pce) + (or + (get (setq Fld1 (Dir (: field))) 'piece) + (get Fld1 (if (: color) 'whAtt 'blAtt)) + (get (setq Fld2 (Dir Fld1) Fld Fld2) 'piece) + (when Long + (or + (get (setq Fld (Dir Fld)) 'piece) + (get Fld (if (: color) 'whAtt 'blAtt)) ) ) + (and + (== '+Rook (last (type (setq Pce (get (Dir Fld) 'piece))))) + (=0 (get Pce 'cnt)) + (link + (list This + (cons This) + (cons + (piece (cons (car (type This)) '(+Castled +King)) 1) + Fld2 ) + (cons Pce Fld1) ) ) ) ) ) ) + +(de pinned (Fld Lst Color) + (use (Pce L P) + (and + (loop + (NIL (setq Fld (Dir Fld))) + (T (setq Pce (get Fld 'piece)) + (and + (= Color (get Pce 'color)) + (setq L + (make + (loop + (NIL (setq Fld (Dir Fld))) + (link Fld) + (T (setq P (get Fld 'piece))) ) ) ) + (<> Color (get P 'color)) + (memq (last (type P)) Lst) + (cons Pce L) ) ) ) + (link @) ) ) ) + + +### Moves ### +# Move ((p1 (p1 . f2)) . ((p1 . f1))) +# Capture ((p1 (p2) (p1 . f2)) . ((p1 . f1) (p2 . f2))) +# Castle ((K (K) (C . f2) (R . f4)) . ((R . f3) (K . f1))) +# Promote ((P (P) (Q . f2)) . ((Q) (P . f1))) +# Capt/Prom ((P (p1) (P) (Q . f2)) . ((Q) (P . f2) (p1 . f1))) +(de moves (Color) + (filter + '((Lst) + (prog2 + (move (car Lst)) + (not (inCheck Color)) + (move (cdr Lst)) ) ) + (mapcan + '((Pce) + (mapcar + '((Lst) + (cons Lst + (flip + (mapcar + '((Mov) (cons (car Mov) (get Mov 1 'field))) + (cdr Lst) ) ) ) ) + (moves> Pce) ) ) + (if Color *Black *White) ) ) ) + +(de move (Lst) + (if (atom (car Lst)) + (inc (prop (push '*Moved (pop 'Lst)) 'cnt)) + (dec (prop (pop '*Moved) 'cnt)) ) + (for Mov Lst + (move> (car Mov) (cdr Mov)) ) ) + + +### Evaluation ### +(de mate (Color) + (and (inCheck Color) (not (moves Color))) ) + +(de battle (Fld Prey Attacker Defender) + (use Pce + (loop + (NIL (setq Pce (mini 'val> Attacker)) 0) + (setq Attacker (delq Pce Attacker)) + (NIL (and (asoq Pce *Pinned) (not (memq Fld @))) + (max 0 (- Prey (battle Fld (val> Pce) Defender Attacker))) ) ) ) ) + +# Ref. Sargon, Dan and Kate Spracklen, Hayden 1978 +(de cost (Color) + (if (mate (not Color)) + -9999 + (setq *Pinned + (make + (for Dir *Straight + (pinned *WKPos '(+Rook +Queen)) + (pinned *BKPos '(+Rook +Queen) T) ) + (for Dir *Diagonal + (pinned *WKPos '(+Bishop +Queen)) + (pinned *BKPos '(+Bishop +Queen) T) ) ) ) + (let (Ctl 0 Mat 0 Lose 0 Win1 NIL Win2 NIL Flg NIL) + (use (White Black Col Same B) + (for Lst *Board + (for This Lst + (setq White (: whAtt) Black (: blAtt)) + ((if Color inc dec) 'Ctl (- (length White) (length Black))) + (let? Val (and (: piece) (val> @)) + (setq Col (: piece color) Same (== Col Color)) + ((if Same dec inc) 'Ctl (ctl> (: piece))) + (unless + (=0 + (setq B + (if Col + (battle This Val White Black) + (battle This Val Black White) ) ) ) + (dec 'Val 5) + (if Same + (setq + Lose (max Lose B) + Flg (or Flg (== (: piece) (car *Moved))) ) + (when (> B Win1) + (xchg 'B 'Win1) + (setq Win2 (max Win2 B)) ) ) ) + ((if Same dec inc) 'Mat Val) ) ) ) ) + (unless (=0 Lose) (dec 'Lose 5)) + (if Flg + (* 4 (+ Mat Lose)) + (when Win2 + (dec 'Lose (>> 1 (- Win2 5))) ) + (+ Ctl (* 4 (+ Mat Lose))) ) ) ) ) + + +### Game ### +(de display (Res) + (when Res + (disp *Board T + '((This) + (cond + ((: piece) (name> @)) + ((: color) " - ") + (T " ") ) ) ) ) + (and (inCheck *You) (prinl "(+)")) + Res ) + +(de moved? (Lst) + (or + (> 16 (length Lst)) + (find '((This) (n0 (: cnt))) Lst) ) ) + +(de bookMove (From To) + (let Pce (get From 'piece) + (list 0 (list (list Pce (cons Pce To)) (cons Pce From))) ) ) + +(de myMove () + (let? M + (cond + ((moved? (if *Me *Black *White)) + (game *Me *Depth moves move cost) ) + (*Me + (if (member (get *Moved 1 'field 'x) (1 2 3 5)) + (bookMove 'e7 'e5) + (bookMove 'd7 'd5) ) ) + ((rand T) (bookMove 'e2 'e4)) + (T (bookMove 'd2 'd4)) ) + (move (car (push '*Undo (cadr M)))) + (off *Redo) + (cons (car M) (mapcar cdar (cdr M))) ) ) + +(de yourMove (From To) + (when + (find + '((Lst) + (and + (== (caar Lst) (get From 'piece)) + (== To (pick cdr (cdar Lst))) ) ) + (moves *You) ) + (prog1 + (car (push '*Undo @)) + (off *Redo) + (move @) ) ) ) + +(de undo () + (move (cdr (push '*Redo (pop '*Undo)))) ) + +(de redo () + (move (car (push '*Undo (pop '*Redo)))) ) + +(de setup (Depth You Init) + (setq *Depth (or Depth 5) *You You *Me (not You)) + (off *White *Black *Moved *Undo *Redo) + (for Lst *Board + (for This Lst (=: piece) (=: whAtt) (=: blAtt)) ) + (if Init + (for L Init + (with (piece (cadr L) 0 (car L)) + (unless (caddr L) + (=: cnt 1) + (push '*Moved This) ) ) ) + (mapc + '((Cls Lst) + (piece (list '+White Cls) 0 (car Lst)) + (piece '(+White +Pawn) 0 (cadr Lst)) + (piece '(+Black +Pawn) 0 (get Lst 7)) + (piece (list '+Black Cls) 0 (get Lst 8)) ) + '(+Rook +Knight +Bishop +Queen +King +Bishop +Knight +Rook) + *Board ) ) ) + +(de main (Depth You Init) + (setup Depth You Init) + (display T) ) + +(de go Args + (display + (cond + ((not Args) (xchg '*Me '*You) (myMove)) + ((== '- (car Args)) (and *Undo (undo))) + ((== '+ (car Args)) (and *Redo (redo))) + ((yourMove (car Args) (cadr Args)) (display T) (myMove)) ) ) ) + +# Print position to file +(de ppos (File) + (out File + (println + (list 'main *Depth *You + (lit + (mapcar + '((This) + (list + (: field) + (val This) + (not (memq This *Moved)) ) ) + (append *White *Black) ) ) ) ) ) ) + +# vi:et:ts=3:sw=3 diff --git a/games/mine.l b/games/mine.l @@ -0,0 +1,126 @@ +# 22mar10abu +# (c) Software Lab. Alexander Burger + +(load "lib/term.l") + +# Spielfeldbelegung: +# NIL Verdeckt: Leeres Feld +# T Verdeckt: Mine +# 0-8 Aufgedeckt, Nachbarminen + +(seed (in "/dev/urandom" (rd 8))) + +# Globale Konstanten +(de *Minen . 24) # Anzahl der Minen +(de *FeldX . 12) # Feldgroesse X +(de *FeldY . 12) # Feldgroesse Y + +(de *NachbarX -1 0 +1 -1 +1 -1 0 +1) +(de *NachbarY -1 -1 -1 0 0 +1 +1 +1) + +# Globale Variablen +(de *Feld) # Datenbereich des Minenfeldes + + +# Eine Mine legen +(de legeMine () + (use (X Y) + (while + (get *Feld + (setq Y (rand 1 *FeldY)) + (setq X (rand 1 *FeldX)) ) ) + (set (nth *Feld Y X) T) ) ) + +# *Feld anzeigen +(de anzeigen (Flg) + (let (N 0 Y 0) + (for L *Feld + (prin (align 2 (inc 'Y)) " ") + (for C L + (prin + " " + (cond + ((not C) (inc 'N) "-") + (Flg C) + ((=T C) "-") + (T C) ) ) ) + (prinl) ) + (prin " ") + (for C *FeldX + (prin " " (char (+ 64 C))) ) + (prinl) + (prinl "<" N "> ") ) ) + +# Ein Feld ausrechnen +(de wertFeld (X Y) + (when + (=0 + (set + (nth *Feld Y X) + (sum + '((DX DY) + (if (=T (get *Feld (+ Y DY) (+ X DX))) + 1 0 ) ) + *NachbarX + *NachbarY ) ) ) + (mapc + '((DX DY) + (and + (<= 1 (inc 'DX X) *FeldX) + (<= 1 (inc 'DY Y) *FeldY) + (not (member (cons DX DY) *Visit)) + (push '*Visit (cons DX DY)) + (wertFeld DX DY) ) ) + *NachbarX + *NachbarY ) ) ) + +# Hauptfunktion +(de main (N) + (when N + (setq *Minen N) ) + (setq *Feld + (make (do *FeldY (link (need *FeldX)))) ) + (do *Minen (legeMine)) ) + +(de go () + (use (K X Y) + (anzeigen) + (xtUp (+ 2 *FeldY)) + (xtRight 4) + (one X Y) + (catch NIL + (until (= "^[" (setq K (key))) + (case K + ("j" + (unless (= Y *FeldY) + (xtDown 1) + (inc 'Y) ) ) + ("k" + (unless (= Y 1) + (xtUp 1) + (dec 'Y) ) ) + ("l" + (unless (= X *FeldX) + (xtRight 2) + (inc 'X) ) ) + ("h" + (unless (= X 1) + (xtLeft 2) + (dec 'X) ) ) + ((" " "^J" "^M") + (xtLeft (+ 2 (* 2 X))) + (xtUp (dec Y)) + (when (=T (get *Feld Y X)) + (anzeigen T) + (prinl "*** BUMM ***") + (throw) ) + (let *Visit NIL + (wertFeld X Y) ) + (anzeigen) + (unless (find '((L) (memq NIL L)) *Feld) + (prinl ">>> Gewonnen! <<<") + (throw) ) + (xtUp (- *FeldY Y -3)) + (xtRight (+ 2 (* 2 X))) ) ) ) + (xtLeft (+ 2 (* 2 X))) + (xtDown (+ 3 (- *FeldY Y))) ) ) ) diff --git a/games/nim.l b/games/nim.l @@ -0,0 +1,27 @@ +# 31jan08abu +# (c) Software Lab. Alexander Burger + +(load "lib/simul.l") + +# Nim +(de nim Pos + (game T NIL + '((Flg) # Moves + (make + (for (I . N) Pos + (do N + (link + (cons (cons I N) I (- N)) ) + (dec 'N) ) ) ) ) + '((Mov) # Move + (dec (nth Pos (car Mov)) (cdr Mov)) ) + '((Flg) # Cost + (let N (apply + Pos) + (if (=0 N) -100 N) ) ) ) ) + +### Test ### +(test + '(-100 ((1 . 4) 1 . -4) ((2 . 4) 2 . -4) ((3 . 4) 3 . -4)) + (nim 4 4 4) ) + +# vi:et:ts=3:sw=3 diff --git a/games/sudoku.l b/games/sudoku.l @@ -0,0 +1,73 @@ +# 21jan07abu +# (c) Software Lab. Alexander Burger + +(load "lib/simul.l") + +### Fields/Board ### +# val lst + +(setq + *Board (grid 9 9) + *Fields (apply append *Board) ) + +# Init values to zero (empty) +(for L *Board + (for This L + (=: val 0) ) ) + +# Build lookup lists +(for (X . L) *Board + (for (Y . This) L + (=: lst + (make + (let A (* 3 (/ (dec X) 3)) + (do 3 + (inc 'A) + (let B (* 3 (/ (dec Y) 3)) + (do 3 + (inc 'B) + (unless (and (= A X) (= B Y)) + (link + (prop (get *Board A B) 'val) ) ) ) ) ) ) + (for Dir '(`west `east `south `north) + (for (This (Dir This) This (Dir This)) + (unless (memq (:: val) (made)) + (link (:: val)) ) ) ) ) ) ) ) + +# Cut connections (for display only) +(for (X . L) *Board + (for (Y . This) L + (when (member X (3 6)) + (con (car (val This))) ) + (when (member Y (4 7)) + (set (cdr (val This))) ) ) ) + +# Display board +(de display () + (disp *Board 0 + '((This) + (if (=0 (: val)) + " " + (pack " " (: val) " ") ) ) ) ) + +# Initialize board +(de main (Lst) + (for (Y . L) Lst + (for (X . N) L + (put *Board X (- 10 Y) 'val N) ) ) + (display) ) + +# Find solution +(de go () + (unless + (recur (*Fields) + (with (car *Fields) + (if (=0 (: val)) + (loop + (NIL + (or + (assoc (inc (:: val)) (: lst)) + (recurse (cdr *Fields)) ) ) + (T (= 9 (: val)) (=: val 0)) ) + (recurse (cdr *Fields)) ) ) ) + (display) ) ) diff --git a/games/ttt.l b/games/ttt.l @@ -0,0 +1,72 @@ +# 15may07abu +# (c) Software Lab. Alexander Burger + +# *Board + +(load "lib/simul.l") + +(de display () + (for Y (3 2 1) + (prinl " +---+---+---+") + (prin " " Y) + (for X (1 2 3) + (prin " | " (or (get *Board X Y) " ")) ) + (prinl " |") ) + (prinl " +---+---+---+") + (prinl " a b c") ) + +(de find3 (P) + (find + '((X Y DX DY) + (do 3 + (NIL (= P (get *Board X Y))) + (inc 'X DX) + (inc 'Y DY) + T ) ) + (1 1 1 1 2 3 1 1) + (1 2 3 1 1 1 1 3) + (1 1 1 0 0 0 1 1) + (0 0 0 1 1 1 1 -1) ) ) + +(de myMove () + (when + (game NIL 8 + '((Flg) # Moves + (unless (find3 (or (not Flg) 0)) + (make + (for (X . L) *Board + (for (Y . P) L + (unless P + (link + (cons + (cons X Y (or Flg 0)) + (list X Y) ) ) ) ) ) ) ) ) + '((Mov) # Move + (set (nth *Board (car Mov) (cadr Mov)) (cddr Mov)) ) + '((Flg) # Cost + (if (find3 (or Flg 0)) -100 0) ) ) + (let Mov (caadr @) + (set (nth *Board (car Mov) (cadr Mov)) 0) ) + (display) ) ) + +(de yourMove (X Y) + (and + (sym? X) + (>= 3 (setq X (- (char X) 96)) 1) + (num? Y) + (>= 3 Y 1) + (not (get *Board X Y)) + (set (nth *Board X Y) T) + (display) ) ) + +(de main () + (setq *Board (make (do 3 (link (need 3))))) + (display) ) + +(de go Args + (cond + ((not (yourMove (car Args) (cadr Args))) + "Illegal move!" ) + ((find3 T) "Congratulation, you won!") + ((not (myMove)) "No moves") + ((find3 0) "Sorry, you lost!") ) ) diff --git a/games/xchess b/games/xchess @@ -0,0 +1,49 @@ +#!/usr/bin/picolisp /usr/lib/picolisp/lib.l +# 12nov09abu +# (c) Software Lab. Alexander Burger + +(load "@games/chess.l") + +(de reply @ + (prinl (glue " " (rest))) + (flush) ) + +(de xmove () + (when (myMove) + (let L (car *Undo) + (reply "move" + (pack + (cdr (assoc (caar L) (cdr L))) + (pick cdr (cdar L)) ) ) ) ) ) + +(in NIL + (loop + (case (read) + (protover + (read) + (reply "feature" "myname=\"PicoLisp Chess\"") + (reply "feature" "time=0" "sigint=0" "usermove=1") + (reply "feature" "done=1") ) + (accepted (read)) + (new + (seed (in "/dev/urandom" (rd 3))) + (setup (format (sys "XCHESS_DEPTH"))) ) + (level (line T)) + (sd (setup (read))) + (black (off *Me) (on *You)) + (white (on *Me) (off *You)) + (usermove + (let (L (line) From (pack (head 2 L)) To (pack (head 2 (cddr L))) F (get L 5)) + (if (and (yourMove (intern From) (intern To)) (or (not F) (= "q" F))) + (xmove) + (reply "Illegal move:" (pack L)) ) ) ) + (go (xchg '*Me '*You) (xmove)) + (undo (undo)) + (remove (undo) (undo)) + (result (line T)) + (random) + (hard) + (quit (bye)) + (T (reply "Error (unknown command):" @)) ) ) ) + +# vi:et:ts=3:sw=3 diff --git a/img/7fach.eps b/img/7fach.eps @@ -0,0 +1,474 @@ +%!PS-Adobe-3.0 EPSF-3.0 +%%For: Josef Bartl +%%CreationDate: Tue Feb 18 11:34:19 2003 +%%Title: 7fach.eps +%%Creator: Sketch 0.6.7 +%%Pages: 1 +%%BoundingBox: 35 63 232 148 +%%Extensions: CMYK +%%DocumentSuppliedResources: (atend) +%%DocumentNeededResources: font NewCenturySchlbk-Italic +%%EndComments + +%%BeginProlog +%%BeginResource: procset Linux-Sketch-Procset 1.0 2 +/SketchDict 100 dict def +SketchDict begin +/bd { bind def } bind def +/x { exch } bd +/xd { exch def } bd +/PI 3.14159265358979323846264338327 def +/radgrad { 180 mul PI div } bd +/skstartmatrix matrix currentmatrix def +/tmpmat matrix def +/ISOLatin1Encoding dup where +{ pop pop } +{ [/.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef +/.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef +/.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef +/.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef +/.notdef /space /exclam /quotedbl /numbersign /dollar /percent /ampersand +/quoteright /parenleft /parenright /asterisk /plus /comma /minus /period +/slash /zero /one /two /three /four /five /six /seven /eight /nine /colon +/semicolon /less /equal /greater /question /at /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 /bracketleft /backslash +/bracketright /asciicircum /underscore /quoteleft /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 /braceleft /bar /braceright +/asciitilde /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef +/.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef +/.notdef /.notdef /dotlessi /grave /acute /circumflex /tilde /macron /breve +/dotaccent /dieresis /.notdef /ring /cedilla /.notdef /hungarumlaut /ogonek +/caron /space /exclamdown /cent /sterling /currency /yen /brokenbar /section +/dieresis /copyright /ordfeminine /guillemotleft /logicalnot /hyphen +/registered /macron /degree /plusminus /twosuperior /threesuperior /acute /mu +/paragraph /periodcentered /cedilla /onesuperior /ordmasculine /guillemotright +/onequarter /onehalf /threequarters /questiondown /Agrave /Aacute /Acircumflex +/Atilde /Adieresis /Aring /AE /Ccedilla /Egrave /Eacute /Ecircumflex +/Edieresis /Igrave /Iacute /Icircumflex /Idieresis /Eth /Ntilde /Ograve +/Oacute /Ocircumflex /Otilde /Odieresis /multiply /Oslash /Ugrave /Uacute +/Ucircumflex /Udieresis /Yacute /Thorn /germandbls /agrave /aacute +/acircumflex /atilde /adieresis /aring /ae /ccedilla /egrave /eacute +/ecircumflex /edieresis /igrave /iacute /icircumflex /idieresis /eth /ntilde +/ograve /oacute /ocircumflex /otilde /odieresis /divide /oslash /ugrave +/uacute /ucircumflex /udieresis /yacute /thorn /ydieresis] def +} +ifelse +/arct dup where +{pop pop} +{ +/arct {arcto pop pop pop pop} bd +} +ifelse +/size 0 def +/fontname 0 def +/newfont 0 def +/sf { +/size xd +/fontname xd +fontname findfont +dup /Encoding get StandardEncoding eq +{ +dup +length dict /newfont xd +{ +1 index +/FID ne +{ newfont 3 1 roll put } +{ pop pop } +ifelse +} forall +newfont /Encoding ISOLatin1Encoding put +fontname newfont definefont +} +if +size scalefont setfont +} bd +/pusht {matrix currentmatrix} bd +/popt {setmatrix} bd +/pushc {gsave} bd +/popc {grestore} bd +/rgb {setrgbcolor} bd +/w { setlinewidth } bd +/j { setlinejoin } bd +/J { setlinecap } bd +/d { setdash } bd +/F { eofill } bd +/f { closepath F } bd +/S { +pusht +skstartmatrix setmatrix stroke +popt +} bd +/s { closepath S } bd +/m { moveto } bd +/l { lineto } bd +/c { curveto } bd +/txt { +/tmpmat tmpmat currentmatrix def +dup type /arraytype eq {concat} {translate} ifelse +0 0 m +tmpmat +} bd +/T {txt x show popt} bd +/P {txt x true charpath popt} bd +/TP {txt x dup show 0 0 m true charpath popt} bd +/C {newpath 0 360 arc} bd +/R { +2 copy m +x 2 index l +x 2 index x l +l +closepath +} bd +/ellipse { +dup type /arraytype eq +{ +pusht x concat +0 0 1.0 C +popt +} +{ +pusht 5 1 roll +4 -1 roll concat +newpath +dup 2 eq { +0 0 m +} if +3 1 roll +radgrad x +radgrad x +0 0 1 5 -2 roll +arc +0 ne { closepath } if +popt +} +ifelse +} bd +/radius1 0 def +/radius2 0 def +/factor 0 def +/rect { +dup type /arraytype eq +{ +pusht x concat +0 0 m 1 0 l 1 1 l 0 1 l closepath +popt +} +{ +/radius2 xd +/radius1 xd +pusht x concat +radius1 radius2 div 1 scale +0 radius2 m +0 1 radius2 1 radius2 arct +radius2 radius1 div +dup 1 1 index 0 radius2 arct +0 0 0 radius2 arct +0 0 0 1 radius2 arct +closepath +popt +} +ifelse +} bd +/buf 0 def +/width 0 def +/height 0 def +/skcimg { +/tmpmat tmpmat currentmatrix def +{ concat } if +/height xd +/width xd +/buf width 3 mul string def +width height scale +width height 8 +[width 0 0 height neg 0 height] +{ currentfile buf readhexstring pop } bind +false 3 colorimage +tmpmat setmatrix +} bd +/skgimg { +/tmpmat tmpmat currentmatrix def +{ concat } if +/height xd +/width xd +/buf width string def +width height scale +width height 8 +[width 0 0 height neg 0 height] +{ currentfile buf readhexstring pop } bind +image +tmpmat setmatrix +} bd +/rclip { +4 2 roll m +dup 0 x rlineto +x 0 rlineto +neg 0 x rlineto +closepath +clip +} bd +/skeps { +10 dict begin +/sk_state save def +concat +3 index neg 3 index neg translate +rclip +0 setgray 0 setlinecap 1 setlinewidth 0 setlinejoin +10 setmiterlimit [ ] 0 setdash +newpath +/sk_dict_count countdictstack def +/sk_count count 1 sub def +userdict begin +/showpage { } def +/languagelevel where +{ +pop +languagelevel 1 ne +{ +false setstrokeadjust +false setoverprint +} if +} if +} bd +/skepsend { +count sk_count sub { pop } repeat +countdictstack sk_dict_count sub { end } repeat +sk_state restore +end +} bd +/gradidx 0 def +/gradient { +3 mul array +/gradidx 0 def +} bd +/$ { +3 index gradidx 5 -1 roll put +2 index gradidx 1 add 4 -1 roll put +1 index gradidx 2 add 3 -1 roll put +/gradidx gradidx 3 add def +} bd +/! { +3 +{ +dup dup gradidx dup 3 1 roll 3 sub get put +/gradidx gradidx 1 add def +} +repeat +} bd +/gradcolor { +3 mul dup 2 add 1 exch % idx 1 idx+2 +{ +1 index exch % array array i +get % array component +exch % component array +} +for +4 1 roll +} bd +/x0 0 def /y0 0 def /x1 0 def /y1 0 def +/left 0 def /right 0 def /top 0 def /bottom 0 def +/numcolors 0 def +/axial { +/y1 xd /x1 xd /y0 xd /x0 xd +dup length 3 idiv /numcolors xd +pusht exch % ctm array +x0 x1 ne y0 y1 ne or +{ +x0 y0 translate +[x1 x0 sub y1 y0 sub dup neg 2 index 0 0] concat +clippath flattenpath pathbbox +/top xd /right xd /bottom xd /left xd +newpath +0 gradcolor rgb clippath f +0 1 numcolors 1 sub +{ +dup numcolors div +3 1 roll +gradcolor rgb +exch +bottom right top R f +} +for +} +if +pop +popt +} bd +/r0 0 def /r1 0 def /dr 0 def +/radial { +/r1 xd /r0 xd /y0 xd /x0 xd +/dr r1 r0 sub def +dup length 3 idiv /numcolors xd +pusht exch % ctm array +r0 r1 ne +{ +x0 y0 translate +clippath flattenpath pathbbox +/top xd /right xd /bottom xd /left xd +newpath +dr 0 gt {numcolors 1 sub}{0} ifelse gradcolor rgb +clippath f +dr 0 gt {numcolors 1 sub -1 0} { 0 1 numcolors 1 sub} ifelse +{ +dup numcolors div dr mul r0 add +3 1 roll +gradcolor rgb +exch +0 0 3 -1 roll C f +} +for +} +if +pop +popt +} bd +/max { +2 copy lt {exch} if pop +} bd +/conical { +pusht 5 1 roll +3 1 roll /y0 xd /x0 xd +x0 y0 translate +radgrad rotate +dup length 3 idiv /numcolors xd +clippath flattenpath pathbbox newpath +4 { abs 4 1 roll} repeat +3 { max } repeat +2 mul +dup scale +0 gradcolor rgb +0 0 1 0 360 arc f +1 1 numcolors 1 sub +{ +dup numcolors div 180 mul +3 1 roll +gradcolor rgb +exch +0 0 moveto +0 0 1 4 -1 roll dup neg arc +closepath f +} +for +pop +popt +} bd +/XStep 0 def /YStep 0 def /imagedata 0 def /components 0 def +/tileimage2 { +exch 4 2 roll +/height xd +/width xd +mark +/components 2 index +/PatternType 1 +/PaintType 1 +/TilingType 1 +/BBox [0 0 width height] +/XStep width +/YStep height +/PaintProc { +begin +XStep YStep 8 +matrix +imagedata +false +components +colorimage +end +} +counttomark 2 div cvi dup dict begin +{ def } repeat +pop currentdict end +dup +/imagedata +4 -1 roll +width height mul mul string +currentfile exch readhexstring pop +put +exch +makepattern +setpattern +clippath +eofill +} bd +/tileimage1 { +concat +/components xd +/height xd +/width xd +/imagedata +currentfile +width height mul components mul string +readhexstring pop +def +clippath flattenpath pathbbox +/top xd /right xd /bottom xd /left xd +left width div floor width mul +bottom height div floor height mul +translate +top bottom sub height div ceiling cvi +{ +gsave +right left sub width div ceiling cvi +{ +width height 8 matrix +components 1 eq +{ +{ imagedata } +image +} +{ +imagedata +false components +colorimage +} +ifelse +width 0 translate +} +repeat +grestore +0 height translate +} +repeat +} bd +/makepattern where +{ +pop +/tileimage /tileimage2 load def +} +{ +/tileimage /tileimage1 load def +} +ifelse +end +%%EndResource +%%EndProlog + +%%BeginSetup +%%IncludeResource: font NewCenturySchlbk-Italic + +10.433 setmiterlimit +%%EndSetup + +%%Page: 1 1 +SketchDict begin +/NewCenturySchlbk-Italic 72 sf +(7) +[1 0.0774195 0 1 38.5322 74.5729] 0 0.475 0 rgb +T +(f) +[1 0.0774195 0 1 82.704 81.2248] 0.354 0.335 0.676 rgb +T +(a) +[1 0.0774195 0 1 111.793 83.4768] 0.667 0 0 rgb +T +(c) +[1 0.0774195 0 1 154.887 86.8132] 0.747 0.609 0.241 rgb +T +(h) +[1 0.0774195 0 1 189.363 89.4823] 0.001 0 0.67 rgb +T +%%PageTrailer +%%Trailer +end +%%DocumentSuppliedResources: procset Linux-Sketch-Procset 1.0 2 +%%EOF diff --git a/img/7fach.gif b/img/7fach.gif Binary files differ. diff --git a/img/go.png b/img/go.png Binary files differ. diff --git a/img/no.png b/img/no.png Binary files differ. diff --git a/lib.css b/lib.css @@ -0,0 +1,194 @@ +/* 20apr10abu + * (c) Software Lab. Alexander Burger + */ + +/* Lib */ +.left {float: left;} +.right {float: right;} +.clr {clear: both;} +.norm {text-align: left;} +.align {text-align: right;} +.center {text-align: center;} +.black {color: black;} +.red {color: red;} +.green {color: green;} +.blue {color: blue;} +.bold {font-weight: bold;} +.mono {font-family: monospace;} + +/* Defaults */ +body { + font-family: Arial, Helvetica, sans-serif; + background-color: #F0F0F0; + font-size: small; + margin: 0; +} + +img { + border: 0; +} + +fieldset { + border-style: none; +} + +input, textarea, select { + font-size: small; + background-color: white; +} + +caption { + padding: 0 1em; + text-align: left; + margin-top: 2ex; + background-color: #D0D0D0; +} + +a { + text-decoration: none; +} + +.step a { + background-color: #D0D0D0; + padding: 2px; +} + +a:hover { + background-color: white; +} + +/* Navigation */ +#menu { + position: absolute; + top: 0; + left: 0; + width: 18em; + height: 100%; + padding: 1ex 0; + background-color: #D0D0D0; +} + +#menu ul { + list-style: none; + padding: 0; + margin: 0; +} + +#menu .cmd1, .act1, .cmd2, .act2, .cmd3, .act3, .cmd4, .act4 { + list-style-position: inside; + list-style-type: circle; + padding: 0 0 0 2em; +} + +#menu .act1, .act2, .act3, .act4 { + list-style-type: disc; +} + +#menu .sub1, .top1, .sub2, .top2, .sub3, .top3, .sub4, .top4 { + list-style-position: inside; + padding: 0 0 0 1em; +} + +#expires { + position: absolute; + top: 0; + right: 3px; + color: red; +} + +/* Tabulators */ +.tab { + margin-bottom: 1ex; +} + +.tab td { + padding: 1ex 1em; +} + +.tab .top { + font-weight: bold; + border-top: 1px solid; + border-left: 1px solid; + border-right: 1px solid; +} + +.tab .sub { + background-color: #D0D0D0; + border-bottom: 1px solid; +} + +/* Main area */ +#main { + position: absolute; + top: 0; + left: 19em; + padding: 1ex 0; +} + +/* Charts */ +.chart { + width: 100%; + white-space: nowrap; +} + +.chart td { + background-color: #E0E0E0; +} + +.chart td.T { + background-color: #D0D0D0; +} + +.chart td.nil { + background-color: white; +} + +.btn { + width: 1em; +} + +/* Buttons */ +.submit { + font-weight: bold; + background-color: #D0D0D0; +} + +.edit { + background-color: #66FF66; +} + +/* Errors */ +.err { + color: red; + background-color: yellow; +} + +/* Fonts */ +.tiny { + font-size: smaller; + padding: 0; +} + +.note, .ask { + font-weight: bold; +} + +/* Alerts */ +.alert { + display: inline; + padding: 1ex; + margin: 1ex 0 1ex 5em; + background-color: yellow; + border: dashed thin; +} + +.alert input { + margin-top: 1ex; +} + +/* Dialogs */ +.dialog { + padding: 1ex; + margin: 1ex 5em 1ex 1em; + border: dashed thin; +} diff --git a/lib.l b/lib.l @@ -0,0 +1,369 @@ +# 18mar10abu +# (c) Software Lab. Alexander Burger + +(de task (Key . Prg) + (nond + (Prg (del (assoc Key *Run) '*Run)) + ((num? Key) (quit "Bad Key" Key)) + ((assoc Key *Run) + (push '*Run + (conc + (make + (when (lt0 (link Key)) + (link (+ (eval (pop 'Prg) 1))) ) ) + (ifn (sym? (car Prg)) + Prg + (cons + (cons 'job + (cons + (lit + (make + (while (atom (car Prg)) + (link + (cons (pop 'Prg) (eval (pop 'Prg) 1)) ) ) ) ) + Prg ) ) ) ) ) ) ) + (NIL (quit "Key conflict" Key)) ) ) + +(de forked () + (let N (caar *Run) + (when (gt0 N) + (push '*Fork (list 'close N)) ) + (push '*Fork (list 'task N)) ) ) + +(de timeout (N) + (if2 N (assoc -1 *Run) + (set (cdr @) (+ N)) + (push '*Run (list -1 (+ N) '(bye))) + (del @ '*Run) ) ) + +(de abort ("N" . "Prg") + (catch 'abort + (alarm "N" (throw 'abort)) + (finally (alarm 0) (run "Prg")) ) ) + +(de macro "Prg" + (run (fill "Prg")) ) + +(de later ("@Var" . "@Prg") + (macro + (task (pipe (pr (prog . "@Prg"))) + (setq "@Var" (in @ (rd))) + (close @) + (task @) ) ) + "@Var" ) + +(de recur recurse + (run (cdr recurse)) ) + +(de curry "Z" + (let ("X" (pop '"Z") "Y" (pop '"Z") "P" (filter pat? "X")) + (if2 "P" (diff "X" "P") + (list "Y" (cons 'job (lit (env @)) (fill "Z" "P"))) + (cons "Y" (fill "Z" "P")) + (list "Y" (cons 'job (lit (env @)) "Z")) + (cons "Y" "Z") ) ) ) + +(====) + +(de expr ("F") + (set "F" + (list '@ (list 'pass (box (getd "F")))) ) ) + +(de subr ("F") + (set "F" + (getd (cadr (cadr (getd "F")))) ) ) + +(de undef ("X" "C") + (when (pair "X") + (setq "C" (cdr "X") "X" (car "X")) ) + (ifn "C" + (prog1 (val "X") (set "X")) + (prog1 + (cdr (asoq "X" (val "C"))) + (set "C" + (delq (asoq "X" (val "C")) (val "C")) ) ) ) ) + +(de redef "Lst" + (let ("Old" (car "Lst") "New" (name "Old")) + (set + "New" (getd "Old") + "Old" "New" + "Old" (fill (cdr "Lst") "Old") ) + "New" ) ) + +(de daemon ("X" . Prg) + (prog1 + (nond + ((pair "X") + (or (pair (getd "X")) (expr "X")) ) + ((pair (cdr "X")) + (method (car "X") (cdr "X")) ) + (NIL + (method (car "X") (get (or (cddr "X") *Class) (cadr "X"))) ) ) + (con @ (append Prg (cdr @))) ) ) + +(de patch ("Lst" "Pat" . "Prg") + (bind (fish pat? "Pat") + (recur ("Lst") + (loop + (cond + ((match "Pat" (car "Lst")) + (set "Lst" (run "Prg")) ) + ((pair (car "Lst")) + (recurse @) ) ) + (NIL (cdr "Lst")) + (T (atom (cdr "Lst")) + (when (match "Pat" (cdr "Lst")) + (con "Lst" (run "Prg")) ) ) + (setq "Lst" (cdr "Lst")) ) ) ) ) + +(====) + +(de cache ("Var" "Str" . Prg) + (nond + ((setq "Var" (car (idx "Var" "Str" T))) + (set "Str" "Str" "Str" (run Prg 1)) ) + ((n== "Var" (val "Var")) + (set "Var" (run Prg 1)) ) + (NIL (val "Var")) ) ) + +(====) + +(de scl (N) + (setq *Scl N) ) + +### I/O ### +(de tab (Lst . @) + (for N Lst + (let V (next) + (and (gt0 N) (space (- N (length V)))) + (prin V) + (and (lt0 N) (args) (space (- 0 N (length V)))) ) ) + (prinl) ) + +(de beep () + (prin "^G") ) + +(de msg (X . @) + (out 2 + (print X) + (pass prinl) + (flush) ) + X ) + +(de script (File . @) + (load File) ) + +(de once Prg + (unless (idx '*Once (file) T) + (run Prg 1) ) ) + +(de rc (File Key . @) + (ctl File + (let Lst (in File (read)) + (ifn (args) + (cdr (assoc Key Lst)) + (let Val (next) + (if (assoc Key Lst) + (con @ Val) + (push 'Lst (cons Key Val)) ) + (protect + (out File (println Lst)) ) + Val ) ) ) ) ) + +(de acquire (File) + (ctl File + (let P (in File (rd)) + (or + (= P *Pid) + (unless (and P (kill P 0)) + (out File (pr *Pid)) ) ) ) ) ) + +(de release (File) + (ctl File (out File)) ) + +### List ### +(de insert (N Lst X) + (conc + (cut (dec N) 'Lst) + (cons X) + Lst ) ) + +(de remove (N Lst) + (conc + (cut (dec N) 'Lst) + (cdr Lst) ) ) + +(de place (N Lst X) + (conc + (cut (dec N) 'Lst) + (cons X) + (cdr Lst) ) ) + +(de uniq (Lst) + (let R NIL + (filter + '((X) (not (idx 'R X T))) + Lst ) ) ) + +(de group (Lst) + (make + (while Lst + (if (assoc (caar Lst) (made)) + (conc @ (cons (cdr (pop 'Lst)))) + (link + (cons (caar Lst) (cons (cdr (pop 'Lst)))) ) ) ) ) ) + +### Symbol ### +(de qsym "Sym" + (cons (val "Sym") (getl "Sym")) ) + +(de loc (S X) + (if (and (str? X) (= S X)) + X + (and + (pair X) + (or + (loc S (car X)) + (loc S (cdr X)) ) ) ) ) + +### OOP ### +(de class Lst + (let L (val (setq *Class (car Lst))) + (def *Class + (recur (L) + (if (atom (car L)) + (cdr Lst) + (cons (car L) (recurse (cdr L))) ) ) ) ) ) + +(de object ("Sym" "Val" . @) + (def "Sym" "Val") + (putl "Sym") + (while (args) + (put "Sym" (next) (next)) ) + "Sym" ) + +(de extend X + (setq *Class (car X)) ) + +# Class variables +(de var X + (put *Class (car X) (cdr X)) ) + +(de var: X + (apply meta X This) ) + +### Pretty Printing ### +(de "*PP" + T NIL if if2 ifn when unless while until do case state for + with catch finally ! setq default push job use let let? + prog1 later recur redef =: in out ctl tab new ) +(de "*PP1" if2 let let? for redef) +(de "*PP2" setq default) + +(de pretty (X N . @) + (setq N (abs (space (or N 0)))) + (while (args) + (printsp (next)) ) + (if (or (atom X) (>= 12 (size X))) + (print X) + (while (== 'quote (car X)) + (prin "'") + (pop 'X) ) + (let Z X + (prin "(") + (when (memq (print (pop 'X)) "*PP") + (cond + ((memq (car Z) "*PP1") + (if (and (pair (car X)) (pair (cdar X))) + (when (>= 12 (size (car X))) + (space) + (print (pop 'X)) ) + (space) + (print (pop 'X)) + (when (or (atom (car X)) (>= 12 (size (car X)))) + (space) + (print (pop 'X)) ) ) ) + ((memq (car Z) "*PP2") + (inc 'N 3) + (loop + (prinl) + (pretty (cadr X) N (car X)) + (NIL (setq X (cddr X)) (space)) ) ) + ((or (atom (car X)) (>= 12 (size (car X)))) + (space) + (print (pop 'X)) ) ) ) + (when X + (loop + (T (== Z X) (prin " .")) + (T (atom X) (prin " . ") (print X)) + (prinl) + (pretty (pop 'X) (+ 3 N)) + (NIL X) ) + (space) ) + (prin ")") ) ) ) + +(de pp ("X" C) + (let *Dbg NIL + (when (pair "X") + (setq C (cdr "X")) ) + (prin "(") + (printsp (if C 'dm 'de)) + (prog1 + (printsp "X") + (setq "X" + (if C + (method (if (pair "X") (car "X") "X") C) + (val "X") ) ) + (cond + ((atom "X") + (prin ". ") + (print "X") ) + ((atom (cdr "X")) + (ifn (cdr "X") + (print (car "X")) + (print (car "X")) + (prin " . ") + (print @) ) ) + (T (print (pop '"X")) + (while (pair "X") + (prinl) + (pretty (pop '"X") 3) ) + (when "X" + (prin " . ") + (print "X") ) + (space) ) ) + (prinl ")") ) ) ) + +(de show ("X" . @) + (let *Dbg NIL + (setq "X" (apply get (rest) "X")) + (when (sym? "X") + (print "X" (val "X")) + (prinl) + (maps + '((X) + (space 3) + (if (atom X) + (println X) + (println (cdr X) (car X)) ) ) + "X" ) ) + "X" ) ) + +(de view (X L) + (let (Z X *Dbg) + (loop + (T (atom X) (println X)) + (if (atom (car X)) + (println '+-- (pop 'X)) + (print '+---) + (view + (pop 'X) + (append L (cons (if X "| " " "))) ) ) + (NIL X) + (mapc prin L) + (T (== Z X) (println '*)) + (println '|) + (mapc prin L) ) ) ) + +# vi:et:ts=3:sw=3 diff --git a/lib/adm.l b/lib/adm.l @@ -0,0 +1,71 @@ +# 26mar10abu +# (c) Software Lab. Alexander Burger + +# *Login *Users *Perms + +### Login ### +(de login (Nm Pw) + (ifn (setq *Login (db 'nm '+User Nm 'pw Pw)) + (msg *Pid " ? " Nm) + (msg *Pid " * " (stamp) " " Nm) + (tell 'hi *Pid Nm *Adr) + (push1 '*Bye '(logout)) + (push1 '*Fork '(del '(logout) '*Bye)) + (timeout (setq *Timeout `(* 3600 1000))) ) + *Login ) + +(de logout () + (when *Login + (rollback) + (off *Login) + (tell 'hi *Pid) + (msg *Pid " / " (stamp)) + (timeout (setq *Timeout `(* 300 1000))) ) ) + +(de hi (Pid Nm Adr) + (if (and (= Nm (get *Login 'nm)) (= Adr *Adr)) + (bye) + (hi2 Pid Nm) + (tell 'hi2 *Pid (get *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 + + +### User ### +(class +User +Entity) + +(rel nm (+Need +Key +String)) # User name +(rel pw (+String)) # Password +(rel role (+Joint) usr (+Role)) # User role + + +### Permission management ### +(de permission Lst + (while Lst + (queue '*Perms (car Lst)) + (def (pop 'Lst) (pop 'Lst)) ) ) + +(de may Args + (mmeq Args (get *Login 'role 'perm)) ) + +(de must Args + (unless + (if (cdr Args) + (mmeq @ (get *Login 'role 'perm)) + *Login ) + (msg *Pid " No permission: " (car Args)) + (forbidden) ) ) + +# vi:et:ts=3:sw=3 diff --git a/lib/app.l b/lib/app.l @@ -0,0 +1,34 @@ +# 06apr10abu +# (c) Software Lab. Alexander Burger + +# Exit on error +(de *Err + (prinl *Pid " ! " (stamp) " [" *Adr " " (host *Adr) "] " *Agent) + (show This) + (for "X" '(*Gate *Agent *Host *Port *PRG *Url *SesId *ConId *Tab *Gui *Btn *Get *ID) + (println "X" (val "X")) ) + (and (get *Top 'focus) (println 'focus (get @ 'ix))) + (for "X" (env) + (unless (== (car "X") (cdr "X")) + (println (car "X") (cdr "X")) ) ) + (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) "] " *Agent)) ) + +# Bye message +(push1 '*Bye '(and *SesId (msg *Pid " - " (stamp)))) diff --git a/lib/boss.l b/lib/boss.l @@ -0,0 +1,16 @@ +# 26feb09abu +# (c) Software Lab. Alexander Burger + +# "tmp+" "tmp-" + +(unless (info (tmp "+")) + (call 'mkfifo (setq "tmp+" (tmp "+"))) + (call 'mkfifo (setq "tmp-" (tmp "-"))) ) +(hear (open "tmp+")) + +# (boss 'sym ['any ..]) +(de boss @ + (out "tmp+" (pr (rest))) ) + +(de reply Exe #-> any + (out "tmp-" (pr (eval Exe))) ) diff --git a/lib/btree.l b/lib/btree.l @@ -0,0 +1,438 @@ +# 08oct09abu +# (c) Software Lab. Alexander Burger + +# *Prune + +(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 + (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)) ) + (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)) ) ) + (inc Root) ) ) ) + +(de _put (Top) + (let (V (val Top) R (rank Key (cdr V))) + (if (and R (= Key (car R))) + (nil (touch Top) (con (cdr R) Val)) + (cond + (R + (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) + (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) + (call 'rm 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) ) ) + +# 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) + (catch NIL + (loop + (until (cdar Q) + (or (cdr Q) (throw)) + (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))) + (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))) + (wipe V) ) + (unless (and Flg (flg? (fin (car X)))) + (throw NIL + (or (cddr X) (fin (car X))) ) ) ) ) ) ) ) + +(====) + +# Scan tree nodes +(de scan ("Tree" "Fun" "Beg" "End" "Flg") + (default "Fun" println) + (or "Beg" "End" (on "End")) + ((if (>= "End" "Beg") _scan _nacs) + (cdr (root "Tree")) ) ) + +(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")) ) + (wipe "Node") ) ) + +(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")) ) + (wipe "Node") ) ) + +(====) + +# Iterate tree values +(de iter ("Tree" "Fun" "Beg" "End" "Flg") + (default "Fun" println) + (or "Beg" "End" (on "End")) + ((if (>= "End" "Beg") _iter _reti) + (cdr (root "Tree")) ) ) + +(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")) ) + (wipe "Node") ) ) + +(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")) ) + (wipe "Node") ) ) + +(====) + +(de prune (Done) + (for Node (idx '*Prune) + (recur (Node) + (let? V (val (lieu Node)) + (if (nor (car V) (find cadr (cdr V))) + (wipe Node) + (recurse (car V)) + (for X (cdr V) + (recurse (cadr X)) + (wipe (lieu (cddr X))) ) ) ) ) ) + (setq *Prune (not Done)) ) + +# Delete Tree +(de zapTree (Node) + (let? V (val Node) + (zapTree (car V)) + (for L (cdr V) + (zapTree (cadr L)) ) + (zap Node) ) ) + +# 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" ) ) + +# vi:et:ts=3:sw=3 diff --git a/lib/cal.l b/lib/cal.l @@ -0,0 +1,79 @@ +# 17sep02abu +# (c) Software Lab. Alexander Burger + +# Easter date +(de easter (Year) + (unless (<= 1900 Year 2099) + (quit "Illegal Year" Year) ) + (let + (A (% Year 19) + B (% Year 4) + C (% Year 7) + D (% (+ 24 (* 19 A)) 30) + E (% (+ 5 (* 2 B) (* 4 C) (* 6 D)) 7) + Day (+ 22 D E) + Mon 3 ) + (and (> Day 31) (setq Day (+ D E -9) Mon 4)) + (and (= Day 26) (= Mon 4) (setq Day 19)) + (and (= Day 25) (= Mon 4) (= D 28) (= E 6) (> A 10) (setq Day 18)) + (date Year Mon Day) ) ) + +# Feiertage +(de feier (X Year) + (if (sym? X) + (case X + (Neujahr + (date Year 1 1) ) + ((Maifeiertag "1. Mai" "Tag der Arbeit") + (date Year 5 1) ) + (("Tag der deutschen Einheit" "Deutsche Einheit") + (date Year 10 3) ) + ((Weihnachten "1. Weihnachtstag") + (date Year 12 25) ) + ("2. Weihnachtstag" + (date Year 12 26) ) + (Rosenmontag + (- (easter Year) 48) ) + (Aschermittwoch + (- (easter Year) 46) ) + (Karfreitag + (- (easter Year) 2) ) + ((Ostern Ostersonntag) + (easter Year) ) + (Ostermontag + (+ (easter Year) 1) ) + ((Himmelfahrt "Christi Himmelfahrt") + (+ (easter Year) 39) ) + ((Pfingsten Pfingstsonntag) + (+ (easter Year) 49) ) + (Pfingstsmontag + (+ (easter Year) 50) ) + (Fronleichnam + (+ (easter Year) 60) ) ) + (let L (date X) + (cdr + (or + (assoc (cdr L) + (quote + ((1 1) . Neujahr) + ((5 1) . Maifeiertag) + ((10 3) . "Tag der deutschen Einheit") + ((12 25) . Weihnachten) + ((12 26) . "2. Weihnachtstag") ) ) + (assoc (- X (easter (car L))) + (quote + (-48 . Rosenmontag) + (-46 . Aschermittwoch) + (-2 . Karfreitag) + (0 . Ostern) + (1 . Ostermontag) + (39 . Himmelfahrt) + (49 . Pfingsten) + (50 . Pfingstsmontag) + (60 . Fronleichnam) ) ) ) ) ) ) ) + +# Werktag +(de werktag (Dat) + (nor + (member (% Dat 7) (4 5)) # Sa So + (feier Dat) ) ) diff --git a/lib/conDbgc.l b/lib/conDbgc.l @@ -0,0 +1,69 @@ +# 29jun07abu +# (c) Software Lab. Alexander Burger + +### Concurrent DB Garbage Collector ### +# *DbgcDly *DbgcPid + +(default *DbgcDly 64) + +(if (fork) + (setq *DbgcPid @) + + (wait 60000) + (undef 'upd) + (de upd Lst + (wipe Lst) + (let *DbgcDly (>> 1 *DbgcDly) + (for S Lst + (when (ext? S) + (mark S T) + (markData (val S)) + (maps markData S) ) + (wipe S) ) ) ) + + (de markExt (S) + (unless (mark S T) + (wait *DbgcDly) + (markData (val S)) + (maps markData S) + (wipe S) ) ) + + (de markData (X) + (while (pair X) + (markData (pop 'X)) ) + (and (ext? X) (markExt X)) ) + + (loop + (let MS (+ (/ (usec) 1000) 86400000) + (markExt *DB) + (while (> MS (/ (usec) 1000)) + (wait 60000) ) ) + (let Cnt 0 + (for (F . @) (or *Dbs (2)) + (for (S (seq F) S (seq S)) + (wait *DbgcDly) + (unless (mark S) + (sync) + (unless (mark S) + (and (isa '+Entity S) (zap> S)) + (zap S) + (commit) + (inc 'Cnt) ) ) ) ) + (when *Blob + (use (@S @R F S) + (let Pat (conc (chop *Blob) '(@S "." @R)) + (in (list 'find *Blob "-type" "f") + (while (setq F (line)) + (wait *DbgcDly) + (when (match Pat F) + (unless + (and + (setq S (extern (pack (replace @S '/)))) + (get S (intern (pack @R))) ) + (inc 'Cnt) + (call 'rm (pack F)) ) + (wipe S) ) ) ) ) ) ) + (msg Cnt " conDbgc") ) + (mark 0) ) ) + +# vi:et:ts=3:sw=3 diff --git a/lib/db.l b/lib/db.l @@ -0,0 +1,1125 @@ +# 08mar10abu +# (c) Software Lab. Alexander Burger + +# *Dbs *Jnl *Blob upd + +### DB Sizes ### +(de dbs Lst + (default *Dbs (_dbs 1)) ) + +(de dbs+ (N . Lst) + (unless (cdr (nth *Dbs N)) + (conc *Dbs (_dbs N)) ) ) + +(de _dbs (N) + (mapcar + '((L) + (let Dbf (cons N (>> (- (car L)) 64)) + (for Cls (cdr L) + (if (atom Cls) + (put Cls 'Dbf Dbf) + (for Var (cdr Cls) + (unless (get Cls 1 Var) + (quit "Bad relation" (cons Var (car Cls))) ) + (put (get (car Cls) Var) 'dbf Dbf) ) ) ) ) + (inc 'N) + (car L) ) + Lst ) ) + +(de db: Typ + (or (meta Typ 'Dbf 1) 1) ) + + +### Tree Access ### +(de tree (Var Cls Hook) + (cons Var + (if Hook + (cons Cls Hook) + Cls ) ) ) + +(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) + (for (L (rest) (and L (== (pop 'A) (pop 'L))) (cdr L)) + (conc Key (cons (car L))) ) ) + (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 (arg) (next))) ) ) ) + + +# (aux 'var 'cls ['hook] 'any ..) -> sym +(de aux (Var Cls . @) + (with (treeRel Var Cls) + (step + (init (tree (: var) (: cls) (and (: hook) (next))) + (rest) + (conc (rest) 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 + (if (isa '+Key This) + (iter Tree + '((X) (and (isa Cls X) (link (pass get X)))) + X1 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)) ) ) + (if (isa '+Idx This) + (iter Tree + '((X) + (and + (isa Cls X) + (not (memq (setq X (pass get X)) (made))) + (link X) ) ) + X1 X2 T ) + (iter Tree + '((X) + (and (isa Cls X) (link (pass get X))) ) + X1 X2 ) ) ) ) ) ) ) + + +(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 ) ) + + +### Relations ### +(class +relation) +# cls var + +(dm T (Var Lst) + (=: cls *Class) + (=: var Var) ) + +# Type check +(dm mis> (Val Obj)) #> lst +(dm ele> (Val)) + +# Value present? +(dm has> (Val X) #> any | NIL + (and (= Val X) 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 lose> (Obj Val)) + +(dm keep> (Obj Val)) + +# Finalizer +(dm zap> (Obj Val)) + + +(class +Any +relation) + + +# (+Bag) (cls ..) (..) (..) +(class +Bag +relation) +# bag + +(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) + (or + (ifn (lst? Val) "Not a Bag") + (pick + '((This V) + (mis> This V Obj + (get + (if (sym? (: hook)) Obj Val) + (: hook) ) ) ) + (: bag) + Val ) ) ) + +(dm ele> (Val) + (and Val + (or + (atom Val) + (find 'ele> (: bag) Val) ) ) ) + +(dm has> (Val X) + (and Val + (or + (super Val X) + (car (member 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 + (get + (if (sym? (: hook)) Obj Old) + (: hook) ) ) ) + (: bag) + Old ) ) + (when New + (mapc + '((This N) + (rel> This Obj NIL N + (get + (if (sym? (: hook)) Obj New) + (: hook) ) ) ) + (: bag) + New ) ) ) + +(dm lose> (Obj Val) + (mapc + '((This V) + (lose> This Obj V + (get + (if (sym? (: hook)) Obj Val) + (: hook) ) ) ) + (: bag) + Val ) ) + +(dm keep> (Obj Val) + (mapc + '((This V) + (keep> This Obj V + (get + (if (sym? (: hook)) Obj Val) + (: hook) ) ) ) + (: bag) + Val ) ) + + +(class +Bool +relation) + +(dm mis> (Val Obj) + (and Val (nT Val) ,"Boolean input expected") ) + + +# (+Number) [num] +(class +Number +relation) +# scl + +(dm T (Var Lst) + (=: scl (car Lst)) + (super Var (cdr Lst)) ) + +(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) [num] +(class +String +Symbol) +# len + +(dm T (Var Lst) + (=: len (car Lst)) + (super Var (cdr Lst)) ) + +(dm mis> (Val Obj) + (and Val (not (str? Val)) ,"String type expected") ) + + +# (+Link) typ +(class +Link +relation) +# type + +(dm T (Var Lst) + (unless (=: type (car Lst)) + (quit "No Link" Var) ) + (super Var (cdr Lst)) ) + +(de canQuery (Val) + (and + (pair Val) + (pair (car Val)) + (not + (find + '((L) + (not + (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 +(class +Joint +Link) +# slot + +(dm T (Var Lst) + (=: slot (car Lst)) + (super Var (cdr Lst)) ) + +(dm mis> (Val Obj) + (and + Val + (nor + (canQuery Val) + (and + (isa (: type) Val) + (with (meta Val (: slot)) + (or + (isa '+Joint This) + (find + '((B) (isa '+Joint B)) + (: bag) ) ) ) ) ) + ,"Type error" ) ) + +(dm rel> (Obj Old New) + (and Old (del> Old (: slot) Obj)) + (and New + (not (get Obj T)) + (put> New (: slot) Obj) ) ) + +(dm lose> (Obj Val) + (when Val + (put Val (: slot) + (del> (meta Val (: slot)) Obj (get Val (: slot)) Obj) ) ) ) + +(dm keep> (Obj Val) + (when Val + (put Val (: slot) + (put> (meta Val (: slot)) Obj (get Val (: slot)) 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) ) + + +# (+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 (call 'rm "-f" (blob Obj (: var)))) ) + + +### Index classes ### +(class +index) +# hook dbf + +(dm T (Var Lst) + (=: hook (car Lst)) + (extra Var (cdr Lst)) ) + + +# (+Key) 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 (get Obj (: hook)))) + Val ) + ,"Not unique" ) ) ) + +(dm rel> (Obj Old New Hook) + (let Tree (tree (: var) (: cls) (or Hook (get Obj (: hook)))) + (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 lose> (Obj Val Hook) + (store + (tree (: var) (: cls) (or Hook (get Obj (: hook)))) + Val NIL (: dbf) ) + (extra Obj Val Hook) ) + +(dm keep> (Obj Val Hook) + (store + (tree (: var) (: cls) (or Hook (get Obj (: hook)))) + Val Obj (: dbf) ) + (extra Obj Val Hook) ) + + +# (+Ref) hook +(class +Ref +index) +# aux + +(dm rel> (Obj Old New Hook) + (let + (Tree (tree (: var) (: cls) (or Hook (get Obj (: hook)))) + Aux (conc (mapcar '((S) (get Obj S)) (: aux)) Obj) ) + (when Old + (store Tree (cons Old Aux) NIL (: dbf)) ) + (and New + (not (get Obj T)) + (store Tree (cons New Aux) Obj (: dbf)) ) ) + (extra Obj Old New Hook) ) + +(dm lose> (Obj Val Hook) + (store + (tree (: var) (: cls) (or Hook (get Obj (: hook)))) + (cons Val (conc (mapcar '((S) (get Obj S)) (: aux)) Obj)) + NIL (: dbf) ) + (extra Obj Val Hook) ) + +(dm keep> (Obj Val Hook) + (store + (tree (: var) (: cls) (or Hook (get Obj (: hook)))) + (cons Val (conc (mapcar '((S) (get Obj S)) (: aux)) Obj)) + Obj (: dbf) ) + (extra Obj Val Hook) ) + + +# 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 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) cnt hook +(class +Idx +Ref) +# min + +(dm T (Var Lst) + (=: min (or (car Lst) 3)) + (super Var (cdr Lst)) ) + +(dm rel> (Obj Old New Hook) + (let + (Tree (tree (: var) (: cls) (or Hook (get Obj (: hook)))) + Aux (conc (mapcar '((S) (get Obj S)) (: aux)) Obj) ) + (when Old + (store Tree (cons Old Aux) NIL (: dbf)) + (for S (split (cdr (chop Old)) " " "^J") + (while (nth S (: min)) + (store Tree (list (pack S) Obj) NIL (: dbf)) + (pop 'S) ) ) ) + (when (and New (not (get Obj T))) + (store Tree (cons New Aux) Obj (: dbf)) + (for S (split (cdr (chop New)) " " "^J") + (while (nth S (: min)) + (store Tree (list (pack S) Obj) Obj (: dbf)) + (pop 'S) ) ) ) ) + (extra Obj Old New Hook) ) + +(dm lose> (Obj Val Hook) + (let + (Tree (tree (: var) (: cls) (or Hook (get Obj (: hook)))) + Aux (conc (mapcar '((S) (get Obj S)) (: aux)) Obj) ) + (store Tree (cons Val Aux) NIL (: dbf)) + (for S (split (cdr (chop Val)) " " "^J") + (while (nth S (: min)) + (store Tree (list (pack S) Obj) NIL (: dbf)) + (pop 'S) ) ) ) + (extra Obj Val Hook) ) + +(dm keep> (Obj Val Hook) + (let + (Tree (tree (: var) (: cls) (or Hook (get Obj (: hook)))) + Aux (conc (mapcar '((S) (get Obj S)) (: aux)) Obj) ) + (store Tree (cons Val Aux) Obj (: dbf)) + (for S (split (cdr (chop Val)) " " "^J") + (while (nth S (: min)) + (store Tree (list (pack S) Obj) Obj (: dbf)) + (pop 'S) ) ) ) + (extra Obj Val Hook) ) + + + +# (+Sn +index) hook +(class +Sn) + +(dm rel> (Obj Old New Hook) + (let Tree (tree (: var) (: cls) (or Hook (get Obj (: hook)))) + (when Old + (store Tree (cons (ext:Snx Old) Obj T) NIL (: dbf)) ) + (and New + (not (get Obj T)) + (store Tree (cons (ext:Snx New) Obj T) Obj (: dbf)) ) ) + (extra Obj Old New Hook) ) + +(dm lose> (Obj Val Hook) + (store + (tree (: var) (: cls) (or Hook (get Obj (: hook)))) + (cons (ext:Snx Val) Obj T) + NIL (: dbf) ) + (extra Obj Val Hook) ) + +(dm keep> (Obj Val Hook) + (store + (tree (: var) (: cls) (or Hook (get Obj (: hook)))) + (cons (ext:Snx Val) Obj T) + Obj (: dbf) ) + (extra Obj Val Hook) ) + + +# (+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 lose> (Obj Val Hook) + (extra Obj (fold Val) Hook) ) + +(dm keep> (Obj Val Hook) + (extra Obj (fold Val) Hook) ) + + +# (+Aux) lst +(class +Aux) + +(dm T (Var Lst) + (=: aux (car Lst)) + (with *Class + (for A (car Lst) + (if (asoq A (: Aux)) + (conc @ (cons Var)) + (=: Aux + (conc (: Aux) (cons (list A Var))) ) ) ) ) + (extra Var (cdr Lst)) ) + +(de relAux (Obj Var Old Lst) + (for A Lst + (let? Val (get Obj A) + (with (meta Obj A) + (let Tree (tree (: var) (: cls) (get Obj (: hook))) + (store Tree + (conc + (cons Val + (mapcar + '((S) + (if (== S Var) Old (get Obj S)) ) + (: aux) ) ) + Obj ) + NIL + (: dbf) ) + (store Tree + (conc + (cons Val + (mapcar + '((S) + (if (== S Var) (get Obj Var) (get Obj S)) ) + (: aux) ) ) + Obj ) + Obj + (: dbf) ) ) ) ) ) ) + + +### Relation prefix classes ### +(class +Dep) +# dep + +(dm T (Var Lst) + (=: dep (car Lst)) + (extra Var (cdr Lst)) ) + +(dm rel> (Obj Old New Hook) + (unless New + (for Var (: dep) + (del> Obj Var (get Obj Var)) ) ) + (extra Obj Old New Hook) ) + +(dm lose> (Obj Val Hook) + (for Var (: dep) + (del> Obj Var (get Obj Var)) ) + (extra Obj Val Hook) ) + + +(class +List) + +(dm mis> (Val Obj) + (or + (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) + (and Val + (or + (extra Val X) + (find '((X) (extra Val X)) 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) ) ) + +(dm rel> (Obj Old New Hook) + (if (or (ele> This Old) (ele> This New)) + (extra Obj Old New Hook) + (for O (diff Old New) + (extra Obj O NIL Hook) ) + (for N New + (extra Obj NIL N Hook) ) ) ) + +(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) ) ) ) + + +(class +Need) + +(dm mis> (Val Obj) + (ifn Val + ,"Input required" + (extra Val Obj) ) ) + + +(class +Mis) +# 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)) ) + + +### Entities ### +(class +Entity) + +(var Dbf) +(var Aux) + +(de dbSync () + (let *Run NIL + (while (lock *DB) (wait 40)) + (sync) ) ) + +(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)) + (dbSync) + (prog2 + (touch Obj) + (inc (prop Obj Var) (or Val 1)) + (commit 'upd) ) ) ) + +(de blob! (Obj Var File) + (and *Jnl (blob+ Obj Var)) + (put!> Obj Var File) ) + +(de blob+ (Obj Var) + (chdir *Blob + (call 'ln "-sf" + (pack (glue "/" (chop Obj)) "." Var) + (pack (name Obj) "." Var) ) ) ) + +(dm T @ + (while (args) + (cond + ((=T (next)) (put This T T)) + ((atom (arg)) (put> This (arg) (next))) + (T (put> This (car (arg)) (eval (cdr (arg))))) ) ) + (upd> This (val This)) ) + +(dm zap> () + (for X (getl This) + (let V (or (atom X) (pop 'X)) + (and (meta This X) (zap> @ This V)) ) ) ) + +(dm url> (Tab)) + +(dm upd> (X Old)) + +(dm has> (Var Val) + (or + (nor Val (get This Var)) + (has> (meta This Var) Val (get This Var)) ) ) + +(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 @)) ) + (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 @)) ) + (when (asoq Var (meta This 'Aux)) + (relAux This Var Old (cdr @)) ) + (upd> This Var Old) + (commit 'upd) ) ) ) + +(dm inc> (Var Val) + (when (num? (get This Var)) + (touch This) + (let Old (get This Var) + (rel> (meta This Var) This Old + (inc (prop This Var) (or Val 1)) ) + (when (asoq Var (meta This 'Aux)) + (relAux This Var Old (cdr @)) ) + (upd> This Var Old) ) ) ) + +(dm inc!> (Var Val) + (when (num? (get This Var)) + (dbSync) + (touch This) + (let Old (get This Var) + (rel> (meta This Var) This Old + (inc (prop This Var) (or Val 1)) ) + (when (asoq Var (meta This 'Aux)) + (relAux This Var Old (cdr @)) ) + (upd> This Var Old) + (commit 'upd) ) ) ) + +(dm dec> (Var Val) + (when (num? (get This Var)) + (touch This) + (let Old (get This Var) + (rel> (meta This Var) This Old + (dec (prop This Var) (or Val 1)) ) + (when (asoq Var (meta This 'Aux)) + (relAux This Var Old (cdr @)) ) + (upd> This Var Old) ) ) ) + +(dm dec!> (Var Val) + (when (num? (get This Var)) + (dbSync) + (touch This) + (let Old (get This Var) + (rel> (meta This Var) This Old + (dec (prop This Var) (or Val 1)) ) + (when (asoq Var (meta This 'Aux)) + (relAux This Var Old (cdr @)) ) + (upd> This Var Old) + (commit 'upd) ) ) ) + +(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) (pop 'X)) + (and + (not (memq X Lst)) + (meta This X) + (lose> @ This V) ) ) ) + (=: T T) + (upd> This) ) ) + +(dm lose!> () + (dbSync) + (lose> This) + (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) + (for X (getl This) + (let V (or (atom X) (pop '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) (get (up This) (: hook))) (car X)) + (cons (car X) ,"Not unique") ) ) ) + (getl This) ) ) + +(dm keep!> () + (dbSync) + (keep> This) + (commit 'upd) ) + +(de keep "Prg" + (let "Flg" (: T) + (=: T) + (run "Prg") + (=: T "Flg") ) ) + +(dm set> (Val) + (unless (= Val (val This)) + (let + (L + (extract + '((X) + (pop 'X) + (unless (== (meta Val X) (meta (val This) X)) + X ) ) + (getl This) ) + V (mapcar + '((X) + (prog1 + (get This X) + (if (meta This X) + (put> This X) + (put This X) ) ) ) + L ) ) + (xchg This 'Val) + (mapc + '((X V) + (if (meta This X) + (put> This X V) + (put This X V) ) ) + L V ) ) + (upd> This (val This) Val) ) + (val This) ) + +(dm set!> (Val) + (unless (= Val (val This)) + (dbSync) + (let + (L + (extract + '((X) + (pop 'X) + (unless (== (meta Val X) (meta (val This) X)) + X ) ) + (getl This) ) + V (mapcar + '((X) + (prog1 + (get This X) + (if (meta This X) + (put> This X) + (put This X) ) ) ) + L ) ) + (xchg This 'Val) + (mapc + '((X V) + (if (meta This X) + (put> This X V) + (put This X V) ) ) + L V ) ) + (upd> This (val This) Val) + (commit 'upd) ) + (val This) ) + +(dm clone> () + (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 ) ) + (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)) ) ) ) ) + (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 + (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) + (get This (get Rel 'hook)) ) ) ) + ((or (not (isa '+Joint Rel)) (isa '+List (meta Obj (cdr X)))) + (put> Obj (cdr X) (car X)) ) ) ) ) ) ) + Obj ) ) + +(de cloneKey (Rel Var Val Hook) + (cond + ((isa '+Number Rel) + (genKey Var (get Rel 'cls) Hook) ) + ((isa '+String Rel) + (let S (pack "# " Val) + (while (fetch (tree Var (get Rel 'cls) Hook) S) + (setq S (pack "# " S)) ) + S ) ) ) ) + +(dm clone!> () + (prog2 + (dbSync) + (clone> This) + (commit 'upd) ) ) + +# Default syncronization function +(de upd Lst + (wipe Lst) ) + + +### Utilities ### +# 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 (: hook) (next) Var) + (pass new Dbf Typ Var) ) ) ) ) ) ) + +# Create or update object +(de obj Lst + (let Obj (apply request (pop 'Lst)) + (while Lst + (put> Obj (pop 'Lst) (pop 'Lst)) ) + Obj ) ) + +# vi:et:ts=3:sw=3 diff --git a/lib/db32-64.l b/lib/db32-64.l @@ -0,0 +1,73 @@ +# 05feb10abu +# (c) Software Lab. Alexander Burger + +## 1. On the 32-bit system, in single-user mode: +## : (load "lib/db32-64.l") +## : (export64 *Pool *Dbs *Blob) +## +## 2. Transfer the resulting file "db64.tgz" to the 64-bit system, +## and unpack it in the application's runtime directory +## +## 3. On the 64-bit system, in single-user mode: +## : (load "lib/db32-64.l") +## : (import32) + +# 64-bit DB export: (export64 "db/app/" *Dbs *Blob) -> "db64.tgz" +(de export64 (Pool Dbs Blob) + (if Blob + (call 'tar "cfz" (tmp "db32.tgz") Pool Blob) + (call 'tar "cfz" (tmp "db32.tgz") Pool) ) + (chdir (tmp) + (call 'tar "xfz" "db32.tgz") + (pool Pool Dbs) + (for (F . @) (or Dbs (2)) + (for (S (seq F) S (seq S)) + (touch S) + (at (0 . 10000) (commit T)) ) ) + (commit T) + (pool) + (for (F . @) Dbs + (call 'mv + (pack Pool F) + (pack Pool (hax (dec F))) ) ) + (ifn Blob + (call 'tar "cvfz" "../../db64.tgz" Pool) + (call 'mv Blob ".blob/") + (call 'mkdir "-p" Blob) + (use (@S @R Src) + (let Pat '`(conc (chop ".blob/") '(@S "." @R)) + (in (list 'find ".blob/" "-type" "f") + (while (setq Src (line)) + (when (match Pat Src) + (let + (L (split (replace @S "/") "-") + Dbf + (when (cdr L) + (pack + (hax (dec (fmt64 (pack (pop 'L))))) + "/" ) ) + Id + (chop (oct (fmt64 (pack (car L))))) + Dst + (pack + Blob + Dbf + (car Id) + (flip + (mapcan list + (flip (cdr Id)) + '(NIL NIL "/" .) ) ) + "." + @R ) ) + (when (dirname Dst) + (call 'mkdir "-p" @) ) + (call 'mv Src Dst) ) ) ) ) ) ) + (call 'tar "cvfz" "../../db64.tgz" Pool Blob) ) ) ) + +# 32-bit -> 64-bit DB import +(de import32 () + (dbMap NIL + '((Base Root Var Cls Hook) + (rebuild NIL Var Cls Hook) ) ) ) + +# vi:et:ts=3:sw=3 diff --git a/lib/dbase.l b/lib/dbase.l @@ -0,0 +1,59 @@ +# 10jul08abu +# (c) Software Lab. Alexander Burger + +(de dbase (File) + (use (Cnt Hdr Siz Fld X) + (in File + (unless (= 3 (rd 1)) # Version + (quit "dBASE Version") ) + (rd 3) # Date + (setq + Cnt (rd -4) # Record count + Hdr (rd -2) # Header size + Siz (rd -2) ) # Record size + (rd 3) # Reserved + (unless (=0 (rd 1)) # Encryption Flag + (quit "Encrypted") ) + (rd 16) # Reserved + (setq Fld + (make + (until (= 13 (setq X (rd 1))) + (link + (cons + (intern # Name + (pack + (char X) + (make + (for + (L (make (do 10 (link (rd 1)))) + (n0 (car L)) + (cdr L) ) + (link (char (car L))) ) ) ) ) + (cons + (char (rd 1)) # Type + (cons + (prog (rd 4) (rd 1)) # Size + (rd 1) ) ) ) ) # Prec + (rd 14) ) ) ) ) # Skip + + (in (list "bin/utf2" "-dd" (pack "if=" File) (pack "bs=" Hdr) "skip=1") + (prog1 + (make + (do Cnt + (setq X (make (do Siz (link (char))))) + (when (<> "*" (pop 'X)) + (link + (extract + '((F) + (let? S (pack (clip (cut (caddr F) 'X))) + (cons + (car F) + (case (cadr F) + ("C" S) + ("D" ($dat S)) + ("L" (bool (member S `(chop "JjTt")))) + ("N" (format S (cdddr F))) + (T "?") ) ) ) ) + Fld ) ) ) ) ) + (unless (= "^Z" (char)) + (quit "Missing EOF") ) ) ) ) ) diff --git a/lib/debug.l b/lib/debug.l @@ -0,0 +1,362 @@ +# 12mar10abu +# (c) Software Lab. Alexander Burger + +# Browsing +(de doc (Sym Browser) + (let (L (chop Sym) C (car L)) + (and + (member C '("*" "+")) + (cadr L) + (setq C @) ) + (cond + ((>= "Z" C "A")) + ((>= "z" C "a") (setq C (uppc C))) + (T (setq C "_")) ) + (call (or Browser (sys "BROWSER") 'w3m) + (pack + "file:" + (and (= `(char '/) (char (path "@"))) "//") + (path "@doc/ref") + C ".html#" Sym ) ) ) ) + +(de more ("M" "Fun") + (let *Dbg NIL + (if (pair "M") + ((default "Fun" print) (pop '"M")) + (println (type "M")) + (setq + "Fun" (list '(X) (list 'pp 'X (lit "M"))) + "M" (mapcar car (filter pair (val "M"))) ) ) + (loop + (T (atom "M") (prinl)) + (T (line) T) + ("Fun" (pop '"M")) ) ) ) + +(de depth (Idx) #> (max . average) + (let (C 0 D 0 N 0) + (cons + (recur (Idx N) + (ifn Idx + 0 + (inc 'C) + (inc 'D (inc 'N)) + (inc + (max + (recurse (cadr Idx) N) + (recurse (cddr Idx) N) ) ) ) ) + (or (=0 C) (*/ D C)) ) ) ) + +(de what (S) + (let *Dbg NIL + (setq S (chop S)) + (filter + '(("X") (match S (chop "X"))) + (all) ) ) ) + + +(de who ("X" . "*Prg") + (let (*Dbg NIL "Who" '("Who" @ @@ @@@)) + (make (mapc "who" (all))) ) ) + +(de "who" ("Y") + (unless (or (ext? "Y") (memq "Y" "Who")) + (push '"Who" "Y") + (ifn (= `(char "+") (char "Y")) + (and (pair (val "Y")) ("nest" @) (link "Y")) + (for "Z" (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 can (X) + (let *Dbg NIL + (extract + '(("Y") + (and + (= `(char "+") (char "Y")) + (asoq X (val "Y")) + (cons X "Y") ) ) + (all) ) ) ) + + +# 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") ) ) ) + +# Source code +(off "*Vi") + +(in "@lib/tags" + (while (read) + (let Sym @ + (if (get Sym '*Dbg) + (set @ (read)) + (put Sym '*Dbg (cons (read))) ) ) ) ) + +(de vi ("X" C) + (when (pair "X") + (setq C (cdr "X") "X" (car "X")) ) + (when + (if "X" + (setq "*Vi" + (if C + (get C '*Dbg -1 "X") + (get "X" '*Dbg 1) ) ) + "*Vi" ) + (call 'vim + (pack "+" (car "*Vi")) + (path (cdr "*Vi")) ) + "X" ) ) + +(de ld () + (and "*Vi" (load (cdr "*Vi"))) ) + +# 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) + (case (pop 'Lst) + ((case 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 ("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 ("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 X (set "X" (cddr (cadr (getd "X")))) + (and + (== '@ (pop 'X)) + (= 1 (length X)) + (= 2 (length (car X))) + (== 'pass (caar X)) + (sym? (cdadr X)) + (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 +(de proc @ + (apply call + (make (while (args) (link "-C" (next)))) + 'ps "-H" "-o" "pid,ppid,start,size,pcpu,wchan,cmd" ) ) + +# Hex Dump +(de hd (File Cnt) + (in File + (let Pos 0 + (while + (and + (nand Cnt (lt0 (dec 'Cnt))) + (make (do 16 (and (rd 1) (link @)))) ) + (let L @ + (prin (pad 8 (hex Pos)) " ") + (inc 'Pos 16) + (for N L + (prin (pad 2 (hex N)) " ") ) + (space (inc (* 3 (- 16 (length L))))) + (for N L + (prin (if (<= 32 N 127) (char N) ".")) ) + (prinl) ) ) ) ) ) + +# Benchmarking +(de bench Prg + (let U (usec) + (prog1 (run Prg 1) + (out 2 + (prinl + (format (*/ (- (usec) U) 1000) 3) + " sec" ) ) ) ) ) + +# vi:et:ts=3:sw=3 diff --git a/lib/ed.l b/lib/ed.l @@ -0,0 +1,47 @@ +# 27feb10abu +# (c) Software Lab. Alexander Burger + +# Structure Editor +(setq *Clip) + +(de ed ("X" "C") + (when (pair "X") + (setq "C" (cdr "X") "X" (car "X")) ) + (catch NIL + (let (*Dbg NIL "Done") + (ifn "C" + (set "X" (_ed (val "X"))) + (and + (asoq "X" (val "C")) + (con @ (_ed (cdr @))) ) ) + (pp "X" "C") ) ) ) + +(de _ed (X) + (use C + (loop + (T "Done" X) + (pretty (car X)) + (prinl) + (T (member (setq C (key)) '("^H" "^?")) X) + (T (= C "^I") (on "Done") X) + (setq X + (if (>= "9" C "1") + (cons + (head (setq C (format C)) X) + (nth X (inc C)) ) + (case (uppc C) + (("^M" "^J") (cons (_ed (car X)) (cdr X))) + ("^[" (throw)) + (" " (cons (car X) (_ed (cdr X)))) + ("D" (cdr X)) + ("I" (prin "Insert:") (cons (read) X)) + ("R" (prin "Replace:") (cons (read) (cdr X))) + ("X" (setq *Clip (car X)) (cdr X)) + ("C" (setq *Clip (car X)) X) + ("V" (cons *Clip X)) + ("0" (append (car X) (cdr X))) + ("B" + (if (== '! (caar X)) + (cons (cdar X) (cdr X)) + (cons (cons '! (car X)) (cdr X)) ) ) + (T X) ) ) ) ) ) ) diff --git a/lib/edit.l b/lib/edit.l @@ -0,0 +1,66 @@ +# 10mar10abu +# (c) Software Lab. Alexander Burger + +# "*F" "*Lst" "*X" "*K" + +(de edit @ + (let *Dbg NIL + (setq "*F" (tmp '"edit.l")) + (catch NIL + ("edit" (rest)) ) ) ) + +(de "edit" ("Lst") + (let "N" 1 + (loop + (out "*F" + (setq "*Lst" + (make + (for "S" "Lst" + ("loc" (printsp "S")) + ("loc" (val "S")) + (pretty (val "S")) + (prinl) + (for "X" (sort (getl "S")) + ("loc" "X") + (space 3) + (if (atom "X") + (println "X" T) + (printsp (cdr "X")) + (pretty (setq "X" (car "X")) -3) + (cond + ((type "X") + (prin " # ") + (print @) ) + ((>= 799999 "X" 700000) + (prin " # " (datStr "X")) ) ) + (prinl) ) ) + (prinl) + (println '(********)) + (prinl) ) ) ) ) + (call 'vim + "+set isk=@,33-34,36-38,42-90,92,94-95,97-125" + "+map K yw:call setline(line(\"$\"), \"(\" . line(\".\") . \" \" . @@ . \")\")^MZZ" + "+map Q GC(0)^[ZZ" + (pack "+" "N") + "*F" ) + (apply ==== "*Lst") + (in "*F" + (while (and (setq "*X" (read)) (atom "*X")) + (def "*X" (read)) + (until (= '(********) (setq "*K" (read))) + (def "*X" "*K" (read)) ) ) ) + (====) + (NIL "*X" (throw)) + (T (=0 (car "*X"))) + (setq "N" (car "*X")) + ("edit" (conc (cdr "*X") "Lst")) ) ) ) + +(de "loc" ("X" "Lst") + (cond + ((memq "X" "Lst")) + ((and (str? "X") (not (memq "X" (made)))) + (link "X") ) + ((pair "X") + (push '"Lst" "X") + ("loc" (car "X") "Lst") + ("loc" (cdr "X") "Lst") ) ) ) diff --git a/lib/el/inferior-picolisp.el b/lib/el/inferior-picolisp.el @@ -0,0 +1,312 @@ +;;;;;; inferior-picolisp: Picolisp repl in a buffer. +;;;;;; Version: 1.0 + +;;; Copyright (c) 2009, Guillermo R. Palavecino + +;; This file is NOT part of GNU emacs. + +;;;; Credits: +;; It's and adaptation of GNU emacs' cmuscheme.el +;; +;;;; Contact: +;; For comments, bug reports, questions, etc, you can contact me via IRC +;; to the user named grpala (or armadillo) on irc.freenode.net in the +;; #picolisp channel or via email to the author's nickname at gmail.com +;; +;;;; License: +;; This work is released under the GPL 2 or (at your option) any later +;; version. + +(require 'picolisp) +(require 'comint) + + +(defgroup picolisp nil + "Run an Picolisp process in a buffer." + :group 'picolisp ) + +;;; INFERIOR PICOLISP MODE STUFF +;;;============================================================================ + +(defcustom inferior-picolisp-mode-hook nil + "*Hook for customizing inferior-picolisp mode." + :type 'hook + :group 'picolisp ) + +(defvar inferior-picolisp-mode-map + (let ((m (make-sparse-keymap))) + (define-key m "\M-\C-x" 'picolisp-send-definition) ;gnu convention + (define-key m "\C-x\C-e" 'picolisp-send-last-sexp) + (define-key m "\C-c\C-l" 'picolisp-load-file) + m ) ) + +(defvar picolisp-program-name "/usr/bin/picolisp" + "The name of the program used to run Picolisp." ) + +;; Install the process communication commands in the picolisp-mode keymap. +(define-key picolisp-mode-map "\M-\C-x" 'picolisp-send-definition);gnu convention +(define-key picolisp-mode-map "\C-x\C-e" 'picolisp-send-last-sexp);gnu convention +(define-key picolisp-mode-map "\C-c\C-e" 'picolisp-send-definition) +(define-key picolisp-mode-map "\C-c\M-e" 'picolisp-send-definition-and-go) +(define-key picolisp-mode-map "\C-c\C-r" 'picolisp-send-region) +(define-key picolisp-mode-map "\C-c\M-r" 'picolisp-send-region-and-go) +(define-key picolisp-mode-map "\C-c\C-x" 'switch-to-picolisp) +(define-key picolisp-mode-map "\C-c\C-l" 'picolisp-load-file) + +(let ((map (lookup-key picolisp-mode-map [menu-bar picolisp]))) + (define-key map [separator-eval] '("--")) + (define-key map [load-file] + '("Load Picolisp File" . picolisp-load-file) ) + (define-key map [switch] + '("Switch to Picolisp" . switch-to-picolisp) ) + (define-key map [send-def-go] + '("Evaluate Last Definition & Go" . picolisp-send-definition-and-go) ) + (define-key map [send-def] + '("Evaluate Last Definition" . picolisp-send-definition) ) + (define-key map [send-region-go] + '("Evaluate Region & Go" . picolisp-send-region-and-go) ) + (define-key map [send-region] + '("Evaluate Region" . picolisp-send-region) ) + (define-key map [send-sexp] + '("Evaluate Last S-expression" . picolisp-send-last-sexp) ) ) + +(defvar picolisp-buffer) + +(define-derived-mode inferior-picolisp-mode comint-mode "Inferior Picolisp" + "Major mode for interacting with an inferior Picolisp process. + +The following commands are available: +\\{inferior-picolisp-mode-map} + +An Picolisp process can be fired up with M-x run-picolisp. + +Customization: Entry to this mode runs the hooks on comint-mode-hook and +inferior-picolisp-mode-hook (in that order). + +You can send text to the inferior Picolisp process from other buffers containing +Picolisp source. + switch-to-picolisp switches the current buffer to the Picolisp process buffer. + picolisp-send-definition sends the current definition to the Picolisp process. + picolisp-send-region sends the current region to the Picolisp process. + + picolisp-send-definition-and-go and picolisp-send-region-and-go + switch to the Picolisp process buffer after sending their text. +For information on running multiple processes in multiple buffers, see +documentation for variable picolisp-buffer. + +Commands: +Return after the end of the process' output sends the text from the + end of process to point. +Return before the end of the process' output copies the sexp ending at point + to the end of the process' output, and sends it. +Delete converts tabs to spaces as it moves back. +Tab indents for Picolisp; with argument, shifts rest + of expression rigidly with the current line. +C-M-q does Tab on each line starting within following expression. +Paragraphs are separated only by blank lines. Semicolons start comments. +If you accidentally suspend your process, use \\[comint-continue-subjob] +to continue it." + ;; Customize in inferior-picolisp-mode-hook + (picolisp-mode-variables) + (setq comint-prompt-regexp "^[^\n:?!]*[?!:]+ *") + (setq comint-prompt-read-only nil) + (setq comint-input-filter (function picolisp-input-filter)) + (setq comint-get-old-input (function picolisp-get-old-input)) + (setq mode-line-process '(":%s")) + (setq comint-input-ring-file-name "~/.pil_history") ) + +(defcustom inferior-picolisp-filter-regexp "\\`\\s *\\S ?\\S ?\\s *\\'" + "*Input matching this regexp are not saved on the history list. +Defaults to a regexp ignoring all inputs of 0, 1, or 2 letters." + :type 'regexp + :group 'picolisp ) + +(defun picolisp-input-filter (str) + "Don't save anything matching `inferior-picolisp-filter-regexp'." + (not (string-match inferior-picolisp-filter-regexp str)) ) + + +(defun picolisp-get-old-input () + "Snarf the sexp ending at point." + (save-excursion + (let ((end (point))) + (backward-sexp) + (buffer-substring (point) end) ) ) ) + +;;;###autoload +(defun run-picolisp (cmd) + "Run an inferior Picolisp process, input and output via buffer `*picolisp*'. +If there is a process already running in `*picolisp*', switch to that buffer. +With argument, allows you to edit the command line (default is value +of `picolisp-program-name'). +Runs the hook `inferior-picolisp-mode-hook' \(after the `comint-mode-hook' +is run). +\(Type \\[describe-mode] in the process buffer for a list of commands.)" + + (interactive (list (if current-prefix-arg + (read-string "Run Picolisp: " picolisp-program-name) + picolisp-program-name ) ) ) + (when (not (comint-check-proc "*picolisp*")) + (let ((cmdlist (split-string cmd))) + (set-buffer (apply 'make-comint "picolisp" (car cmdlist) + nil (cdr cmdlist) ) ) + (inferior-picolisp-mode) ) ) + (setq picolisp-program-name cmd) + (setq picolisp-buffer "*picolisp*") + (pop-to-buffer "*picolisp*") ) +;;;###autoload (add-hook 'same-window-buffer-names "*picolisp*") + +(defun picolisp-send-region (start end) + "Send the current region to the inferior Picolisp process." + (interactive "r") + (let ((regionsubstring (replace-regexp-in-string "^ +" "" (buffer-substring start end) ) ) ) + (comint-send-string + (picolisp-proc) + (if (string= "" (car (last (split-string regionsubstring " +" ) ) ) ) + regionsubstring + (concat regionsubstring "\n") ) ) ) ) + +(defun picolisp-send-definition () + "Send the current definition to the inferior Picolisp process." + (interactive) + (save-excursion + (end-of-defun) + (let ((end (point))) + (beginning-of-defun) + (picolisp-send-region + (point) (progn (forward-sexp) (point)) ) ) ) ) + +(defun picolisp-send-last-sexp () + "Send the previous sexp to the inferior Picolisp process." + (interactive) + (picolisp-send-region (save-excursion (backward-sexp) (point)) (point)) ) + +(defun switch-to-picolisp (eob-p) + "Switch to the picolisp process buffer. +With argument, position cursor at end of buffer." + (interactive "P") + (if (or (and picolisp-buffer (get-buffer picolisp-buffer)) + (picolisp-interactively-start-process) ) + (pop-to-buffer picolisp-buffer) + (error "No current process buffer. See variable `picolisp-buffer'") ) + (when eob-p + (push-mark) + (goto-char (point-max)) ) ) + +(defun picolisp-send-region-and-go (start end) + "Send the current region to the inferior Picolisp process. +Then switch to the process buffer." + (interactive "r") + (picolisp-send-region start end) + (switch-to-picolisp t) ) + +(defun picolisp-send-definition-and-go () + "Send the current definition to the inferior Picolisp. +Then switch to the process buffer." + (interactive) + (picolisp-send-definition) + (switch-to-picolisp t) ) + +(defcustom picolisp-source-modes '(picolisp-mode) + "*Used to determine if a buffer contains Picolisp source code. +If it's loaded into a buffer that is in one of these major modes, +it's considered a picolisp source file by `picolisp-load-file'. Used by +these commands to determine defaults." + :type '(repeat function) + :group 'picolisp ) + +(defvar picolisp-prev-load-dir/file nil + "Caches the last (directory . file) pair. +Caches the last pair used in the last `picolisp-load-file' command. +Used for determining the default in the next one." ) + +(defun picolisp-load-file (file-name) + "Load a Picolisp file FILE-NAME into the inferior Picolisp process." + (interactive (comint-get-source "Load Picolisp file: " picolisp-prev-load-dir/file + picolisp-source-modes t ) ) ; t because `load' + ; needs an exact name + (comint-check-source file-name) ; Check to see if buffer needs saved. + (setq picolisp-prev-l/c-dir/file (cons (file-name-directory file-name) + (file-name-nondirectory file-name) ) ) + (comint-send-string (picolisp-proc) (concat "(load \"" + file-name + "\"\)\n" ) ) ) + + +(defvar picolisp-buffer nil "*The current picolisp process buffer. + +MULTIPLE PROCESS SUPPORT +=========================================================================== +inferior-picolisp.el supports, in a fairly simple fashion, running multiple Picolisp +processes. To run multiple Picolisp processes, you start the first up with +\\[run-picolisp]. It will be in a buffer named *picolisp*. Rename this buffer +with \\[rename-buffer]. You may now start up a new process with another +\\[run-picolisp]. It will be in a new buffer, named *picolisp*. You can +switch between the different process buffers with \\[switch-to-buffer]. + +Commands that send text from source buffers to Picolisp processes -- like +`picolisp-send-definition' -- have to choose a process to send to, when you +have more than one Picolisp process around. This is determined by the +global variable `picolisp-buffer'. Suppose you have three inferior Picolisps +running: + Buffer Process + foo picolisp + bar picolisp<2> + *picolisp* picolisp<3> +If you do a \\[picolisp-send-definition-and-go] command on some Picolisp source +code, what process do you send it to? + +- If you're in a process buffer (foo, bar, or *picolisp*), + you send it to that process. +- If you're in some other buffer (e.g., a source file), you + send it to the process attached to buffer `picolisp-buffer'. +This process selection is performed by function `picolisp-proc'. + +Whenever \\[run-picolisp] fires up a new process, it resets `picolisp-buffer' +to be the new process's buffer. If you only run one process, this will +do the right thing. If you run multiple processes, you can change +`picolisp-buffer' to another process buffer with \\[set-variable]. + +More sophisticated approaches are, of course, possible. If you find yourself +needing to switch back and forth between multiple processes frequently, +you may wish to consider ilisp.el, a larger, more sophisticated package +for running inferior Lisp and Picolisp processes. The approach taken here is +for a minimal, simple implementation. Feel free to extend it." ) + +(defun picolisp-proc () + "Return the current Picolisp process, starting one if necessary. +See variable `picolisp-buffer'." + (unless (and picolisp-buffer + (get-buffer picolisp-buffer) + (comint-check-proc picolisp-buffer) ) + (picolisp-interactively-start-process) ) + (or (picolisp-get-process) + (error "No current process. See variable `picolisp-buffer'") ) ) + +(defun picolisp-get-process () + "Return the current Picolisp process or nil if none is running." + (get-buffer-process (if (eq major-mode 'inferior-picolisp-mode) + (current-buffer) + picolisp-buffer ) ) ) + +(defun picolisp-interactively-start-process (&optional cmd) + "Start an inferior Picolisp process. Return the process started. +Since this command is run implicitly, always ask the user for the +command to run." + (save-window-excursion + (run-picolisp (read-string "Run Picolisp: " picolisp-program-name)) ) ) + +;;; Do the user's customization... + +(defcustom inferior-picolisp-load-hook nil + "This hook is run when inferior-picolisp is loaded in. +This is a good place to put keybindings." + :type 'hook + :group 'picolisp ) + +(run-hooks 'inferior-picolisp-load-hook) + +(provide 'inferior-picolisp) + diff --git a/lib/el/paredit.el.diff b/lib/el/paredit.el.diff @@ -0,0 +1,89 @@ +--- /usr/share/emacs/site-lisp/paredit/paredit.el 2009-07-28 20:43:11.000000000 -0300 ++++ src/el/paredit.el 2009-12-15 04:39:31.000000000 -0300 +@@ -683,7 +683,8 @@ + (defun paredit-move-past-close (close) + (cond ((or (paredit-in-string-p) + (paredit-in-comment-p)) +- (insert close)) ++ (insert close) ++ (paredit-delete-leading-whitespace)) + ((not (paredit-in-char-p)) + (paredit-move-past-close-and-reindent close) + (paredit-blink-paren-match nil)))) +@@ -691,7 +692,8 @@ + (defun paredit-move-past-close-and-newline (close) + (if (or (paredit-in-string-p) + (paredit-in-comment-p)) +- (insert close) ++ (progn (insert close) ++ (paredit-delete-leading-whitespace)) + (if (paredit-in-char-p) (forward-char)) + (paredit-move-past-close-and-reindent close) + (let ((comment.point (paredit-find-comment-on-line))) +@@ -747,6 +749,7 @@ + (point)))) + (regionp (funcall forward (+ end (if spacep 2 1))))) + (insert close) ++ (paredit-delete-leading-whitespace) + (if (paredit-space-for-delimiter-p t close) + (insert " ")))))) + +@@ -784,7 +787,8 @@ + (if (eq close (matching-paren open)) + (save-excursion + (message "Missing closing delimiter: %c" close) +- (insert close)) ++ (insert close) ++ (paredit-delete-leading-whitespace)) + (error "Mismatched missing closing delimiter: %c ... %c" + open close)))) + (let ((orig (point))) +@@ -1543,6 +1547,7 @@ + ((paredit-region-active-p) nil) + (t 1))) + (insert close) ++ (paredit-delete-leading-whitespace) + (backward-char))) + (save-excursion (backward-up-list) (indent-sexp))) + +@@ -1791,8 +1796,10 @@ + (setq close ; adjusting for mixed + (prog1 (char-before) ; delimiters as necessary, + (backward-delete-char 1) +- (insert close)))))) +- (insert close))) ; to insert that delimiter. ++ (insert close) ++ (paredit-delete-leading-whitespace)))))) ++ (insert close) ; to insert that delimiter. ++ (paredit-delete-leading-whitespace))) + + (defun paredit-forward-slurp-into-string () + (goto-char (1+ (cdr (paredit-string-start+end-points)))) +@@ -1802,7 +1809,8 @@ + (let ((close (char-before))) + (backward-delete-char 1) + (paredit-forward-for-quote (save-excursion (forward-sexp) (point))) +- (insert close))) ++ (insert close) ++ (paredit-delete-leading-whitespace))) + + (defun paredit-forward-barf-sexp () + "Remove the last S-expression in the current list from that list +@@ -1822,7 +1830,8 @@ + (error "Barfing all subexpressions with no open-paren?")) + ((paredit-in-comment-p) ; Don't put the close-paren in + (newline-and-indent))) ; a comment. +- (insert close)) ++ (insert close) ++ (paredit-delete-leading-whitespace)) + ;; Reindent all of the newly barfed S-expressions. + (paredit-forward-and-indent))) + +@@ -1919,6 +1928,7 @@ + (char-before)))) + (delete-horizontal-space) + (insert close) ++ (paredit-delete-leading-whitespace) + (save-excursion (insert ?\ ) + (insert open) + (backward-char) diff --git a/lib/el/picolisp.el b/lib/el/picolisp.el @@ -0,0 +1,536 @@ +;;;;;; picolisp-mode: Major mode to edit picoLisp. +;;;;;; Version: 1.1 + +;;; Copyright (c) 2009, Guillermo R. Palavecino + +;; This file is NOT part of GNU emacs. + +;;;; Credits: +;; It's based on GNU emacs' lisp-mode and scheme-mode. +;; Some bits were taken from paredit.el +;; +;;;; Contact: +;; For comments, bug reports, questions, etc, you can contact me via IRC +;; to the user named grpala (or armadillo) on irc.freenode.net in the +;; #picolisp channel or via email to the author's nickname at gmail.com +;; +;;;; License: +;; This work is released under the GPL 2 or (at your option) any later +;; version. + +(require 'lisp-mode) + +(defcustom picolisp-parsep t + "This is to toggle picolisp-mode's multi-line s-exps closing parens separation capability." + :type 'boolean + :group 'picolisp ) + +;; I know... this shouldn't be here, but you see, people may want to keep +;; their body-indent value unaltered and have a different one for picolisp +;; sources, so... +(defcustom picolisp-body-indent 3 + "Number of columns to indent the second line of a `(de ...)' form." + :group 'picolisp + :type 'integer ) + +(defvar picolisp-mode-syntax-table + (let ((st (make-syntax-table)) + (i 0) ) + + ;; Default is atom-constituent. + (while (< i 256) + (modify-syntax-entry i "_ " st) + (setq i (1+ i)) ) + + ;; Word components. + (setq i ?0) + (while (<= i ?9) + (modify-syntax-entry i "w " st) + (setq i (1+ i)) ) + (setq i ?A) + (while (<= i ?Z) + (modify-syntax-entry i "w " st) + (setq i (1+ i)) ) + (setq i ?a) + (while (<= i ?z) + (modify-syntax-entry i "w " st) + (setq i (1+ i)) ) + + ;; Whitespace + (modify-syntax-entry ?\t " " st) + (modify-syntax-entry ?\n "> " st) + (modify-syntax-entry ?\f " " st) + (modify-syntax-entry ?\r " " st) + (modify-syntax-entry ?\s " " st) + + ;; These characters are delimiters but otherwise undefined. + ;; Brackets and braces balance for editing convenience. + (modify-syntax-entry ?\[ "(] " st) + (modify-syntax-entry ?\] ")[ " st) + (modify-syntax-entry ?{ "(} " st) + (modify-syntax-entry ?} "){ " st) + + ;; Other atom delimiters + (modify-syntax-entry ?\( "() " st) + (modify-syntax-entry ?\) ")( " st) + ;; It's used for single-line comments. + (modify-syntax-entry ?# "< " st) + (modify-syntax-entry ?\" "\" " st) + (modify-syntax-entry ?' "' " st) + (modify-syntax-entry ?` "' " st) + (modify-syntax-entry ?~ "' " st) + + ;; Special characters + (modify-syntax-entry ?, "' " st) + (modify-syntax-entry ?\\ "\\ " st) + st ) ) + +(defvar picolisp-mode-abbrev-table nil) +(define-abbrev-table 'picolisp-mode-abbrev-table ()) + +(defun picolisp-mode-variables () + (set-syntax-table picolisp-mode-syntax-table) + ;;(setq local-abbrev-table picolisp-mode-abbrev-table) + (make-local-variable 'paragraph-start) + (setq paragraph-start (concat "$\\|" page-delimiter)) + ;;(setq comint-input-ring-file-name "~/.pil_history") + + (make-local-variable 'paragraph-separate) + (setq paragraph-separate paragraph-start) + + (make-local-variable 'paragraph-ignore-fill-prefix) + (setq paragraph-ignore-fill-prefix t) + + (make-local-variable 'fill-paragraph-function) + (setq fill-paragraph-function 'lisp-fill-paragraph) + ;; Adaptive fill mode gets in the way of auto-fill, + ;; and should make no difference for explicit fill + ;; because lisp-fill-paragraph should do the job. + (make-local-variable 'adaptive-fill-mode) + (setq adaptive-fill-mode nil) + + (make-local-variable 'normal-auto-fill-function) + (setq normal-auto-fill-function 'lisp-mode-auto-fill) + + (make-local-variable 'indent-line-function) + (setq indent-line-function 'picolisp-indent-line) + + (make-local-variable 'parse-sexp-ignore-comments) + (setq parse-sexp-ignore-comments t) + + (make-local-variable 'comment-start) + (setq comment-start "#") + + (set (make-local-variable 'comment-add) 1) + (make-local-variable 'comment-start-skip) + ;; Look within the line for a # following an even number of backslashes + ;; after either a non-backslash or the line beginning. + (setq comment-start-skip "\\(\\(^\\|[^\\\\\n]\\)\\(\\\\\\\\\\)*\\)#+[ \t]*"); ((^|[^\n])(\\\\)*)#+[ t]* + (set (make-local-variable 'font-lock-comment-start-skip) "#+ *") + + (make-local-variable 'comment-column) + (setq comment-column 40) + + (make-local-variable 'parse-sexp-ignore-comments) + (setq parse-sexp-ignore-comments t) + + (make-local-variable 'lisp-indent-function) + (setq lisp-indent-function 'picolisp-indent-function) + + ;; This is just to avoid tabsize-variations fuck-up. + (make-local-variable 'indent-tabs-mode) + + (setq mode-line-process '("" picolisp-mode-line-process)) + (set (make-local-variable 'font-lock-defaults) + '((picolisp-font-lock-keywords + picolisp-font-lock-keywords-1 + picolisp-font-lock-keywords-2 ) + nil t (("+-*/.<>=!?$%_&~^:" . "w")) + beginning-of-defun + (font-lock-mark-block-function . mark-defun) + (font-lock-keywords-case-fold-search . nil) + (parse-sexp-lookup-properties . t) + (font-lock-extra-managed-props syntax-table) ) ) + (set (make-local-variable 'lisp-doc-string-elt-property) + 'picolisp-doc-string-elt ) ) + +(defvar picolisp-mode-line-process "") + +(defvar picolisp-mode-map + (let ((map (make-sparse-keymap "Picolisp"))) + (set-keymap-parent map lisp-mode-shared-map) + (define-key map [menu-bar picolisp] (cons "Picolisp" map)) + (define-key map [run-picolisp] '("Run Inferior Picolisp" . run-picolisp)) + (define-key map [uncomment-region] + '("Uncomment Out Region" . (lambda (beg end) + (interactive "r") + (comment-region beg end '(4)) ) ) ) + (define-key map [comment-region] '("Comment Out Region" . comment-region)) + (define-key map [indent-region] '("Indent Region" . indent-region)) + (define-key map [indent-line] '("Indent Line" . picolisp-indent-line)) + (define-key map "\t" 'picolisp-indent-line) + (put 'comment-region 'menu-enable 'mark-active) + (put 'uncomment-region 'menu-enable 'mark-active) + (put 'indent-region 'menu-enable 'mark-active) + map ) + "Keymap for Picolisp mode. +All commands in `lisp-mode-shared-map' are inherited by this map." ) + + +;;;###autoload +(defun picolisp-mode () + "Major mode for editing Picolisp code. +Editing commands are similar to those of `lisp-mode'. + +Commands: +Delete converts tabs to spaces as it moves back. +Blank lines separate paragraphs. Semicolons start comments. +\\{picolisp-mode-map} +Entry to this mode calls the value of `picolisp-mode-hook' +if that value is non-nil." + (interactive) + (remove-text-properties (point-min) (point-max) '(display "")) + (kill-all-local-variables) + (use-local-map picolisp-mode-map) + (setq major-mode 'picolisp-mode) + (setq mode-name "Picolisp") + (picolisp-mode-variables) + (run-mode-hooks 'picolisp-mode-hook) + (defun paredit-delete-leading-whitespace () + (picolisp-delete-leading-whitespace) ) ) + +(autoload 'run-picolisp "inferior-picolisp" + "Run an inferior Picolisp process, input and output via buffer `*picolisp*'. +If there is a process already running in `*picolisp*', switch to that buffer. +With argument, allows you to edit the command line (default is value +of `picolisp-program-name'). +Runs the hook `inferior-picolisp-mode-hook' \(after the `comint-mode-hook' +is run). +\(Type \\[describe-mode] in the process buffer for a list of commands.)" + t ) + +(defgroup picolisp nil + "Editing Picolisp code." + :link '(custom-group-link :tag "Font Lock Faces group" font-lock-faces) + :group 'lisp ) + +(defcustom picolisp-mode-hook nil + "Normal hook run when entering `picolisp-mode'. +See `run-hooks'." + :type 'hook + :group 'picolisp ) + +(defconst picolisp-font-lock-keywords-1 + (eval-when-compile + (list + ;; + ;; Declarations. + (list + (concat "(" (regexp-opt '("be" "de" "dm" "set" "setq") t) "\\>" + ;; Any whitespace and declared object. + "[ \t]*(?" + "\\(\\sw+\\)?" ) + '(1 font-lock-keyword-face) + '(2 (cond ((match-beginning 0) font-lock-function-name-face) + ((match-beginning 3) font-lock-variable-name-face) + (t font-lock-type-face) ) + nil t ) ) + (list (concat "[( \t]'?" + (regexp-opt '("NIL" "T") t) + "[ )\n\t]" ) + '(1 font-lock-constant-face) ) + (list + (concat "[( ]" + (regexp-opt '("*OS" "*DB" "*Solo" "*PPid" "*Pid" "@" "@@" "@@@" + "This" "*Dbg" "*Zap" "*Scl" "*Class" "*Dbs" "*Run" + "*Hup" "*Sig1" "*Sig2" "^" "*Err" "*Msg" "*Uni" + "*Led" "*Adr" "*Allow" "*Fork" "*Bye" ) t ) + "[ )\n\t]" ) + '(1 font-lock-builtin-face) ) + ;; This is so we make the point used in conses more visible + '("[ \t]\\(\\.\\)[ \t)]" (1 font-lock-negation-char-face)) + '("(\\(====\\)\\>" (1 font-lock-negation-char-face)) ) ) + "Subdued expressions to highlight in Picolisp modes." ) + +(defconst picolisp-font-lock-keywords-2 + (append picolisp-font-lock-keywords-1 + (eval-when-compile + (list + ;; + ;; Control structures. + (cons + (concat + "(" (regexp-opt + '( ;; Symbol Functions + "new" "sym" "str" "char" "name" "sp?" "pat?" "fun?" "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" "xchg" "on" "off" "onOff" "zero" "one" "default" + "expr" "subr" "let" "let?" "use" "accu" "push" "push1" + "pop" "cut" "del" "queue" "fifo" "idx" "lup" "cache" + "locale" "dirname" + ;; Property Access + "put" "get" "prop" ";" "=:" ":" "::" "putl" "getl" "wipe" + "meta" + ;; Predicates + "atom" "pair" "lst?" "num?" "sym?" "flg?" "sp?" "pat?" + "fun?" "box?" "str?" "ext?" "bool" "not" "==" "n==" "=" + "<>" "=0" "=T" "n0" "nT" "<" "<=" ">" ">=" "match" + ;; Arithmetics + "+" "-" "*" "/" "%" "*/" "**" "inc" "dec" ">>" "lt0" + "ge0" "gt0" "abs" "bit?" "&" "|" "x|" "sqrt" "seed" + "rand" "max" "min" "length" "size" "accu" "format" "pad" + "oct" "hex" "fmt64" "money" + ;; List Processing + "car" "cdr" "caar" "cadr" "cdar" "cddr" "caaar" "caadr" + "cadar" "caddr" "cdaar" "cdadr" "cddar" "cdddr" "cadddr" + "cddddr" "nth" "con" "cons" "conc" "circ" "rot" "list" + "need" "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" "assoc" "asoq" + "rank" "sort" "uniq" "group" "length" "size" "val" "set" + "xchg" "push" "push1" "pop" "cut" "queue" "fifo" "idx" + "balance" "get" "fill" "apply" "range" + ;; Control Flow + "load" "args" "next" "arg" "rest" "pass" "quote" "as" + "pid" "lit" "eval" "run" "macro" "curry" "def" "de" "dm" + "recur" "recurse" "undef" "box" "new" "type" "isa" + "method" "meth" "send" "try" "super" "extra" "with" + "bind" "job" "let" "let?" "use" "and" "or" "nand" "nor" + "xor" "bool" "not" "nil" "t" "prog" "prog1" "prog2" "if" + "if2" "ifn" "when" "unless" "cond" "nond" "case" "state" + "while" "until" "loop" "do" "at" "for" "catch" "throw" + "finally" "!" "e" "$" "sys" "call" "tick" "ipid" "opid" + "kill" "quit" "task" "fork" "pipe" "later" "timeout" + "abort" "bye" + ;; Mapping + "apply" "pass" "maps" "map" "mapc" "maplist" "mapcar" + "mapcon" "mapcan" "filter" "extract" "seek" "find" "pick" + "cnt" "sum" "maxi" "mini" "fish" "by" + ;; Input/Output + "path" "in" "ipid" "out" "opid" "pipe" "ctl" "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" "rd" "pr" "wr" + "rpc" "wait" "sync" "echo" "info" "file" "dir" "lines" + "open" "close" "port" "listen" "accept" "host" "connect" + "nagle" "udp" "script" "once" "rc" "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" "with" "This" + ;; Database + "pool" "journal" "id" "seq" "lieu" "lock" "begin" + "commit" "rollback" "mark" "free" "dbck" "rel" "dbs" + "dbs+" "db:" "fmt64" "tree" "root" "fetch" "store" + "count" "leaf" "minKey" "maxKey" "genKey" "useKey" "init" + "step" "scan" "iter" "prune" "zapTree" "chkTree" "db" + "aux" "collect" + ;; Pilog + "goal" "prove" "->" "unify" "?" + ;; Debugging + "pretty" "pp" "show" "loc" "debug" "vi" "ld" "trace" + "lint" "lintAll" "fmt64" + ;; System Functions + "cmd" "argv" "opt" "gc" "raw" "alarm" "protect" "heap" + "env" "up" "date" "time" "usec" "stamp" "dat$" "$dat" + "datSym" "datStr" "strDat" "expDat" "day" "week" "ultimo" + "tim$" "$tim" "telStr" "expTel" "locale" "allowed" + "allow" "pwd" "cd" "chdir" "ctty" "info" "dir" "dirname" + "call" "tick" "kill" "quit" "task" "fork" "pipe" + "timeout" "mail" "test" "bye" ) t ) + "\\>" ) 1 ) ) ) ) + "Gaudy expressions to highlight in Picolisp modes." ) + +(defvar picolisp-font-lock-keywords picolisp-font-lock-keywords-1 + "Default expressions to highlight in Picolisp modes." ) + +(defconst picolisp-sexp-comment-syntax-table + (let ((st (make-syntax-table picolisp-mode-syntax-table))) + (modify-syntax-entry ?\n " " st) + (modify-syntax-entry ?# "." st) + st ) ) + +(put 'lambda 'picolisp-doc-string-elt 2) +;; Docstring's pos in a `define' depends on whether it's a var or fun def. +(put 'define 'picolisp-doc-string-elt + (lambda () + ;; The function is called with point right after "define". + (forward-comment (point-max)) + (if (eq (char-after) ?\() 2 0) ) ) + + +;; Copied from lisp-indent-line, +;; because Picolisp doesn't care about how many comment chars you use. +(defun picolisp-indent-line (&optional whole-exp) + "Indent current line as Picolisp code. +With argument, indent any additional lines of the same expression +rigidly along with this one." + (interactive "P") + (let ((indent (calculate-lisp-indent)) shift-amt end + (pos (- (point-max) (point))) + (beg (progn (beginning-of-line) (point))) ) + (skip-chars-forward " \t") + (if (or (null indent) (looking-at "\\s<\\s<\\s<")) + ;; Don't alter indentation of a ;;; comment line + ;; or a line that starts in a string. + (goto-char (- (point-max) pos)) + (if (listp indent) (setq indent (car indent))) + (setq shift-amt (- indent (current-column))) + (if (zerop shift-amt) + nil + (delete-region beg (point)) + (indent-to indent) ) ) + ;; If initial point was within line's indentation, + ;; position after the indentation. Else stay at same point in text. + (if (> (- (point-max) pos) (point)) + (goto-char (- (point-max) pos)) ) + ;; If desired, shift remaining lines of expression the same amount. + (and whole-exp (not (zerop shift-amt)) + (save-excursion + (goto-char beg) + (forward-sexp 1) + (setq end (point)) + (goto-char beg) + (forward-line 1) + (setq beg (point)) + (> end beg) ) + (indent-code-rigidly beg end shift-amt) ) ) ) + +(defvar calculate-lisp-indent-last-sexp) + +;; Copied from lisp-indent-function, but with gets of +;; picolisp-indent-{function,hook}, and minor modifications. +(defun picolisp-indent-function (indent-point state) + (picolisp-parensep) + (let ((normal-indent (current-column))) + (goto-char (1+ (elt state 1))) + (parse-partial-sexp (point) calculate-lisp-indent-last-sexp 0 t) + (if (and (elt state 2) + (not (looking-at "\"?\\sw\\|\\s_")) ) + ;; car of form doesn't seem to be a symbol + (progn + (if (not (> (save-excursion (forward-line 1) (point)) + calculate-lisp-indent-last-sexp ) ) + (progn (goto-char calculate-lisp-indent-last-sexp) + (beginning-of-line) + (parse-partial-sexp (point) + calculate-lisp-indent-last-sexp 0 t ) ) ) + ;; Indent under the list or under the first sexp on the same + ;; line as calculate-lisp-indent-last-sexp. Note that first + ;; thing on that line has to be complete sexp since we are + ;; inside the innermost containing sexp. + (backward-prefix-chars) + (current-column) ) + (let* ((function (buffer-substring (point) + (progn (forward-sexp 1) (point)) ) ) + (method (or (get (intern-soft function) 'picolisp-indent-function) + (get (intern-soft function) 'picolisp-indent-hook) + ;;(and picolisp-indent-style 'picolisp-indent-defform) + 'picolisp-indent ) ) ) + (if (integerp method) + (lisp-indent-specform method state indent-point normal-indent) + (funcall method state indent-point normal-indent) ) ) ) ) ) + + +;;; Some functions are different in picoLisp +(defun picolisp-indent (state indent-point normal-indent) + (let ((lisp-body-indent picolisp-body-indent)) + (lisp-indent-defform state indent-point) ) ) + + +;;; This is to space closing parens when they close a previous line. +(defun picolisp-parensep () + (save-excursion + (condition-case nil ; This is to avoid fuck-ups when there are + (progn ; unbalanced expressions. + (up-list) + (back-to-indentation) + (while (and (re-search-forward ")" (line-end-position) t) + (< (point) (line-end-position)) ) + (if (and (not (picolisp-in-comment-p)) + (not (picolisp-in-string-p)) ) + (picolisp-delete-leading-whitespace) ) ) + (if (and (not (picolisp-in-comment-p)) + (not (picolisp-in-string-p)) ) + (picolisp-delete-leading-whitespace) ) ) + (error nil) ) ) ) + +(defun picolisp-delete-leading-whitespace () + ;; This assumes that we're on the closing delimiter already. + (save-excursion + (backward-char) + (while (let ((syn (char-syntax (char-before)))) + (and (or (eq syn ?\ ) (eq syn ?-)) ; whitespace syntax + ;; The above line is a perfect example of why the + ;; following test is necessary. + (not (picolisp-in-char-p (1- (point)))) ) ) + (backward-delete-char 1) ) ) + (when (and (equal 'picolisp-mode major-mode) ; We don't want to screw-up + ; the formatting of other buffers making + ; use of paredit, do we? + (not (picolisp-in-string-p)) ) + (let ((another-line? (save-excursion + (backward-sexp) + (line-number-at-pos) ) ) ) + (if (< another-line? (line-number-at-pos)) + (save-excursion + (backward-char) + (when picolisp-parsep + (insert " ") ) ) ) ) ) ) + +(defun picolisp-current-parse-state () + "Return parse state of point from beginning of defun." + (let ((point (point))) + (beginning-of-defun) + ;; Calling PARSE-PARTIAL-SEXP will advance the point to its second + ;; argument (unless parsing stops due to an error, but we assume it + ;; won't in picolisp-mode). + (parse-partial-sexp (point) point) ) ) + +(defun picolisp-in-string-p (&optional state) + "True if the parse state is within a double-quote-delimited string. +If no parse state is supplied, compute one from the beginning of the + defun to the point." + ;; 3. non-nil if inside a string (the terminator character, really) + (and (nth 3 (or state (picolisp-current-parse-state))) + t ) ) +(defun picolisp-in-comment-p (&optional state) + "True if parse state STATE is within a comment. +If no parse state is supplied, compute one from the beginning of the + defun to the point." + ;; 4. nil if outside a comment, t if inside a non-nestable comment, + ;; else an integer (the current comment nesting) + (and (nth 4 (or state (picolisp-current-parse-state))) + t ) ) + +(defun picolisp-in-char-p (&optional argument) + "True if the point is immediately after a character literal. +A preceding escape character, not preceded by another escape character, + is considered a character literal prefix. (This works for elisp, + Common Lisp, and Scheme.) +Assumes that `picolisp-in-string-p' is false, so that it need not handle + long sequences of preceding backslashes in string escapes. (This + assumes some other leading character token -- ? in elisp, # in Scheme + and Common Lisp.)" + (let ((argument (or argument (point)))) + (and (eq (char-before argument) ?\\) + (not (eq (char-before (1- argument)) ?\\)) ) ) ) + +(add-to-list 'auto-mode-alist '("\\.l$" . picolisp-mode)) + +(require 'tsm) + +(ignore-errors + (when tsm-lock + (font-lock-add-keywords 'picolisp-mode tsm-lock) + (font-lock-add-keywords 'inferior-picolisp-mode tsm-lock) ) ) + +(provide 'picolisp) diff --git a/lib/el/tsm.el b/lib/el/tsm.el @@ -0,0 +1,130 @@ +;;;;;; tsm-mode: Minor mode to display transient symbols in picolisp-mode. +;;;;;; Version: 1.0 + +;;; Copyright (c) 2009, Guillermo R. Palavecino + +;; This file is NOT part of GNU emacs. + +;;;; Contact: +;; For comments, bug reports, questions, etc, you can contact me via IRC +;; to the user named grpala (or armadillo) on irc.freenode.net in the +;; #picolisp channel or via email to the author's nickname at gmail.com +;; +;;;; License: +;; This work is released under the GPL 2 or (at your option) any later +;; version. + +(defvar tsm-face 'tsm-face) + +(defface tsm-face + '((((class color)) + (:inherit font-lock-string-face :underline t) ) ) + "Face for displaying transient symbols in picolisp-mode" + :group 'faces ) + +(defun tsm-revert (beg end) + (remove-text-properties beg end '(display "")) + (remove-text-properties beg end '(face tsm-face)) ) + +(defvar tsm-regex "\"") + +;;; Sorry, but the following 3 function definitions are write-only for now. + +(defun find-opening-dblquote () + (catch 'return + (while (re-search-forward "\\(\"\\)" (line-end-position) t) + (when (save-excursion + (and (ignore-errors (match-beginning 1)) + (not (progn + (goto-char (match-beginning 1)) + (picolisp-in-string-p) ) ) + (progn + (forward-char) + (picolisp-in-string-p) ) ) ) + (throw 'return (point)) ) ) + (backward-char) ) ) + +(defun find-closing-dblquote () + (catch 'return + (while (re-search-forward "\\(\"\\)" (line-end-position) t) + (when (save-excursion + (and (ignore-errors (match-beginning 1)) + (progn + (goto-char (match-beginning 1)) + (picolisp-in-string-p) ) + (not (progn + (forward-char) + (picolisp-in-string-p) ) ) ) ) + (throw 'return (point)) ) ) ) ) + +(defun tsm-line () + (while (and (find-opening-dblquote) + (save-excursion (find-closing-dblquote)) ) + (let ((opening (point)) + (closing (find-closing-dblquote)) ) + (add-text-properties (1- opening) opening '(display "")) + (add-text-properties (1- closing) closing '(display "")) + (add-text-properties (1- opening) closing '(face tsm-face)) + (dotimes (i (- closing opening 1)) + (let ((i (+ i opening))) + (when (and (eq 92 (char-before i)) + (eq 34 (char-before (1+ i))) ) + (add-text-properties (1- i) i '(display "")) ) ) ) ) ) ) + +(defun tsm-change (beg end) + (save-excursion + (goto-char beg) + (while (re-search-forward "^.*\"" (save-excursion + (goto-char end) + (line-end-position) ) t ) + (beginning-of-line) + (tsm-revert (line-beginning-position) (line-end-position)) + (tsm-line) ) ) ) + +(defvar tsm-lock + '(("\"" + (0 (when tsm-mode + (setq global-disable-point-adjustment t) + (save-excursion + (beginning-of-line) + (remove-text-properties (line-beginning-position) (line-end-position) '(display "")) + (tsm-line) ) + nil ) ) ) ) ) + + +;;;###autoload +(define-minor-mode tsm-mode + "Minor mode to display transient symbols like in the terminal repl in picolisp-mode." + :group 'tsm :lighter " *Tsm" + (save-excursion + (save-restriction + (widen) + ;; We erase all the properties to avoid problems. + (tsm-revert (point-min) (point-max)) + + (if tsm-mode + (progn + (if (not (and (not font-lock-mode) (not global-font-lock-mode))) + (font-lock-add-keywords major-mode tsm-lock) + (jit-lock-register 'tsm-change) + (remove-hook 'after-change-functions + 'font-lock-after-change-function t ) + (set (make-local-variable 'font-lock-fontified) t) + + ;; Tell jit-lock how we extend the region to refontify. + (add-hook 'jit-lock-after-change-extend-region-functions + 'font-lock-extend-jit-lock-region-after-change + nil t ) ) + + (setq global-disable-point-adjustment t) ) + (progn + (if (and (not font-lock-mode) (not global-font-lock-mode)) + (jit-lock-unregister 'tsm-change) + (font-lock-remove-keywords major-mode tsm-lock) ) + (setq global-disable-point-adjustment nil) ) ) + + (if font-lock-mode (font-lock-fontify-buffer)) ) ) ) + +;;; Announce + +(provide 'tsm) diff --git a/lib/form.js b/lib/form.js @@ -0,0 +1,352 @@ +/* 20apr10abu + * (c) Software Lab. Alexander Burger + */ + +var FormReq = false; +var HintReq = false; + +if (window.XMLHttpRequest) { + try { + FormReq = new XMLHttpRequest(); + HintReq = new XMLHttpRequest(); + } + catch (e) {} +} +else if (window.ActiveXObject) { // IE + try { + FormReq = new ActiveXObject("Msxml2.XMLHTTP"); + HintReq = new ActiveXObject("Msxml2.XMLHTTP"); + } + catch (e) { + try { + FormReq = new ActiveXObject("Microsoft.XMLHTTP"); + HintReq = new ActiveXObject("Microsoft.XMLHTTP"); + } + catch (e) {} + } +} + +var Queue = new Array(); +var Btn = new Array(); +var Key, InBtn, Auto; + +function inBtn(flg) {InBtn = flg;} + +function formKey(event) { + Key = event.keyCode; + return true; +} + +function fldChg(field) { + if (!InBtn && Key != 13) + post(field.form); + return true; +} + +function doBtn(btn) { + Btn.push(btn); + return true; +} + +/*** Form submit ***/ +function doPost(form) { + for (var i = 0; ; ++i) { + if (i == Btn.length) + return true; + if (Btn[i].form == form) + break; + } + return post(form); +} + +function post(form) { + var i, j, url, data; + + if (!FormReq) + return true; + if (FormReq.readyState > 0 && FormReq.readyState < 4) { + Queue.push(form); + return false; + } + form.style.cursor = "wait"; + url = form.action.split("~"); + try {FormReq.open("POST", url[0] + "~@jsForm?" + url[1]);} + catch (e) {return true;} + + FormReq.onreadystatechange = function() { + if (FormReq.readyState == 4 && FormReq.status == 200) { + if (FormReq.responseText == "T") { + Queue.length = 0; + form.submit(); + } + else { + var txt = FormReq.responseText.split("&"); + + if (txt[0]) { + var r = txt[0].split(":"); + + if (Auto) + window.clearTimeout(Auto); + if (r[1]) + Auto = window.setTimeout("document.getElementById(\"" + r[0] + "\").click()", r[1]); + } + for (i = 1; 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"); + + a.href = decodeURIComponent(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; + fld.href = decodeURIComponent(txt[i++].substr(1)); + } + } + else { + if (fld.type == "checkbox") { + fld.checked = val != ""; + document.getElementsByName(fld.name)[0].value = ""; + } + 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; + fld.scrollTop = fld.scrollHeight; + } + fld.disabled = false; + if (i == txt.length) + break; + if (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; + if (fld.type == "checkbox" && fld.checked) + document.getElementsByName(fld.name)[0].value = "T"; + ++i; + } + } + 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"); + + a.href = decodeURIComponent(txt[i]); + a.appendChild(img); + node.appendChild(a); + } + ++i; + break; + + case 2: // '?' + fld.title = decodeURIComponent(txt[i++].substr(1)); + break; + } + } + } + } + form.style.cursor = ""; + if (Queue.length > 0) + post(Queue.shift()); + } + } + + data = ""; + for (i = 0; i < Btn.length;) + if (Btn[i].form != form) + ++i; + else { + data += (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); + } + } + try {FormReq.send(data);} + catch (e) { + FormReq.abort(); + return true; + } + return false; +} + + +/*** Hints ***/ +var Hint, Pos; + +function doHint(field) { + var i, url, data; + + Hint = null; + if (!HintReq) + return true; + if (HintReq.readyState > 0 && HintReq.readyState < 4) + return false; + if ((i = field.id.lastIndexOf("-")) < 0) + return true; + url = field.form.action.split("~"); + try {HintReq.open("POST", url[0] + "~@jsHint?" + field.id.substr(i+1));} + catch (e) {return true;} + HintReq.onreadystatechange = function() { + if (HintReq.readyState == 4 && HintReq.status == 200) { + Hint = HintReq.responseText.split("&"); + for (i = 0; i < Hint.length; ++i) + Hint[i] = decodeURIComponent(Hint[i]); + } + } + 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 {HintReq.send(data);} + catch (e) {HintReq.abort();} + Pos = -1; + return true; +} + +function hintKey(field, event, coy) { + var beg = field.selectionStart; + var end = field.selectionEnd; + var i; + + if (Hint.length > 0) { + if (event.keyCode == 19) { // Pause/Break + if (beg != end) + return true; + for (Pos = beg; Pos > 0 && !field.value.charAt(Pos-1).match(/\s/); --Pos); + if ((i = findHint(field.value.substring(Pos, beg))) < 0) + Pos = -1; + else + setHint(field, beg, end, i); + return false; + } + if (event.keyCode == 38 || event.keyCode == 40) { // Up or Down + if (beg == end) + return true; + if ((i = findHint(field.value.substring(Pos, end))) >= 0) + setHint(field, beg, end, nextHint(field.value.substring(Pos, beg), i, event.keyCode==38? -1 : +1)); + return false; + } + if (!coy) { + if (Pos < 0) + for (Pos = beg; Pos > 0 && !field.value.charAt(Pos-1).match(/\s/); --Pos); + if ((i = findHint(field.value.substring(Pos, beg) + String.fromCharCode(event.charCode || event.keyCode))) < 0) + Pos = -1; + else { + setHint(field, beg+1, end, i); + return false; + } + } + } + return true; +} + +function findHint(str) { + str = str.toLowerCase(); + var len = str.length; + for (var i = 0; i < Hint.length; ++i) + if (Hint[i].substr(0,len).toLowerCase() == str) + return i; + return -1; +} + +function nextHint(str, i, n) { + str = str.toLowerCase(); + var len = str.length; + do { + if (n < 0) { + if ((i += n) < 0) + i = Hint.length - 1; + } + else { + if ((i += n) >= Hint.length) + i = 0; + } + } while (Hint[i].substr(0,len).toLowerCase() != str); + return i; +} + +function setHint(field, beg, end, i) { + field.value = field.value.substr(0,Pos) + Hint[i] + field.value.substring(end, field.value.length); + field.setSelectionRange(beg, Pos+Hint[i].length); + field.onblur = function() {fldChg(field)}; + field.onchange = false; +} diff --git a/lib/form.l b/lib/form.l @@ -0,0 +1,2069 @@ +# 21apr10abu +# (c) Software Lab. Alexander Burger + +# *PRG *Top *Gui *Btn *Get *Got *Form *Evt *Lock *Spans +# "*Cnt" "*Lst" "*App" "*Err" "*Foc" "*Post2" "*Stat" "*Ix" "*Chart" "*Cho" + +(allow (path "@img/") T) +(push1 '*JS (allow (path "@lib/form.js"))) +(mapc allow '(*Gui *Get *Got *Form *Evt "@jsForm" "@jsHint")) + +(one "*Cnt") +(off "*Lst" "*Post2" "*Cho") + +(de *Throbber + ("+---" "-+--" "--+-" "---+" "--+-" "-+--" .) ) + +# Define GUI form +(de form ("Attr" . "Prg") + (inc '*Form) + (let "App" + (if *PRG + (get "*Lst" (- "*Cnt" *Get) *Form) + (prog1 (setq *Top (new NIL NIL 'able T 'evt 0)) + (conc + (get "*Lst" (- "*Cnt" *Get)) + (cons *Top) ) ) ) + (let "Lst" (get "*Lst" (- "*Cnt" *Get) 1) + (for ("F" . "L") "Lst" + (let *Form (- "F" (length "Lst")) + (cond + ((and (== *PRG (car "L")) (memq "App" (get *PRG 'top))) + (apply "form" "L") ) + ((or (== *PRG "App") (memq "App" (get *PRG 'top))) + (if (get "L" 1 'top) + (apply "form" "L") + (put (car "L") 'top (cons *PRG (get *PRG 'top))) + (let *PRG NIL (apply "form" "L")) ) ) ) ) ) ) + ("form" "App" "Attr" "Prg") ) ) + +(de "form" ("*App" "Attr" "Prg") + (with "*App" + (job (: env) + (<post> "Attr" (urlMT *Url *Menu *Tab *ID) + (<hidden> '*Get *Get) + (<hidden> '*Form *Form) + (<hidden> '*Evt (: evt)) + (zero "*Ix") + (off "*Chart") + (if *PRG + (let gui + '(() + (with (get "*App" 'gui (inc '"*Ix")) + (for E "*Err" + (when (== This (car E)) + (<div> 'err + (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 + '(@ + (inc '"*Ix") + (with + (cond + ((pair (next)) (pass new @)) + ((not (arg)) (pass new)) + ((num? (arg)) + (ifn "*Chart" + (quit "no chart" (rest)) + (with "*Chart" + (let (I (arg) L (last (: gui))) + (when (get L I) + (inc (:: rows)) + (conc (: gui) + (list (setq L (need (: cols)))) ) ) + (let Fld (pass new) + (set (nth L I) Fld) + (and (get Fld 'chg) (get Fld 'able) (=: lock)) + (set> Fld + (get + ((: put) + (get (nth (: data) (: ofs)) (: rows)) + (+ (: ofs) (: rows) -1) ) + I ) + T ) + (put Fld 'chart (list This (: rows) I)) + Fld ) ) ) ) ) + ((get "*App" (arg)) (quit "gui conflict" (arg))) + (T (put "*App" (arg) (pass new))) ) + (=: home gui (conc (: home gui) (cons This))) + (unless (: chart) (init> This)) + (when (: id) + (let *Gui (val "*App") + (show> This (cons '*Gui (: id))) ) ) + This ) ) + (htPrin "Prg") ) ) ) + (--) + (eval (: show)) + (=: show) ) ) ) + +# Disable form +(de disable (Flg) + (and Flg (=: able)) ) + +# Handle form actions +(de action Prg + (off "*Foc") + (or *PRG "*Post2" (off "*Err")) + (catch "stop" + (nond + (*Post + (unless (and *PRG (= *Form (car *Got)) (= *Get (cadr *Got))) + (pushForm (cons)) ) + (_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 '"*Lst" L) + (and (nth "*Lst" 99) (con @)) + (setq *Get "*Cnt") + (inc '"*Cnt") ) + +(de _doForm () + (one *Form) + (run Prg 2) + (setq "*Stat" + (cons + (pair "*Err") + (copy (get "*Lst" (- "*Cnt" *Get))) ) ) ) + +(de jsForm (Url) + (if (or *PRG (not *Post)) + (noContent) + (setq *Url Url Url (chop Url)) + (let action + '(Prg + (off "*Err") + (with (postForm) + (catch "stop" + (postGui) + (httpHead "text/plain; charset=utf-8") + (if + (and + (= (car "*Stat") "*Err") + (= (cdr "*Stat") (get "*Lst" (- "*Cnt" *Get))) ) + (ht:Out *Chunked + (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))) ) + ((disallowed) + (msg *Url " not allowed") + (http404) ) + ((= '@ (car Url)) + ((intern (pack (cdr Url)))) ) + ((tail '("." "l") Url) + (load *Url) ) ) ) ) ) ) + +(de postForm () + (let? Lst (get "*Lst" (- "*Cnt" (setq *Get (format *Get)))) + (setq + *Form (format *Form) + *Evt (format *Evt) + *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)) ) ) ) ) + +(de postGui () + (if "*Post2" + (off *Gui "*Post2") + (let *Btn NIL + (for G *Gui + (and (lt0 (car G)) (setq *Btn (cdr G))) + (con (assoc (car G) (val *PRG)) (cdr G)) ) + (off *Gui) + (job (: env) + (for This (: gui) + (cond + ((not (: id)) (setq "*Chart" This)) + ((chk> This) (err @)) + ((or (: rid) (: home able)) + (set> This (val> This) T) ) ) ) + (for This (: gui) + (cond + ((: id)) + ((chk> (setq "*Chart" This)) (err @)) + ((or (: rid) (: home able)) + (set> This (val> This)) ) ) ) + (if (pair "*Err") + (and *Lock (with (caar "*Err") (tryLock *Lock))) + (finally + (when *Lock + (if (lock @) + (=: able (off *Lock)) + (sync) ) ) + (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 err (Exe) + (cond + ((=T Exe) (on "*Err")) + ((nT "*Err") (queue '"*Err" (cons This Exe))) ) ) + +(de url (Url . @) + (when Url + (off *PRG) + (redirect (baseHRef) *SesId Url '? + (pack + (make + (loop + (and + (sym? (next)) + (= `(char '*) (char (arg))) + (link (arg) '=) + (next) ) + (link (ht:Fmt (arg))) + (NIL (args)) + (link '&) ) ) ) ) + (throw "stop") ) ) + +# Actve <span> elements +(de span Args + (def (car Args) + (list NIL + (list '<span> + (lit (cons 'id (car Args))) + (cons 'ht:Prin (cdr Args)) ) ) ) + (push '*Spans Args) ) + +(span expires + (pack + "TimeOut" + " " + (tim$ (% (+ (time) (/ (cadr (assoc -1 *Run)) 1000)) 86400)) ) ) + +# Return chart property +(de chart @ + (pass get "*Chart") ) + +# Table highlighting +(daemon '<table> + (on "rowF") ) + +(de alternating () + (onOff "rowF") ) + +# REPL form +(de repl (Attr) + (form Attr + (gui 'view '(+FileField) '(tmp "repl") 80 25) + (--) + (gui 'line '(+Focus +TextField) 64 ":") + (gui '(+JS +Button) "eval" + '(let Str (val> (: home line)) + (out (pack "+" (tmp "repl")) + (prinl ": " Str) + (catch '(NIL) + (let Res (in "/dev/null" (eval (any Str))) + (prin "-> ") + (println Res) ) ) + (when *Msg (prinl @) (off *Msg)) ) + (clr> (: home line)) ) ) + (gui '(+JS +Button) "clear" + '(clr> (: home view)) ) ) ) + + +# Dialogs +(de _dlg (Attr Env) + (let L (get "*Lst" (- "*Cnt" *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) ) + +(de alert (Env . Prg) + (_dlg 'alert Env) ) + +(de note (Str Lst) + (alert (env '(Str Lst)) + (<span> 'note Str) + (--) + (for S Lst (<br> S)) + (okButton) ) ) + +(de ask (Str . Prg) + (alert (env '(Str Prg)) + (<span> 'ask Str) + (--) + (yesButton (cons 'prog Prg)) + (noButton) ) ) + +(de diaform (Lst . Prg) + (if (and *PRG (not (: diaform))) + (_dlg 'dialog (env Lst)) + (=: env (env Lst)) + (=: diaform T) + (run Prg 1) ) ) + +(de saveButton (Exe) + (gui '(+Button) ,"Save" Exe) ) + +(de closeButton (Lbl Exe) + (when (get "*App" 'top) + (gui '(+Rid +Close +Button) Lbl Exe) ) ) + +(de okButton (Exe) + (when (get "*App" 'top) + (if (=T Exe) + (gui '(+Force +Close +Button) T "OK") + (gui '(+Close +Button) "OK" Exe) ) ) ) + +(de cancelButton () + (when (get "*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 "*Lst" (- "*Cnt" *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) + (pack "@&+" (ht:Fmt (sesId (mkUrl @)))) ) + (T "@") ) ) + +(dm show> ("Var") + (if (: act) + (super "Var") + (<style> (cons 'id (pack "i" *Form '- (: id))) + (if (try (: msg) (: obj) 1) + (<tip> "-->" (<href> "@" (mkUrl @))) + (<span> *Style "@") ) ) ) ) + + +(class +Hint +ChoButton) +# ttl hint + +(dm T (Ttl Exe) + (=: ttl Ttl) + (=: hint Exe) + (super + '(dialog (env 'Ttl (eval (: ttl)) 'Lst (eval (: hint)) 'Dst (field 1)) + (<table> 'chart Ttl '((btn) NIL) + (for X Lst + (<row> NIL + (gui '(+Close +PickButton) + (list 'set> 'Dst + (if (get Dst 'dy) + (list 'pack '(str> Dst) (fin X)) + (lit (fin X)) ) ) ) + (ht:Prin (if (atom X) X (car X))) ) ) ) + (cancelButton) ) ) ) + + +(class +Coy) + +(dm T @ + (=: coy T) + (pass extra) ) + + +(class +Hint0) +# coy + +(dm show> ("Var") + (<style> + (list + '("onfocus" . "doHint(this)") + (cons + "onkeypress" + (pack "return hintKey(this,event" (and (: coy) ",true") ")")) ) + (extra "Var") ) ) + +(de jsHint (Ix) + (httpHead "text/plain; charset=utf-8") + (ht:Out *Chunked + (let? Lst (get "*Lst" (- "*Cnt" (format *Get))) + (let? L + (try 'hint> + (get + (if (gt0 (format *Form)) + (get Lst @) + (get Lst 1 (+ (length (car Lst)) (format *Form)) 1) ) + 'gui + (format Ix) ) ) + (prin + (ht:Fmt + (if (atom (car L)) + (car L) + (caar L) ) ) ) + (for X (cdr L) + (prin '& + (ht:Fmt (if (atom X) X (car X))) ) ) ) ) ) ) + + +(class +Hint1 +Hint0) +# hint + +(dm T (Exe . @) + (=: hint Exe) + (pass extra) ) + +(dm hint> () + (eval (: hint)) ) + + +(class +Hint2 +Hint0) + +(dm hint> () + (with (field -1) + (eval (: hint)) ) ) + + +(class +Txt) +# txt + +(dm T (Fun . @) + (=: txt Fun) + (pass extra) ) + +(dm txt> (Val) + ((: txt) Val) ) + + +(class +Set) +# set + +(dm T (Fun . @) + (=: set Fun) + (pass extra) ) + +(dm set> (Val Dn) + (extra ((: set) Val) Dn) ) + + +(class +Val) +# val + +(dm T (Fun . @) + (=: val Fun) + (pass extra) ) + +(dm val> () + ((: val) (extra)) ) + + +(class +Fmt) +# set val + +(dm T (Fun1 Fun2 . @) + (=: set Fun1) + (=: val Fun2) + (pass extra) ) + +(dm set> (Val Dn) + (extra ((: set) Val) Dn) ) + +(dm val> () + ((: val) (extra)) ) + + +(class +Chg) +# old new + +(dm T (Fun . @) + (=: new Fun) + (pass extra) ) + +(dm set> (Val Dn) + (extra (=: old Val) Dn) ) + +(dm val> () + (let Val (extra) + (if (= (: old) Val) + Val + ((: new) Val) ) ) ) + + +(class +Upd) +# upd + +(dm T (Exe . @) + (=: upd Exe) + (pass extra) ) + +(dm upd> () + (set> This (eval (: upd))) ) + + +(class +Init) +# init + +(dm T (Val . @) + (=: init Val) + (pass extra) ) + +(dm init> () + (set> This (: init)) ) + + +(class +Dflt) +# cue + +(dm T (Exe . @) + (=: cue Exe) + (pass extra) ) + +(dm set> (Val Dn) + (extra (or Val (eval (: cue))) Dn) ) + +(dm val> () + (let Val (extra) + (unless (= Val (eval (: cue))) Val) ) ) + + +(class +Cue +Dflt) + +(dm T (Str . @) + (pass super (pack "<" Str ">")) ) + +(dm show> ("Var") + (<style> + (let V (eval (: cue)) + (list + (cons "onclick" (pack "if (this.value=='" V "') this.value=''")) + (cons "onblur" (pack "if (this.value=='') this.value='" V "'")) ) ) + (extra "Var") ) ) + + +(class +Trim) + +(dm val> () + (pack (trim (chop (extra)))) ) + + +(class +Enum) +# enum + +(dm T (Lst . @) + (=: enum Lst) + (pass extra) ) + +(dm set> (N Dn) + (extra (get (: enum) N) Dn) ) + +(dm val> () + (index (extra) (: enum)) ) + + +(class +Map) +# map + +(dm T (Lst . @) + (=: map Lst) + (pass extra) ) + +(dm set> (Val Dn) + (extra + (if + (find + '((X) (= Val (cdr X))) + (: map) ) + (val (car @)) + Val ) + Dn ) ) + +(dm val> () + (let Val (extra) + (if + (find + '((X) (= Val (val (car X)))) + (: map) ) + (cdr @) + Val ) ) ) + + +# Case conversions +(class +Uppc) + +(dm val> () + (uppc (extra)) ) + + +(class +Lowc) + +(dm set> (Val Dn) + (extra (lowc Val) Dn) ) + +(dm val> () + (lowc (extra)) ) + + +# Field enable/disable +(de able () + (when (or (: rid) (: home able)) + (eval (: able)) ) ) + +(class +Able) + +(dm T (Exe . @) + (pass extra) + (when (: able) + (=: able + (cond + ((=T (: able)) Exe) + ((and (pair (: able)) (== 'and (car @))) + (cons 'and Exe (cdr (: able))) ) + (T (list 'and Exe (: able))) ) ) ) ) + + +(class +Lock +Able) + +(dm T @ + (pass super NIL) ) + + +(class +View +Lock +Upd) + + +# Escape from form lock +(class +Rid) +# rid + +(dm T @ + (=: rid T) + (pass extra) ) + + +(class +Align) + +(dm T @ + (=: align T) + (pass extra) ) + + +(class +Limit) +# lim + +(dm T (Exe . @) + (=: lim Exe) + (pass extra) ) + + +(class +Var) +# var + +(dm T (Var . @) + (=: var Var) + (pass extra) ) + +(dm set> (Val Dn) + (extra (set (: var) Val) Dn) ) + +(dm upd> () + (set> This (val (: var))) ) + + +(class +Chk) +# chk + +(dm T (Exe . @) + (=: chk Exe) + (pass extra) ) + +(dm chk> () + (eval (: chk)) ) + + +(class +Tip) +# tip + +(dm T (Exe . @) + (=: tip Exe) + (pass extra) ) + +(dm show> ("Var") + (<tip> (eval (: tip)) (extra "Var")) ) + +(dm js> () + (pack (extra) "&?" (ht:Fmt (eval (: tip)))) ) + + +(class +Tiny) + +(dm show> ("Var") + (<style> 'tiny (extra "Var")) ) + + +(class +Click) +# clk + +(dm T (Exe . @) + (=: clk Exe) + (pass extra) ) + +(dm show> ("Var") + (extra "Var") + (and + (atom "*Err") + (eval (: clk)) + (javascript NIL + "window.setTimeout(\"document.getElementById(\\\"" + "i" *Form '- (: id) + "\\\").click()\"," + @ + ")" ) ) ) + + +(class +Focus) + +(dm show> ("Var") + (extra "Var") + (when (and (able) (not "*Foc")) + (on "*Foc") + (javascript NIL + "window.setTimeout(\"document.getElementById(\\\"" + "i" *Form '- (: id) + "\\\").focus()\",420)" ) ) ) + + +### Styles ### +(class +Style) +# style + +(dm T (Exe . @) + (=: style Exe) + (pass extra) ) + +(dm show> ("Var") + (<style> (eval (: style)) (extra "Var")) ) + +(dm js> () + (pack (extra) "&#" (eval (: style))) ) + + +# Monospace font +(class +Mono) + +(dm show> ("Var") + (<style> "mono" (extra "Var")) ) + +(dm js> () + (pack (extra) "&#mono") ) + + +# Signum field +(class +Sgn) + +(dm show> ("Var") + (<style> (and (lt0 (val> This)) "red") (extra "Var")) ) + +(dm js> () + (pack (extra) "&#" (and (lt0 (val> This)) "red")) ) + + +### Form field classes ### +(de showFld "Prg" + (when (: lbl) + (ht:Prin (eval @)) + (<nbsp>) ) + (style (cons 'id (pack "i" *Form '- (: id))) "Prg") ) + + +(class +gui) +# home id chg able chart + +(dm T () + (push (=: home "*App") (cons (=: id "*Ix"))) + (=: able T) ) + +(dm txt> (Val)) + +(dm set> (Val Dn)) + +(dm clr> () + (set> This) ) + +(dm val> ()) + +(dm init> () + (upd> This) ) + +(dm upd> ()) + +(dm chk> ()) + + +(class +field +gui) + +(dm T () + (super) + (=: chg T) ) + +(dm txt> (Val) + Val ) + +(dm js> () + (let S (ht:Fmt (cdr (assoc (: id) (val *PRG)))) + (if (able) S (pack S "&=")) ) ) + +(dm set> (Str Dn) + (con (assoc (: id) (val (: home))) Str) + (and (not Dn) (: chart) (set> (car @) (val> (car @)))) ) + +(dm str> () + (cdr (assoc (: id) (val (: home)))) ) + +(dm val> () + (str> This) ) + + +# Get field +(de field (X . @) + (if (sym? X) + (pass get (: home) X) + (pass get (: home gui) (+ X (abs (: id)))) ) ) + +# Get current chart data row +(de row (D) + (+ (: chart 1 ofs) (: chart 2) -1 (or D 0)) ) + +(de curr @ + (pass get (: chart 1 data) (row)) ) + +(de prev @ + (pass get (: chart 1 data) (row -1)) ) + + +(class +Button +gui) +# img lbl alt act js + +# ([T] lbl [alt] act) +(dm T @ + (and (=: img (=T (next))) (next)) + (=: lbl (arg)) + (let X (next) + (ifn (args) + (=: act X) + (=: alt X) + (=: act (next)) ) ) + (super) + (set + (car (val "*App")) + (=: id (- (: id))) ) ) + +(dm js> () + (if (able) + (let Str (ht:Fmt (eval (: lbl))) + (if (: img) (sesId Str) Str) ) + (let Str (ht:Fmt (or (eval (: alt)) (eval (: lbl)))) + (pack (if (: img) (sesId Str) Str) "&=") ) ) ) + +(dm show> ("Var") + (<style> (cons 'id (pack "i" *Form '- (: id))) + (if (able) + (let Str (eval (: lbl)) + ((if (: img) <image> <submit>) Str "Var" NIL (: js)) ) + (let Str (or (eval (: alt)) (eval (: lbl))) + ((if (: img) <image> <submit>) Str "Var" T (: js)) ) ) ) ) + +(dm act> () + (and (able) (eval (: act))) ) + + +(class +JS) + +(dm T @ + (=: js T) + (pass extra) ) + + +(class +Auto +JS) +# auto + +(dm T (Fld Exe . @) + (=: auto (cons Fld Exe)) + (pass super) ) + +(dm act> () + (when (able) + (=: home auto + (cons + (eval (car (: auto))) + (eval (cdr (: auto))) ) ) + (extra) ) ) + + +(class +DnButton +Tiny +Rid +JS +Able +Button) + +(dm T (Exe Lbl) + (super + '(> (length (chart 'data)) (chart 'ofs)) + (or Lbl ">") + (list 'scroll> (lit "*Chart") Exe) ) ) + + +(class +UpButton +Tiny +Rid +JS +Able +Button) + +(dm T (Exe Lbl) + (super + '(> (chart 'ofs) 1) + (or Lbl "<") + (list 'scroll> (lit "*Chart") (list '- Exe)) ) ) + +(class +GoButton +Tiny +Rid +JS +Able +Button) + +(dm T (Exe Lbl) + (super + (list 'and + (list '>= '(length (chart 'data)) Exe) + (list '<> '(chart 'ofs) Exe) ) + Lbl + (list 'goto> (lit "*Chart") Exe) ) ) + +(de scroll (N Flg) + (when Flg + (gui '(+Tip +GoButton) ,"Go to first line" 1 "|<") ) + (gui '(+Tip +UpButton) ,"Scroll up one page" N "<<") + (gui '(+Tip +UpButton) ,"Scroll up one line" 1) + (gui '(+Tip +DnButton) ,"Scroll down one line" 1) + (gui '(+Tip +DnButton) ,"Scroll down one page" N ">>") + (when Flg + (gui '(+Tip +GoButton) ,"Go to last line" + (list '- '(length (chart 'data)) (dec N)) + ">|" ) + (<nbsp>) + (gui '(+View +TextField) + '(let? Len (gt0 (length (chart 'data))) + (pack + (chart 'ofs) + "-" + (min Len (dec (+ (chart 'ofs) (chart 'rows)))) + " / " + Len ) ) ) ) ) + + +# Delete row +(class +DelRowButton +Tiny +JS +Able +Tip +Button) +# del exe + +(dm T (Txt Exe) + (=: del Txt) + (=: exe Exe) + (super '(nth (: chart 1 data) (row)) ,"Delete row" "x" + '(if (or (: home del) (not (curr))) + (_delRow (: exe)) + (ask (if (: del) (eval @) ,"Delete row?") + (with (: home btn) + (=: home del T) + (_delRow (: exe)) ) ) ) ) ) + +(de _delRow (Exe) + (eval Exe) + (set> (: chart 1) (remove (row) (: chart 1 data))) ) + +# Move row up +(class +BubbleButton +Tiny +JS +Able +Tip +Button) + +(dm T () + (super + '(> (: chart 2) 1) + ,"Shift row up" + "\^" + '(let L (: chart 1 data) + (set> (: chart 1) + (conc + (cut (row -2) 'L) + (cons (cadr L)) + (cons (car L)) + (cddr L) ) ) ) ) ) + + +(class +ClrButton +JS +Tip +Button) +# clr + +(dm T (Lbl Lst . @) + (=: clr Lst) + (pass super ,"Clear all input fields" Lbl + '(for X (: clr) + (if (atom X) + (clr> (field X)) + (set> (field (car X)) (eval (cdr X))) ) ) ) ) + + +(class +ShowButton +Button) + +(dm T (Flg Exe) + (super ,"Show" + (list '=: 'home 'show (lit Exe)) ) + (and Flg (=: home show Exe)) ) + + +(class +Checkbox +field) +# lbl + +# ([lbl]) +(dm T (Lbl) + (=: lbl Lbl) + (super) ) + +(dm txt> (Val) + (if Val ,"Yes" ,"No") ) + +(dm show> ("Var") + (showFld (<check> "Var" (not (able)))) ) + +(dm set> (Val Dn) + (super (bool Val) Dn) ) + +(dm val> () + (bool (super)) ) + + +(class +Radio +field) # Inited by Tomas Hlavaty <kvietaag@seznam.cz> +# grp val lbl + +# (grp val [lbl]) +(dm T (Grp Val Lbl) + (super) + (=: grp (if Grp (field @) This)) + (=: val Val) + (=: lbl Lbl) ) + +(dm show> ("Var") + (showFld + (<radio> + (cons '*Gui (: grp id)) + (: val) + (not (able)) ) ) ) + +(dm js> () + (pack + (ht:Fmt (: val)) + "&" (= (: val) (str> (: grp))) + (unless (able) "&=") ) ) + +(dm set> (Val Dn) + (when (== This (: grp)) + (super Val Dn) ) ) + + +(class +TextField +field) +# dx dy lst lbl lim align + +# ([dx [dy] [lbl]]) +# ([lst [lbl]]) +(dm T (X . @) + (nond + ((num? X) + (=: lst X) + (=: lbl (next)) ) + ((num? (next)) + (=: dx X) + (=: lbl (arg)) ) + (NIL + (=: dx X) + (=: dy (arg)) + (=: lbl (next)) ) ) + (super) + (or (: dx) (: lst) (=: chg)) ) + +(dm show> ("Var") + (showFld + (cond + ((: dy) + (<area> (: dx) (: dy) "Var" (not (able))) ) + ((: dx) + (<field> + (if (: align) (- (: dx)) (: dx)) + "Var" + (eval (: lim)) + (not (able)) ) ) + ((: lst) + (let + (L + (mapcar + '(("X") + (if (atom "X") + (val "X") + (cons (val (car "X")) (val (cdr "X"))) ) ) + @ ) + S (str> This) ) + (<select> + (if (or (member S L) (assoc S L)) + L + (cons S L) ) + "Var" + (not (able)) ) ) ) + (T + (<style> (cons 'id (pack "i" *Form '- (: id))) + (<span> *Style + (if (str> This) (ht:Prin @) (<nbsp>)) ) ) ) ) ) ) + + +(class +LinesField +TextField) + +(dm set> (Val Dn) + (super (glue "^J" Val) Dn) ) + +(dm val> () + (split (chop (super)) "^J") ) + + +(class +ListTextField +TextField) +# split + +(dm T (Lst . @) + (=: split Lst) + (pass super) ) + +(dm set> (Val Dn) + (super (glue (car (: split)) Val) Dn) ) + +(dm val> () + (extract pack + (apply split (: split) (chop (super))) ) ) + + +# Password field +(class +PwField +TextField) + +(dm show> ("Var") + (showFld + (<passwd> (: dx) "Var" (eval (: lim)) (not (able))) ) ) + + +# Upload field +(class +UpField +TextField) + +(dm show> ("Var") + (showFld + (<upload> (: dx) "Var" (not (able))) ) ) + + +# Symbol fields +(class +SymField +TextField) + +(dm val> () + (let S (super) + (and (<> "-" S) (intern S)) ) ) + +(dm set> (Val Dn) + (super (name Val) Dn) ) + + +(class +numField +Align +TextField) +# scl + +(dm chk> () + (and + (str> This) + (not (format @ (: scl) *Sep0 *Sep3)) + ,"Numeric input expected" ) ) + + +(class +NumField +numField) + +(dm txt> (Val) + (format Val) ) + +(dm set> (Val Dn) + (super (format Val) Dn) ) + +(dm val> () + (format (super) NIL *Sep0 *Sep3) ) + + +(class +FixField +numField) + +(dm T (N . @) + (=: scl N) + (pass super) ) + +(dm txt> (Val) + (format Val (: scl) *Sep0 *Sep3) ) + +(dm set> (Val Dn) + (super (format Val (: scl) *Sep0 *Sep3) Dn) ) + +(dm val> () + (let S (super) + (format + (if (sub? *Sep0 S) S (pack S *Sep0)) + (: scl) + *Sep0 + *Sep3 ) ) ) + + +(class +AtomField +Mono +TextField) + +(dm set> (Val Dn) + (super + (if (num? Val) + (align (: dx) (format Val)) + Val ) + Dn ) ) + +(dm val> () + (let S (super) + (or (format S) S) ) ) + + +(class +DateField +TextField) + +(dm txt> (Val) + (datStr Val) ) + +(dm set> (Val Dn) + (super (datStr Val) Dn) ) + +(dm val> () + (expDat (super)) ) + +(dm chk> () + (and + (str> This) + (not (val> This)) + ,"Bad date format" ) ) + + +(class +TimeField +TextField) + +(dm txt> (Val) + (tim$ Val (> (: dx) 6)) ) + +(dm set> (Val Dn) + (super (tim$ Val (> (: dx) 6)) Dn) ) + +(dm val> () + ($tim (super)) ) + +(dm chk> () + (and + (str> This) + (not (val> This)) + ,"Bad time format" ) ) + + +(class +Icon) +# icon url + +(dm T (Exe Url . @) + (=: icon Exe) + (=: url Url) + (pass extra) ) + +(dm js> () + (pack (extra) "&*" + (ht:Fmt (sesId (eval (: icon)))) '& + (and (eval (: url)) (ht:Fmt (sesId @))) ) ) + +(dm show> ("Var") + (prin "<table cellspacing=\"0\" cellpadding=\"0\"><td>") + (extra "Var") + (prin "</td><td>") + (<img> (eval (: icon)) 'icon (eval (: url))) + (prinl "</td></table>") ) + + +(class +FileField +TextField) +# file org + +(dm T (Exe . @) + (=: file Exe) + (pass super) ) + +(dm set> (Val Dn) + (and + (<> Val (: org)) + (eval (: file)) + (out @ (prin (=: org Val))) ) + (super Val Dn) ) + +(dm upd> () + (set> This + (=: org + (let? F (eval (: file)) + (and (info F) (in F (till NIL T))) ) ) ) ) + + +(class +Url) +# url + +(dm T (Fun . @) + (=: url Fun) + (pass extra) ) + +(dm js> () + (if2 (or (: dx) (: lst)) (txt> This (val> This)) + (pack (extra) "&*" (ht:Fmt (sesId `(path "@img/go.png"))) '& (ht:Fmt (sesId ((: url) @)))) + (pack (extra) "&*" (ht:Fmt (sesId `(path "@img/no.png"))) '&) + (pack @ "&+" (ht:Fmt (sesId ((: url) @)))) + (extra) ) ) + +(dm show> ("Var") + (cond + ((or (: dx) (: lst)) + (prin "<table cellspacing=\"0\" cellpadding=\"0\"><td>") + (extra "Var") + (prin "</td><td title=\"-->\">") + (if (val> This) + (<img> `(path "@img/go.png") 'url ((: url) (txt> This @))) + (<img> `(path "@img/no.png")) ) + (prinl "</td></table>") ) + ((val> This) + (showFld (<href> @ ((: url) (txt> This @)))) ) + (T (extra "Var")) ) ) + + +(class +HttpField +Url +TextField) + +(dm T @ + (pass super + '((S) (if (sub? "://" S) S (pack "http://" S))) ) ) + + +(class +MailField +Url +TextField) + +(dm T @ + (pass super '((S) (pack "mailto:" S))) ) + + +(class +TelField +TextField) + +(dm txt> (Val) + (telStr Val) ) + +(dm set> (Val Dn) + (super (telStr Val) Dn) ) + +(dm val> () + (expTel (super)) ) + +(dm chk> () + (and + (str> This) + (not (val> This)) + ,"Bad phone number format" ) ) + + +(class +SexField +Map +TextField) + +(dm T (Lbl) + (super + '((,"male" . T) (,"female" . 0)) + '(NIL ,"male" ,"female") + Lbl ) ) + + +(class +JsField +gui) +# js str + +(dm T (Nm) + (super) + (=: js Nm) ) + +(dm show> ("Var")) + +(dm js> () + (pack (ht:Fmt NIL (: str) (: js))) ) + +(dm set> (Val Dn) + (=: str Val) ) + + +### GUI charts ### +(class +Chart) +# home gui rows cols ofs lock put get data clip + +# (cols [put [get]]) +(dm T (N Put Get) + (setq "*Chart" This) + (put (=: home "*App") 'chart + (conc (get "*App" 'chart) (cons This)) ) + (=: rows 1) + (when N + (=: gui (list (need (=: cols N)))) ) + (=: ofs 1) + (=: lock T) + (=: put (or Put prog1)) + (=: get (or Get prog1)) ) + +(dm put> () + (let I (: ofs) + (mapc + '((G D) + (unless (memq NIL G) + (mapc 'set> G ((: put) D I) '(T .)) ) + (inc 'I) ) + (: gui) + (nth (: data) I) ) ) ) + +(dm get> () + (and + (or (: rid) (: home able)) + (not (: lock)) + (let I (: ofs) + (map + '((G D) + (set D + (trim + ((: get) + (mapcar 'val> (car G)) + (car D) + (car G) ) ) ) + (mapc 'set> + (car G) + ((: put) (car D) I) + '(T .) ) + (inc 'I) ) + (: gui) + (nth + (=: data + (need (- 1 I (: rows)) (: data)) ) + I ) ) + (=: data (trim (: data))) ) ) ) + +(dm scroll> (N) + (get> This) + (unless (gt0 (inc (:: ofs) N)) + (=: ofs 1) ) + (put> This) ) + +(dm goto> (N) + (get> This) + (=: ofs (max 1 N)) + (put> This) ) + +(dm find> ("Fun") + (get> This) + (let "D" (cdr (nth (: data) (: ofs))) + (=: ofs + (if (find "Fun" "D") + (index @ (: data)) + 1 ) ) ) + (put> This) ) + +(dm txt> (Flg) + (for (I . L) (: data) + (map + '((G D) + (prin (txt> (car G) (car D))) + (if + (cdr G) + (prin "^I") + (prinl (and Flg "^M")) ) ) + (: gui 1) + ((: put) L I) ) ) ) + +(dm set> (Lst) + (=: ofs + (max 1 + (min (: ofs) (length (=: data (copy Lst)))) ) ) + (put> This) + Lst ) + +(dm log> (Lst) + (=: ofs (max (: ofs) (- (length (: data)) (: rows) -2))) + (set> This (conc (: data) (cons Lst))) ) + +(dm clr> () + (set> This) ) + +(dm val> () + (get> This) + (: data) ) + +(dm init> () + (upd> This) ) + +(dm upd> ()) + +(dm chk> ()) + +(dm cut> (N) + (get> This) + (=: clip (get (: data) (: ofs))) + (set> This (remove (or N (: ofs)) (: data))) ) + +(dm paste> (Flg N) + (get> This) + (set> This (insert (or N (: ofs)) (: data) (unless Flg (: clip)))) ) + + +(class +Chart1 +Chart) + +# (cols) +(dm T (N) + (super N list car) ) + + +### DB GUI ### +(de newUrl @ + (prog1 (pass new!) + (lock (setq *Lock @)) + (apply url (url> @ 1)) ) ) + + +# (choDlg Dst Ttl Rel [Hook] [((+XyzField) ..) Exe Able [Rel2 [Hook2]]]) +(de choDlg (Dst Ttl Rel . @) + (let + (Hook (and (meta (cdr Rel) (car Rel) 'hook) (next)) + Fld (or (next) '((+TextField) 40)) + Gui + (if (next) + (list '(+ObjView +TextField) @) + (list (list '+ObjView (last (car Fld))) (list ': (car Rel))) ) + Able (if (args) (next) T) ) + (nond + ((next) + (setq Ttl (list Ttl (car Rel) (last Rel) Hook)) ) + ((=T (arg)) + (setq Ttl (list Ttl (car (arg)) (cadr (arg)) (next))) ) ) + (diaform '(Dst Ttl Rel Hook Fld Gui Able) + (apply gui + (cons + (cons '+Focus '+Var (car Fld)) + (cdr (or (assoc Rel "*Cho") (push '"*Cho" (list Rel NIL)))) + (cdr Fld) ) ) + (searchButton '(init> (: home query))) + (gui 'query '(+QueryChart) (cho) + '(goal + (list + (list 'db (car Rel) (last Rel) Hook (val> (: home gui 1)) '@@) ) ) + 2 '((Obj) (list Obj Obj)) ) + (<table> 'chart (if (atom Ttl) Ttl (apply choTtl Ttl)) '((btn) NIL) + (do (cho) + (<row> (alternating) + (gui 1 '(+DstButton) Dst) + (apply gui Gui 2) ) ) ) + (<spread> + (scroll (cho)) + (if (meta (cdr Rel) (car Rel) 'hook) + (newButton Able Dst (cdr Rel) + (meta (cdr Rel) (car Rel) 'hook) + Hook + (car Rel) + (let? Val (val> (: home gui 1)) + (unless (db (car Rel) (last Rel) Hook Val) + Val ) ) ) + (newButton Able Dst (cdr Rel) + (car Rel) + (let? Val (val> (: home gui 1)) + (unless (db (car Rel) (last Rel) Val) + Val ) ) ) ) + (cancelButton) ) ) ) ) + +(de choTtl (Ttl Var Cls Hook) + (with (or (get Cls Var) (meta Cls Var)) + (if (isa '+Idx This) + Ttl + (pack (count (tree (: var) (: cls) Hook)) " " Ttl) ) ) ) + +(de cho () + (if (: diaform) 16 8) ) + + +# Able object +(class +AO +Able) +# ao + +(dm T (Exe . @) + (=: ao Exe) + (pass super + '(and + (: home obj) + (not (: home obj T)) + (eval (: ao)) ) ) ) + + +# Lock/Edit button prefix +(class +Edit +Rid +Force +Tip) +# save + +(dm T (Exe) + (=: save Exe) + (super + '(nor (: home able) (lock (: home obj))) + '(if (: home able) + ,"Release exclusive write access for this object" + ,"Gain exclusive write access for this object" ) + '(if (: home able) ,"Done" ,"Edit") + '(if (: home able) + (when (able) + (eval (: save)) + (unless (pair "*Err") + (rollback) + (off *Lock) ) ) + (tryLock (: home obj)) ) ) ) + +(de tryLock (Obj) + (if (lock Obj) + (err (text ,"Currently edited by '@2' (@1)" @ (cdr (lup *Users @)))) + (sync) + (setq *Lock Obj) ) ) + + +(de editButton (Able Exe) + (<style> (and (: able) 'edit) + (gui '(+AO +Focus +Edit +Button) Able Exe) ) ) + +(de searchButton (Exe) + (gui '(+Rid +JS +Tip +Button) ,"Start search" ,"Search" Exe) ) + +(de resetButton (Lst) + (gui '(+Force +ClrButton) T ,"Reset" Lst) ) + +(de newButton (Able Dst . Args) + (gui '(+Rid +Able +Close +Tip +Button) Able ,"Create new object" ',"New" + (nond + (Dst (cons 'newUrl Args)) + ((pair Dst) + (list 'set> (lit Dst) (cons 'new! Args)) ) + (NIL + (list 'prog (list '=: 'obj (cons 'new! Args)) Dst) ) ) ) ) + +# Clone object in form +(de cloneButton (Able) + (gui '(+Rid +Able +Tip +Button) (or Able T) + ,"Create a new copy of this object" + ,"New/Copy" + '(apply url + (url> + (prog1 + (clone!> (: home obj)) + (lock (setq *Lock @)) ) + 1 ) ) ) ) + +# Delete object in form +(de delButton (Able @Txt) + (gui '(+Force +Rid +Able +Tip +Button) T Able + '(if (: home obj T) + ,"Mark this object as \"not deleted\"" + ,"Mark this object as \"deleted\"" ) + '(if (: home obj T) ,"Restore" ,"Delete") + (fill + '(nond + ((: home obj T) + (ask (text ,"Delete @1?" @Txt) + (lose!> (: home top 1 obj)) ) ) + ((keep?> (: home obj)) + (ask (text ,"Restore @1?" @Txt) + (keep!> (: home top 1 obj)) ) ) + (NIL + (note ,"Restore" + (mapcar + '((X) (text "'@1' -- @2" (car X) (cdr X))) + @ ) ) ) ) ) ) ) + + +# Relations +(class +/R +Able) +# erVar erObj + +(dm T (Lst . @) + (=: erVar (car Lst)) + (=: erObj (cdr Lst)) + (pass super + '(and (eval (: erObj)) (not (get @ T))) ) ) + +(dm upd> () + (set> This (get (eval (: erObj)) (: erVar))) ) + + +# Symbol/Relation +(class +S/R +/R) + +(dm set> (Val Dn) + (and + (eval (: erObj)) + (put! @ (: erVar) Val) ) + (extra Val Dn) ) + + +# Entity/Relation +(class +E/R +/R) + +(dm set> (Val Dn) + (and + (eval (: erObj)) + (put!> @ (: erVar) Val) ) + (extra Val Dn) ) + +(dm chk> () + (or + (extra) + (and + (eval (: erObj)) + (mis> @ (: erVar) (val> This)) ) ) ) + + +(class +BlobField +/R +TextField) +# org + +(dm set> (Val Dn) + (and + (<> Val (: org)) + (let? Obj (eval (: erObj)) + (protect + (when (put!> Obj (: erVar) (bool Val)) + (and *Jnl (blob+ Obj (: erVar))) + (out (blob Obj (: erVar)) + (prin (=: org Val)) ) ) ) ) ) + (super Val Dn) ) + +(dm upd> () + (set> This + (=: org + (let? Obj (eval (: erObj)) + (when (get Obj (: erVar)) + (in (blob Obj (: erVar)) + (till NIL T) ) ) ) ) ) ) + + +(class +ClassField +Map +TextField) +# erObj + +(dm T (Exe Lst) + (=: erObj Exe) + (super Lst (mapcar car Lst)) ) + +(dm upd> () + (set> This (val (eval (: erObj)))) ) + +(dm set> (Val Dn) + (and + (eval (: erObj)) + (set!> @ Val) ) + (super Val Dn) ) + + +(class +obj) +# msg obj + +# ([T|msg] ..) +(dm T () + (ifn (atom (next)) + (=: msg 'url>) + (=: msg (arg)) + (next) ) ) + +(dm js> () + (if (=T (: msg)) + (extra) + (if2 (or (: dx) (: lst)) (try (: msg) (: obj) 1) + (pack (extra) "&*" (ht:Fmt (sesId `(path "@img/go.png"))) '& (ht:Fmt (sesId (mkUrl @)))) + (pack (extra) "&*" (ht:Fmt (sesId `(path "@img/no.png"))) '&) + (pack (ht:Fmt (nonblank (str> This))) "&+" (ht:Fmt (sesId (mkUrl @)))) + (extra) ) ) ) + +(dm show> ("Var") + (cond + ((=T (: msg)) (extra "Var")) + ((or (: dx) (: lst)) + (prin "<table cellspacing=\"0\" cellpadding=\"0\"><td>") + (extra "Var") + (prin "</td><td title=\"-->\">") + (if (try (: msg) (: obj) 1) + (<img> `(path "@img/go.png") 'obj (mkUrl @)) + (<img> `(path "@img/no.png")) ) + (prinl "</td></table>") ) + ((try (: msg) (: obj) 1) + (showFld (<href> (nonblank (str> This)) (mkUrl @))) ) + (T (extra "Var")) ) ) + + +(class +Obj +obj) +# objVar objTyp objHook + +# ([T|msg] (var . typ) [hook] [T] ..) +(dm T @ + (super) + (=: objVar (car (arg))) + (=: objTyp (cdr (arg))) + (when (meta (: objTyp) (: objVar) 'hook) + (=: objHook (next)) ) + (pass extra + (if (nT (next)) + (arg) + (cons NIL (hint> This)) ) ) ) + +(dm hint> () + (if (: objHook) + (collect (: objVar) (last (: objTyp)) (eval @) NIL T (: objVar)) + (collect (: objVar) (last (: objTyp)) NIL T (: objVar)) ) ) + +(dm txt> (Obj) + (if (ext? Obj) + (get Obj (: objVar)) + Obj ) ) + +(dm set> (Obj Dn) + (extra + (if (ext? (=: obj Obj)) + (get Obj (: objVar)) + Obj ) + Dn ) ) + +(dm val> () + (let Val (extra) + (cond + ((and (: obj) (not (ext? @))) Val) + ((= Val (get (: obj) (: objVar))) + (: obj) ) + ((: objTyp) + (=: obj + (if (: objHook) + (db (: objVar) (last (: objTyp)) (eval @) Val) + (db (: objVar) (last (: objTyp)) Val) ) ) ) + (T Val) ) ) ) + +(dm chk> () + (or + (extra) + (let? S (str> This) + (and + (: objTyp) + (not (val> This)) + (<> "-" S) + ,"Data not found" ) ) ) ) + + +(class +ObjView +obj) +# disp obj + +# ([T|msg] exe ..) +(dm T @ + (super) + (=: disp (arg)) + (pass extra) + (=: able) ) + +(dm txt> (Obj) + (let Exe (: disp) + (if (ext? Obj) + (with Obj (eval Exe)) + Obj ) ) ) + +(dm set> (Obj Dn) + (let Exe (: disp) + (extra + (if (ext? (=: obj Obj)) + (with Obj (eval Exe)) + Obj ) + Dn ) ) ) + +(dm val> () + (: obj) ) + + +# DB query chart +(class +QueryChart +Chart) +# iniR iniq query + +# (iniR iniQ cols [put [get]]) +(dm T (R Q . @) + (=: iniR R) + (=: iniQ Q) + (pass super) ) + +(dm init> () + (query> This (eval (: iniQ))) ) + +(dm put> () + (while + (and + (> (: ofs) (- (length (: data)) (max (: rows) (: iniR)))) + (get (prove (: query)) '@@) ) + (=: data (conc (: data) (cons @))) ) + (super) ) + +(dm txt> (Flg) + (for ((I . Q) (eval (: iniQ)) (prove Q)) + (map + '((G D) + (prin (txt> (car G) (car D))) + (if (cdr G) + (prin "^I") + (prinl (and Flg "^M")) ) ) + (: gui 1) + ((: put) (; @ @@) I) ) ) ) + +(dm all> () + (make + (for (Q (eval (: iniQ)) (prove Q)) + (link (; @ @@)) ) ) ) + +(dm query> (Q) + (=: query Q) + (set> This) ) + +(dm sort> (Exe) + (set> This + (goal + (list + (list 'lst '@@ + (by '((This) (eval Exe)) sort (: data)) ) ) ) ) ) + +(dm clr> () + (query> This (fail)) ) + + +(====) + +# Form object +(de <id> "Lst" + (with (if *PRG (: obj) (=: obj *ID)) + (and (: T) (prin "[")) + (for "X" (if (=T (car "Lst")) (cdr "Lst") "Lst") + (ht:Prin (eval "X")) ) + (and (: T) (prin "]")) ) + (=: able + (cond + ((: obj T)) + ((=T (car "Lst")) T) + ((== *Lock (: obj)) T) + (*Lock (rollback) (off *Lock)) ) ) ) + +(de panel (Able Txt Del Dlg Var Cls Hook Msg Exe) + (<spread> + (editButton Able Exe) + (delButton + (cond + ((=T Able) Del) + ((=T Del) Able) + ((and Able Del) (list 'and Able Del)) ) + (list 'text Txt (list ': 'home 'obj Var)) ) + (choButton Dlg) + (stepBtn Var Cls Hook Msg) ) + (--) ) + +`*Dbg +(noLint 'gui) +(noLint 'choDlg 'gui) +(noLint 'jsForm 'action) + +# vi:et:ts=3:sw=3 diff --git a/lib/gcc.l b/lib/gcc.l @@ -0,0 +1,40 @@ +# 10oct08abu +# (c) Software Lab. Alexander Burger + +(de gcc (S L . @) + (out (tmp S ".c") + (chdir '@ (prinl "#include \"" (pwd) "/src/pico.h\"")) + (here "/**/") ) + ~(case *OS + (("Linux" "FreeBSD") + (quote + (apply call L 'gcc "-m32" "-o" (tmp S) + "-shared" "-export-dynamic" + "-O" "-falign-functions" "-fomit-frame-pointer" + "-W" "-Wimplicit" "-Wreturn-type" "-Wunused" "-Wformat" + "-Wuninitialized" "-Wstrict-prototypes" + "-pipe" "-D_GNU_SOURCE" "-D_FILE_OFFSET_BITS=64" (tmp S ".c") ) ) ) + ("Darwin" + (quote + (apply call L 'gcc "-o" (tmp S) + "-dynamiclib" "-undefined" "dynamic_lookup" + "-O" "-falign-functions" "-fomit-frame-pointer" + "-W" "-Wimplicit" "-Wreturn-type" "-Wunused" "-Wformat" + "-Wuninitialized" "-Wstrict-prototypes" + "-pipe" "-D_GNU_SOURCE" "-D_FILE_OFFSET_BITS=64" (tmp S ".c") ) ) ) + ("Cygwin" + (quote + (call 'gcc "-c" + "-Os" "-falign-functions" "-fomit-frame-pointer" + "-W" "-Wimplicit" "-Wreturn-type" "-Wunused" "-Wformat" + "-Wuninitialized" "-Wstrict-prototypes" + "-pipe" "-D_GNU_SOURCE" "-D_FILE_OFFSET_BITS=64" + (pack "-I" (path "@src") ) + "-o" (tmp S ".o") (tmp S ".c")) + (apply call L 'gcc "-shared" "-o" (tmp S ".dll") + (tmp S ".o") + (path "@bin/picolisp.dll") ) ) ) ) + (while (args) + (def (next) (def (tmp S ': (arg)))) ) ) + +# vi:et:ts=3:sw=3 diff --git a/lib/glyphlist.txt b/lib/glyphlist.txt @@ -0,0 +1,4322 @@ +# ################################################################################### +# Copyright (c) 1997,1998,2002,2007 Adobe Systems Incorporated +# +# Permission is hereby granted, free of charge, to any person obtaining a +# copy of this documentation file to use, copy, publish, distribute, +# sublicense, and/or sell copies of the documentation, and to permit +# others to do the same, provided that: +# - No modification, editing or other alteration of this document is +# allowed; and +# - The above copyright notice and this permission notice shall be +# included in all copies of the documentation. +# +# Permission is hereby granted, free of charge, to any person obtaining a +# copy of this documentation file, to create their own derivative works +# from the content of this document to use, copy, publish, distribute, +# sublicense, and/or sell the derivative works, and to permit others to do +# the same, provided that the derived work is not represented as being a +# copy or version of this document. +# +# Adobe shall not be liable to any party for any loss of revenue or profit +# or for indirect, incidental, special, consequential, or other similar +# damages, whether based on tort (including without limitation negligence +# or strict liability), contract or other legal or equitable grounds even +# if Adobe has been advised or had reason to know of the possibility of +# such damages. The Adobe materials are provided on an "AS IS" basis. +# Adobe specifically disclaims all express, statutory, or implied +# warranties relating to the Adobe materials, including but not limited to +# those concerning merchantability or fitness for a particular purpose or +# non-infringement of any third party rights regarding the Adobe +# materials. +# ################################################################################### +# Name: Adobe Glyph List +# Table version: 2.0 +# Date: September 20, 2002 +# +# See http://partners.adobe.com/asn/developer/typeforum/unicodegn.html +# +# Format: Semicolon-delimited fields: +# (1) glyph name +# (2) Unicode scalar value +A;0041 +AE;00C6 +AEacute;01FC +AEmacron;01E2 +AEsmall;F7E6 +Aacute;00C1 +Aacutesmall;F7E1 +Abreve;0102 +Abreveacute;1EAE +Abrevecyrillic;04D0 +Abrevedotbelow;1EB6 +Abrevegrave;1EB0 +Abrevehookabove;1EB2 +Abrevetilde;1EB4 +Acaron;01CD +Acircle;24B6 +Acircumflex;00C2 +Acircumflexacute;1EA4 +Acircumflexdotbelow;1EAC +Acircumflexgrave;1EA6 +Acircumflexhookabove;1EA8 +Acircumflexsmall;F7E2 +Acircumflextilde;1EAA +Acute;F6C9 +Acutesmall;F7B4 +Acyrillic;0410 +Adblgrave;0200 +Adieresis;00C4 +Adieresiscyrillic;04D2 +Adieresismacron;01DE +Adieresissmall;F7E4 +Adotbelow;1EA0 +Adotmacron;01E0 +Agrave;00C0 +Agravesmall;F7E0 +Ahookabove;1EA2 +Aiecyrillic;04D4 +Ainvertedbreve;0202 +Alpha;0391 +Alphatonos;0386 +Amacron;0100 +Amonospace;FF21 +Aogonek;0104 +Aring;00C5 +Aringacute;01FA +Aringbelow;1E00 +Aringsmall;F7E5 +Asmall;F761 +Atilde;00C3 +Atildesmall;F7E3 +Aybarmenian;0531 +B;0042 +Bcircle;24B7 +Bdotaccent;1E02 +Bdotbelow;1E04 +Becyrillic;0411 +Benarmenian;0532 +Beta;0392 +Bhook;0181 +Blinebelow;1E06 +Bmonospace;FF22 +Brevesmall;F6F4 +Bsmall;F762 +Btopbar;0182 +C;0043 +Caarmenian;053E +Cacute;0106 +Caron;F6CA +Caronsmall;F6F5 +Ccaron;010C +Ccedilla;00C7 +Ccedillaacute;1E08 +Ccedillasmall;F7E7 +Ccircle;24B8 +Ccircumflex;0108 +Cdot;010A +Cdotaccent;010A +Cedillasmall;F7B8 +Chaarmenian;0549 +Cheabkhasiancyrillic;04BC +Checyrillic;0427 +Chedescenderabkhasiancyrillic;04BE +Chedescendercyrillic;04B6 +Chedieresiscyrillic;04F4 +Cheharmenian;0543 +Chekhakassiancyrillic;04CB +Cheverticalstrokecyrillic;04B8 +Chi;03A7 +Chook;0187 +Circumflexsmall;F6F6 +Cmonospace;FF23 +Coarmenian;0551 +Csmall;F763 +D;0044 +DZ;01F1 +DZcaron;01C4 +Daarmenian;0534 +Dafrican;0189 +Dcaron;010E +Dcedilla;1E10 +Dcircle;24B9 +Dcircumflexbelow;1E12 +Dcroat;0110 +Ddotaccent;1E0A +Ddotbelow;1E0C +Decyrillic;0414 +Deicoptic;03EE +Delta;2206 +Deltagreek;0394 +Dhook;018A +Dieresis;F6CB +DieresisAcute;F6CC +DieresisGrave;F6CD +Dieresissmall;F7A8 +Digammagreek;03DC +Djecyrillic;0402 +Dlinebelow;1E0E +Dmonospace;FF24 +Dotaccentsmall;F6F7 +Dslash;0110 +Dsmall;F764 +Dtopbar;018B +Dz;01F2 +Dzcaron;01C5 +Dzeabkhasiancyrillic;04E0 +Dzecyrillic;0405 +Dzhecyrillic;040F +E;0045 +Eacute;00C9 +Eacutesmall;F7E9 +Ebreve;0114 +Ecaron;011A +Ecedillabreve;1E1C +Echarmenian;0535 +Ecircle;24BA +Ecircumflex;00CA +Ecircumflexacute;1EBE +Ecircumflexbelow;1E18 +Ecircumflexdotbelow;1EC6 +Ecircumflexgrave;1EC0 +Ecircumflexhookabove;1EC2 +Ecircumflexsmall;F7EA +Ecircumflextilde;1EC4 +Ecyrillic;0404 +Edblgrave;0204 +Edieresis;00CB +Edieresissmall;F7EB +Edot;0116 +Edotaccent;0116 +Edotbelow;1EB8 +Efcyrillic;0424 +Egrave;00C8 +Egravesmall;F7E8 +Eharmenian;0537 +Ehookabove;1EBA +Eightroman;2167 +Einvertedbreve;0206 +Eiotifiedcyrillic;0464 +Elcyrillic;041B +Elevenroman;216A +Emacron;0112 +Emacronacute;1E16 +Emacrongrave;1E14 +Emcyrillic;041C +Emonospace;FF25 +Encyrillic;041D +Endescendercyrillic;04A2 +Eng;014A +Enghecyrillic;04A4 +Enhookcyrillic;04C7 +Eogonek;0118 +Eopen;0190 +Epsilon;0395 +Epsilontonos;0388 +Ercyrillic;0420 +Ereversed;018E +Ereversedcyrillic;042D +Escyrillic;0421 +Esdescendercyrillic;04AA +Esh;01A9 +Esmall;F765 +Eta;0397 +Etarmenian;0538 +Etatonos;0389 +Eth;00D0 +Ethsmall;F7F0 +Etilde;1EBC +Etildebelow;1E1A +Euro;20AC +Ezh;01B7 +Ezhcaron;01EE +Ezhreversed;01B8 +F;0046 +Fcircle;24BB +Fdotaccent;1E1E +Feharmenian;0556 +Feicoptic;03E4 +Fhook;0191 +Fitacyrillic;0472 +Fiveroman;2164 +Fmonospace;FF26 +Fourroman;2163 +Fsmall;F766 +G;0047 +GBsquare;3387 +Gacute;01F4 +Gamma;0393 +Gammaafrican;0194 +Gangiacoptic;03EA +Gbreve;011E +Gcaron;01E6 +Gcedilla;0122 +Gcircle;24BC +Gcircumflex;011C +Gcommaaccent;0122 +Gdot;0120 +Gdotaccent;0120 +Gecyrillic;0413 +Ghadarmenian;0542 +Ghemiddlehookcyrillic;0494 +Ghestrokecyrillic;0492 +Gheupturncyrillic;0490 +Ghook;0193 +Gimarmenian;0533 +Gjecyrillic;0403 +Gmacron;1E20 +Gmonospace;FF27 +Grave;F6CE +Gravesmall;F760 +Gsmall;F767 +Gsmallhook;029B +Gstroke;01E4 +H;0048 +H18533;25CF +H18543;25AA +H18551;25AB +H22073;25A1 +HPsquare;33CB +Haabkhasiancyrillic;04A8 +Hadescendercyrillic;04B2 +Hardsigncyrillic;042A +Hbar;0126 +Hbrevebelow;1E2A +Hcedilla;1E28 +Hcircle;24BD +Hcircumflex;0124 +Hdieresis;1E26 +Hdotaccent;1E22 +Hdotbelow;1E24 +Hmonospace;FF28 +Hoarmenian;0540 +Horicoptic;03E8 +Hsmall;F768 +Hungarumlaut;F6CF +Hungarumlautsmall;F6F8 +Hzsquare;3390 +I;0049 +IAcyrillic;042F +IJ;0132 +IUcyrillic;042E +Iacute;00CD +Iacutesmall;F7ED +Ibreve;012C +Icaron;01CF +Icircle;24BE +Icircumflex;00CE +Icircumflexsmall;F7EE +Icyrillic;0406 +Idblgrave;0208 +Idieresis;00CF +Idieresisacute;1E2E +Idieresiscyrillic;04E4 +Idieresissmall;F7EF +Idot;0130 +Idotaccent;0130 +Idotbelow;1ECA +Iebrevecyrillic;04D6 +Iecyrillic;0415 +Ifraktur;2111 +Igrave;00CC +Igravesmall;F7EC +Ihookabove;1EC8 +Iicyrillic;0418 +Iinvertedbreve;020A +Iishortcyrillic;0419 +Imacron;012A +Imacroncyrillic;04E2 +Imonospace;FF29 +Iniarmenian;053B +Iocyrillic;0401 +Iogonek;012E +Iota;0399 +Iotaafrican;0196 +Iotadieresis;03AA +Iotatonos;038A +Ismall;F769 +Istroke;0197 +Itilde;0128 +Itildebelow;1E2C +Izhitsacyrillic;0474 +Izhitsadblgravecyrillic;0476 +J;004A +Jaarmenian;0541 +Jcircle;24BF +Jcircumflex;0134 +Jecyrillic;0408 +Jheharmenian;054B +Jmonospace;FF2A +Jsmall;F76A +K;004B +KBsquare;3385 +KKsquare;33CD +Kabashkircyrillic;04A0 +Kacute;1E30 +Kacyrillic;041A +Kadescendercyrillic;049A +Kahookcyrillic;04C3 +Kappa;039A +Kastrokecyrillic;049E +Kaverticalstrokecyrillic;049C +Kcaron;01E8 +Kcedilla;0136 +Kcircle;24C0 +Kcommaaccent;0136 +Kdotbelow;1E32 +Keharmenian;0554 +Kenarmenian;053F +Khacyrillic;0425 +Kheicoptic;03E6 +Khook;0198 +Kjecyrillic;040C +Klinebelow;1E34 +Kmonospace;FF2B +Koppacyrillic;0480 +Koppagreek;03DE +Ksicyrillic;046E +Ksmall;F76B +L;004C +LJ;01C7 +LL;F6BF +Lacute;0139 +Lambda;039B +Lcaron;013D +Lcedilla;013B +Lcircle;24C1 +Lcircumflexbelow;1E3C +Lcommaaccent;013B +Ldot;013F +Ldotaccent;013F +Ldotbelow;1E36 +Ldotbelowmacron;1E38 +Liwnarmenian;053C +Lj;01C8 +Ljecyrillic;0409 +Llinebelow;1E3A +Lmonospace;FF2C +Lslash;0141 +Lslashsmall;F6F9 +Lsmall;F76C +M;004D +MBsquare;3386 +Macron;F6D0 +Macronsmall;F7AF +Macute;1E3E +Mcircle;24C2 +Mdotaccent;1E40 +Mdotbelow;1E42 +Menarmenian;0544 +Mmonospace;FF2D +Msmall;F76D +Mturned;019C +Mu;039C +N;004E +NJ;01CA +Nacute;0143 +Ncaron;0147 +Ncedilla;0145 +Ncircle;24C3 +Ncircumflexbelow;1E4A +Ncommaaccent;0145 +Ndotaccent;1E44 +Ndotbelow;1E46 +Nhookleft;019D +Nineroman;2168 +Nj;01CB +Njecyrillic;040A +Nlinebelow;1E48 +Nmonospace;FF2E +Nowarmenian;0546 +Nsmall;F76E +Ntilde;00D1 +Ntildesmall;F7F1 +Nu;039D +O;004F +OE;0152 +OEsmall;F6FA +Oacute;00D3 +Oacutesmall;F7F3 +Obarredcyrillic;04E8 +Obarreddieresiscyrillic;04EA +Obreve;014E +Ocaron;01D1 +Ocenteredtilde;019F +Ocircle;24C4 +Ocircumflex;00D4 +Ocircumflexacute;1ED0 +Ocircumflexdotbelow;1ED8 +Ocircumflexgrave;1ED2 +Ocircumflexhookabove;1ED4 +Ocircumflexsmall;F7F4 +Ocircumflextilde;1ED6 +Ocyrillic;041E +Odblacute;0150 +Odblgrave;020C +Odieresis;00D6 +Odieresiscyrillic;04E6 +Odieresissmall;F7F6 +Odotbelow;1ECC +Ogoneksmall;F6FB +Ograve;00D2 +Ogravesmall;F7F2 +Oharmenian;0555 +Ohm;2126 +Ohookabove;1ECE +Ohorn;01A0 +Ohornacute;1EDA +Ohorndotbelow;1EE2 +Ohorngrave;1EDC +Ohornhookabove;1EDE +Ohorntilde;1EE0 +Ohungarumlaut;0150 +Oi;01A2 +Oinvertedbreve;020E +Omacron;014C +Omacronacute;1E52 +Omacrongrave;1E50 +Omega;2126 +Omegacyrillic;0460 +Omegagreek;03A9 +Omegaroundcyrillic;047A +Omegatitlocyrillic;047C +Omegatonos;038F +Omicron;039F +Omicrontonos;038C +Omonospace;FF2F +Oneroman;2160 +Oogonek;01EA +Oogonekmacron;01EC +Oopen;0186 +Oslash;00D8 +Oslashacute;01FE +Oslashsmall;F7F8 +Osmall;F76F +Ostrokeacute;01FE +Otcyrillic;047E +Otilde;00D5 +Otildeacute;1E4C +Otildedieresis;1E4E +Otildesmall;F7F5 +P;0050 +Pacute;1E54 +Pcircle;24C5 +Pdotaccent;1E56 +Pecyrillic;041F +Peharmenian;054A +Pemiddlehookcyrillic;04A6 +Phi;03A6 +Phook;01A4 +Pi;03A0 +Piwrarmenian;0553 +Pmonospace;FF30 +Psi;03A8 +Psicyrillic;0470 +Psmall;F770 +Q;0051 +Qcircle;24C6 +Qmonospace;FF31 +Qsmall;F771 +R;0052 +Raarmenian;054C +Racute;0154 +Rcaron;0158 +Rcedilla;0156 +Rcircle;24C7 +Rcommaaccent;0156 +Rdblgrave;0210 +Rdotaccent;1E58 +Rdotbelow;1E5A +Rdotbelowmacron;1E5C +Reharmenian;0550 +Rfraktur;211C +Rho;03A1 +Ringsmall;F6FC +Rinvertedbreve;0212 +Rlinebelow;1E5E +Rmonospace;FF32 +Rsmall;F772 +Rsmallinverted;0281 +Rsmallinvertedsuperior;02B6 +S;0053 +SF010000;250C +SF020000;2514 +SF030000;2510 +SF040000;2518 +SF050000;253C +SF060000;252C +SF070000;2534 +SF080000;251C +SF090000;2524 +SF100000;2500 +SF110000;2502 +SF190000;2561 +SF200000;2562 +SF210000;2556 +SF220000;2555 +SF230000;2563 +SF240000;2551 +SF250000;2557 +SF260000;255D +SF270000;255C +SF280000;255B +SF360000;255E +SF370000;255F +SF380000;255A +SF390000;2554 +SF400000;2569 +SF410000;2566 +SF420000;2560 +SF430000;2550 +SF440000;256C +SF450000;2567 +SF460000;2568 +SF470000;2564 +SF480000;2565 +SF490000;2559 +SF500000;2558 +SF510000;2552 +SF520000;2553 +SF530000;256B +SF540000;256A +Sacute;015A +Sacutedotaccent;1E64 +Sampigreek;03E0 +Scaron;0160 +Scarondotaccent;1E66 +Scaronsmall;F6FD +Scedilla;015E +Schwa;018F +Schwacyrillic;04D8 +Schwadieresiscyrillic;04DA +Scircle;24C8 +Scircumflex;015C +Scommaaccent;0218 +Sdotaccent;1E60 +Sdotbelow;1E62 +Sdotbelowdotaccent;1E68 +Seharmenian;054D +Sevenroman;2166 +Shaarmenian;0547 +Shacyrillic;0428 +Shchacyrillic;0429 +Sheicoptic;03E2 +Shhacyrillic;04BA +Shimacoptic;03EC +Sigma;03A3 +Sixroman;2165 +Smonospace;FF33 +Softsigncyrillic;042C +Ssmall;F773 +Stigmagreek;03DA +T;0054 +Tau;03A4 +Tbar;0166 +Tcaron;0164 +Tcedilla;0162 +Tcircle;24C9 +Tcircumflexbelow;1E70 +Tcommaaccent;0162 +Tdotaccent;1E6A +Tdotbelow;1E6C +Tecyrillic;0422 +Tedescendercyrillic;04AC +Tenroman;2169 +Tetsecyrillic;04B4 +Theta;0398 +Thook;01AC +Thorn;00DE +Thornsmall;F7FE +Threeroman;2162 +Tildesmall;F6FE +Tiwnarmenian;054F +Tlinebelow;1E6E +Tmonospace;FF34 +Toarmenian;0539 +Tonefive;01BC +Tonesix;0184 +Tonetwo;01A7 +Tretroflexhook;01AE +Tsecyrillic;0426 +Tshecyrillic;040B +Tsmall;F774 +Twelveroman;216B +Tworoman;2161 +U;0055 +Uacute;00DA +Uacutesmall;F7FA +Ubreve;016C +Ucaron;01D3 +Ucircle;24CA +Ucircumflex;00DB +Ucircumflexbelow;1E76 +Ucircumflexsmall;F7FB +Ucyrillic;0423 +Udblacute;0170 +Udblgrave;0214 +Udieresis;00DC +Udieresisacute;01D7 +Udieresisbelow;1E72 +Udieresiscaron;01D9 +Udieresiscyrillic;04F0 +Udieresisgrave;01DB +Udieresismacron;01D5 +Udieresissmall;F7FC +Udotbelow;1EE4 +Ugrave;00D9 +Ugravesmall;F7F9 +Uhookabove;1EE6 +Uhorn;01AF +Uhornacute;1EE8 +Uhorndotbelow;1EF0 +Uhorngrave;1EEA +Uhornhookabove;1EEC +Uhorntilde;1EEE +Uhungarumlaut;0170 +Uhungarumlautcyrillic;04F2 +Uinvertedbreve;0216 +Ukcyrillic;0478 +Umacron;016A +Umacroncyrillic;04EE +Umacrondieresis;1E7A +Umonospace;FF35 +Uogonek;0172 +Upsilon;03A5 +Upsilon1;03D2 +Upsilonacutehooksymbolgreek;03D3 +Upsilonafrican;01B1 +Upsilondieresis;03AB +Upsilondieresishooksymbolgreek;03D4 +Upsilonhooksymbol;03D2 +Upsilontonos;038E +Uring;016E +Ushortcyrillic;040E +Usmall;F775 +Ustraightcyrillic;04AE +Ustraightstrokecyrillic;04B0 +Utilde;0168 +Utildeacute;1E78 +Utildebelow;1E74 +V;0056 +Vcircle;24CB +Vdotbelow;1E7E +Vecyrillic;0412 +Vewarmenian;054E +Vhook;01B2 +Vmonospace;FF36 +Voarmenian;0548 +Vsmall;F776 +Vtilde;1E7C +W;0057 +Wacute;1E82 +Wcircle;24CC +Wcircumflex;0174 +Wdieresis;1E84 +Wdotaccent;1E86 +Wdotbelow;1E88 +Wgrave;1E80 +Wmonospace;FF37 +Wsmall;F777 +X;0058 +Xcircle;24CD +Xdieresis;1E8C +Xdotaccent;1E8A +Xeharmenian;053D +Xi;039E +Xmonospace;FF38 +Xsmall;F778 +Y;0059 +Yacute;00DD +Yacutesmall;F7FD +Yatcyrillic;0462 +Ycircle;24CE +Ycircumflex;0176 +Ydieresis;0178 +Ydieresissmall;F7FF +Ydotaccent;1E8E +Ydotbelow;1EF4 +Yericyrillic;042B +Yerudieresiscyrillic;04F8 +Ygrave;1EF2 +Yhook;01B3 +Yhookabove;1EF6 +Yiarmenian;0545 +Yicyrillic;0407 +Yiwnarmenian;0552 +Ymonospace;FF39 +Ysmall;F779 +Ytilde;1EF8 +Yusbigcyrillic;046A +Yusbigiotifiedcyrillic;046C +Yuslittlecyrillic;0466 +Yuslittleiotifiedcyrillic;0468 +Z;005A +Zaarmenian;0536 +Zacute;0179 +Zcaron;017D +Zcaronsmall;F6FF +Zcircle;24CF +Zcircumflex;1E90 +Zdot;017B +Zdotaccent;017B +Zdotbelow;1E92 +Zecyrillic;0417 +Zedescendercyrillic;0498 +Zedieresiscyrillic;04DE +Zeta;0396 +Zhearmenian;053A +Zhebrevecyrillic;04C1 +Zhecyrillic;0416 +Zhedescendercyrillic;0496 +Zhedieresiscyrillic;04DC +Zlinebelow;1E94 +Zmonospace;FF3A +Zsmall;F77A +Zstroke;01B5 +a;0061 +aabengali;0986 +aacute;00E1 +aadeva;0906 +aagujarati;0A86 +aagurmukhi;0A06 +aamatragurmukhi;0A3E +aarusquare;3303 +aavowelsignbengali;09BE +aavowelsigndeva;093E +aavowelsigngujarati;0ABE +abbreviationmarkarmenian;055F +abbreviationsigndeva;0970 +abengali;0985 +abopomofo;311A +abreve;0103 +abreveacute;1EAF +abrevecyrillic;04D1 +abrevedotbelow;1EB7 +abrevegrave;1EB1 +abrevehookabove;1EB3 +abrevetilde;1EB5 +acaron;01CE +acircle;24D0 +acircumflex;00E2 +acircumflexacute;1EA5 +acircumflexdotbelow;1EAD +acircumflexgrave;1EA7 +acircumflexhookabove;1EA9 +acircumflextilde;1EAB +acute;00B4 +acutebelowcmb;0317 +acutecmb;0301 +acutecomb;0301 +acutedeva;0954 +acutelowmod;02CF +acutetonecmb;0341 +acyrillic;0430 +adblgrave;0201 +addakgurmukhi;0A71 +adeva;0905 +adieresis;00E4 +adieresiscyrillic;04D3 +adieresismacron;01DF +adotbelow;1EA1 +adotmacron;01E1 +ae;00E6 +aeacute;01FD +aekorean;3150 +aemacron;01E3 +afii00208;2015 +afii08941;20A4 +afii10017;0410 +afii10018;0411 +afii10019;0412 +afii10020;0413 +afii10021;0414 +afii10022;0415 +afii10023;0401 +afii10024;0416 +afii10025;0417 +afii10026;0418 +afii10027;0419 +afii10028;041A +afii10029;041B +afii10030;041C +afii10031;041D +afii10032;041E +afii10033;041F +afii10034;0420 +afii10035;0421 +afii10036;0422 +afii10037;0423 +afii10038;0424 +afii10039;0425 +afii10040;0426 +afii10041;0427 +afii10042;0428 +afii10043;0429 +afii10044;042A +afii10045;042B +afii10046;042C +afii10047;042D +afii10048;042E +afii10049;042F +afii10050;0490 +afii10051;0402 +afii10052;0403 +afii10053;0404 +afii10054;0405 +afii10055;0406 +afii10056;0407 +afii10057;0408 +afii10058;0409 +afii10059;040A +afii10060;040B +afii10061;040C +afii10062;040E +afii10063;F6C4 +afii10064;F6C5 +afii10065;0430 +afii10066;0431 +afii10067;0432 +afii10068;0433 +afii10069;0434 +afii10070;0435 +afii10071;0451 +afii10072;0436 +afii10073;0437 +afii10074;0438 +afii10075;0439 +afii10076;043A +afii10077;043B +afii10078;043C +afii10079;043D +afii10080;043E +afii10081;043F +afii10082;0440 +afii10083;0441 +afii10084;0442 +afii10085;0443 +afii10086;0444 +afii10087;0445 +afii10088;0446 +afii10089;0447 +afii10090;0448 +afii10091;0449 +afii10092;044A +afii10093;044B +afii10094;044C +afii10095;044D +afii10096;044E +afii10097;044F +afii10098;0491 +afii10099;0452 +afii10100;0453 +afii10101;0454 +afii10102;0455 +afii10103;0456 +afii10104;0457 +afii10105;0458 +afii10106;0459 +afii10107;045A +afii10108;045B +afii10109;045C +afii10110;045E +afii10145;040F +afii10146;0462 +afii10147;0472 +afii10148;0474 +afii10192;F6C6 +afii10193;045F +afii10194;0463 +afii10195;0473 +afii10196;0475 +afii10831;F6C7 +afii10832;F6C8 +afii10846;04D9 +afii299;200E +afii300;200F +afii301;200D +afii57381;066A +afii57388;060C +afii57392;0660 +afii57393;0661 +afii57394;0662 +afii57395;0663 +afii57396;0664 +afii57397;0665 +afii57398;0666 +afii57399;0667 +afii57400;0668 +afii57401;0669 +afii57403;061B +afii57407;061F +afii57409;0621 +afii57410;0622 +afii57411;0623 +afii57412;0624 +afii57413;0625 +afii57414;0626 +afii57415;0627 +afii57416;0628 +afii57417;0629 +afii57418;062A +afii57419;062B +afii57420;062C +afii57421;062D +afii57422;062E +afii57423;062F +afii57424;0630 +afii57425;0631 +afii57426;0632 +afii57427;0633 +afii57428;0634 +afii57429;0635 +afii57430;0636 +afii57431;0637 +afii57432;0638 +afii57433;0639 +afii57434;063A +afii57440;0640 +afii57441;0641 +afii57442;0642 +afii57443;0643 +afii57444;0644 +afii57445;0645 +afii57446;0646 +afii57448;0648 +afii57449;0649 +afii57450;064A +afii57451;064B +afii57452;064C +afii57453;064D +afii57454;064E +afii57455;064F +afii57456;0650 +afii57457;0651 +afii57458;0652 +afii57470;0647 +afii57505;06A4 +afii57506;067E +afii57507;0686 +afii57508;0698 +afii57509;06AF +afii57511;0679 +afii57512;0688 +afii57513;0691 +afii57514;06BA +afii57519;06D2 +afii57534;06D5 +afii57636;20AA +afii57645;05BE +afii57658;05C3 +afii57664;05D0 +afii57665;05D1 +afii57666;05D2 +afii57667;05D3 +afii57668;05D4 +afii57669;05D5 +afii57670;05D6 +afii57671;05D7 +afii57672;05D8 +afii57673;05D9 +afii57674;05DA +afii57675;05DB +afii57676;05DC +afii57677;05DD +afii57678;05DE +afii57679;05DF +afii57680;05E0 +afii57681;05E1 +afii57682;05E2 +afii57683;05E3 +afii57684;05E4 +afii57685;05E5 +afii57686;05E6 +afii57687;05E7 +afii57688;05E8 +afii57689;05E9 +afii57690;05EA +afii57694;FB2A +afii57695;FB2B +afii57700;FB4B +afii57705;FB1F +afii57716;05F0 +afii57717;05F1 +afii57718;05F2 +afii57723;FB35 +afii57793;05B4 +afii57794;05B5 +afii57795;05B6 +afii57796;05BB +afii57797;05B8 +afii57798;05B7 +afii57799;05B0 +afii57800;05B2 +afii57801;05B1 +afii57802;05B3 +afii57803;05C2 +afii57804;05C1 +afii57806;05B9 +afii57807;05BC +afii57839;05BD +afii57841;05BF +afii57842;05C0 +afii57929;02BC +afii61248;2105 +afii61289;2113 +afii61352;2116 +afii61573;202C +afii61574;202D +afii61575;202E +afii61664;200C +afii63167;066D +afii64937;02BD +agrave;00E0 +agujarati;0A85 +agurmukhi;0A05 +ahiragana;3042 +ahookabove;1EA3 +aibengali;0990 +aibopomofo;311E +aideva;0910 +aiecyrillic;04D5 +aigujarati;0A90 +aigurmukhi;0A10 +aimatragurmukhi;0A48 +ainarabic;0639 +ainfinalarabic;FECA +aininitialarabic;FECB +ainmedialarabic;FECC +ainvertedbreve;0203 +aivowelsignbengali;09C8 +aivowelsigndeva;0948 +aivowelsigngujarati;0AC8 +akatakana;30A2 +akatakanahalfwidth;FF71 +akorean;314F +alef;05D0 +alefarabic;0627 +alefdageshhebrew;FB30 +aleffinalarabic;FE8E +alefhamzaabovearabic;0623 +alefhamzaabovefinalarabic;FE84 +alefhamzabelowarabic;0625 +alefhamzabelowfinalarabic;FE88 +alefhebrew;05D0 +aleflamedhebrew;FB4F +alefmaddaabovearabic;0622 +alefmaddaabovefinalarabic;FE82 +alefmaksuraarabic;0649 +alefmaksurafinalarabic;FEF0 +alefmaksurainitialarabic;FEF3 +alefmaksuramedialarabic;FEF4 +alefpatahhebrew;FB2E +alefqamatshebrew;FB2F +aleph;2135 +allequal;224C +alpha;03B1 +alphatonos;03AC +amacron;0101 +amonospace;FF41 +ampersand;0026 +ampersandmonospace;FF06 +ampersandsmall;F726 +amsquare;33C2 +anbopomofo;3122 +angbopomofo;3124 +angkhankhuthai;0E5A +angle;2220 +anglebracketleft;3008 +anglebracketleftvertical;FE3F +anglebracketright;3009 +anglebracketrightvertical;FE40 +angleleft;2329 +angleright;232A +angstrom;212B +anoteleia;0387 +anudattadeva;0952 +anusvarabengali;0982 +anusvaradeva;0902 +anusvaragujarati;0A82 +aogonek;0105 +apaatosquare;3300 +aparen;249C +apostrophearmenian;055A +apostrophemod;02BC +apple;F8FF +approaches;2250 +approxequal;2248 +approxequalorimage;2252 +approximatelyequal;2245 +araeaekorean;318E +araeakorean;318D +arc;2312 +arighthalfring;1E9A +aring;00E5 +aringacute;01FB +aringbelow;1E01 +arrowboth;2194 +arrowdashdown;21E3 +arrowdashleft;21E0 +arrowdashright;21E2 +arrowdashup;21E1 +arrowdblboth;21D4 +arrowdbldown;21D3 +arrowdblleft;21D0 +arrowdblright;21D2 +arrowdblup;21D1 +arrowdown;2193 +arrowdownleft;2199 +arrowdownright;2198 +arrowdownwhite;21E9 +arrowheaddownmod;02C5 +arrowheadleftmod;02C2 +arrowheadrightmod;02C3 +arrowheadupmod;02C4 +arrowhorizex;F8E7 +arrowleft;2190 +arrowleftdbl;21D0 +arrowleftdblstroke;21CD +arrowleftoverright;21C6 +arrowleftwhite;21E6 +arrowright;2192 +arrowrightdblstroke;21CF +arrowrightheavy;279E +arrowrightoverleft;21C4 +arrowrightwhite;21E8 +arrowtableft;21E4 +arrowtabright;21E5 +arrowup;2191 +arrowupdn;2195 +arrowupdnbse;21A8 +arrowupdownbase;21A8 +arrowupleft;2196 +arrowupleftofdown;21C5 +arrowupright;2197 +arrowupwhite;21E7 +arrowvertex;F8E6 +asciicircum;005E +asciicircummonospace;FF3E +asciitilde;007E +asciitildemonospace;FF5E +ascript;0251 +ascriptturned;0252 +asmallhiragana;3041 +asmallkatakana;30A1 +asmallkatakanahalfwidth;FF67 +asterisk;002A +asteriskaltonearabic;066D +asteriskarabic;066D +asteriskmath;2217 +asteriskmonospace;FF0A +asterisksmall;FE61 +asterism;2042 +asuperior;F6E9 +asymptoticallyequal;2243 +at;0040 +atilde;00E3 +atmonospace;FF20 +atsmall;FE6B +aturned;0250 +aubengali;0994 +aubopomofo;3120 +audeva;0914 +augujarati;0A94 +augurmukhi;0A14 +aulengthmarkbengali;09D7 +aumatragurmukhi;0A4C +auvowelsignbengali;09CC +auvowelsigndeva;094C +auvowelsigngujarati;0ACC +avagrahadeva;093D +aybarmenian;0561 +ayin;05E2 +ayinaltonehebrew;FB20 +ayinhebrew;05E2 +b;0062 +babengali;09AC +backslash;005C +backslashmonospace;FF3C +badeva;092C +bagujarati;0AAC +bagurmukhi;0A2C +bahiragana;3070 +bahtthai;0E3F +bakatakana;30D0 +bar;007C +barmonospace;FF5C +bbopomofo;3105 +bcircle;24D1 +bdotaccent;1E03 +bdotbelow;1E05 +beamedsixteenthnotes;266C +because;2235 +becyrillic;0431 +beharabic;0628 +behfinalarabic;FE90 +behinitialarabic;FE91 +behiragana;3079 +behmedialarabic;FE92 +behmeeminitialarabic;FC9F +behmeemisolatedarabic;FC08 +behnoonfinalarabic;FC6D +bekatakana;30D9 +benarmenian;0562 +bet;05D1 +beta;03B2 +betasymbolgreek;03D0 +betdagesh;FB31 +betdageshhebrew;FB31 +bethebrew;05D1 +betrafehebrew;FB4C +bhabengali;09AD +bhadeva;092D +bhagujarati;0AAD +bhagurmukhi;0A2D +bhook;0253 +bihiragana;3073 +bikatakana;30D3 +bilabialclick;0298 +bindigurmukhi;0A02 +birusquare;3331 +blackcircle;25CF +blackdiamond;25C6 +blackdownpointingtriangle;25BC +blackleftpointingpointer;25C4 +blackleftpointingtriangle;25C0 +blacklenticularbracketleft;3010 +blacklenticularbracketleftvertical;FE3B +blacklenticularbracketright;3011 +blacklenticularbracketrightvertical;FE3C +blacklowerlefttriangle;25E3 +blacklowerrighttriangle;25E2 +blackrectangle;25AC +blackrightpointingpointer;25BA +blackrightpointingtriangle;25B6 +blacksmallsquare;25AA +blacksmilingface;263B +blacksquare;25A0 +blackstar;2605 +blackupperlefttriangle;25E4 +blackupperrighttriangle;25E5 +blackuppointingsmalltriangle;25B4 +blackuppointingtriangle;25B2 +blank;2423 +blinebelow;1E07 +block;2588 +bmonospace;FF42 +bobaimaithai;0E1A +bohiragana;307C +bokatakana;30DC +bparen;249D +bqsquare;33C3 +braceex;F8F4 +braceleft;007B +braceleftbt;F8F3 +braceleftmid;F8F2 +braceleftmonospace;FF5B +braceleftsmall;FE5B +bracelefttp;F8F1 +braceleftvertical;FE37 +braceright;007D +bracerightbt;F8FE +bracerightmid;F8FD +bracerightmonospace;FF5D +bracerightsmall;FE5C +bracerighttp;F8FC +bracerightvertical;FE38 +bracketleft;005B +bracketleftbt;F8F0 +bracketleftex;F8EF +bracketleftmonospace;FF3B +bracketlefttp;F8EE +bracketright;005D +bracketrightbt;F8FB +bracketrightex;F8FA +bracketrightmonospace;FF3D +bracketrighttp;F8F9 +breve;02D8 +brevebelowcmb;032E +brevecmb;0306 +breveinvertedbelowcmb;032F +breveinvertedcmb;0311 +breveinverteddoublecmb;0361 +bridgebelowcmb;032A +bridgeinvertedbelowcmb;033A +brokenbar;00A6 +bstroke;0180 +bsuperior;F6EA +btopbar;0183 +buhiragana;3076 +bukatakana;30D6 +bullet;2022 +bulletinverse;25D8 +bulletoperator;2219 +bullseye;25CE +c;0063 +caarmenian;056E +cabengali;099A +cacute;0107 +cadeva;091A +cagujarati;0A9A +cagurmukhi;0A1A +calsquare;3388 +candrabindubengali;0981 +candrabinducmb;0310 +candrabindudeva;0901 +candrabindugujarati;0A81 +capslock;21EA +careof;2105 +caron;02C7 +caronbelowcmb;032C +caroncmb;030C +carriagereturn;21B5 +cbopomofo;3118 +ccaron;010D +ccedilla;00E7 +ccedillaacute;1E09 +ccircle;24D2 +ccircumflex;0109 +ccurl;0255 +cdot;010B +cdotaccent;010B +cdsquare;33C5 +cedilla;00B8 +cedillacmb;0327 +cent;00A2 +centigrade;2103 +centinferior;F6DF +centmonospace;FFE0 +centoldstyle;F7A2 +centsuperior;F6E0 +chaarmenian;0579 +chabengali;099B +chadeva;091B +chagujarati;0A9B +chagurmukhi;0A1B +chbopomofo;3114 +cheabkhasiancyrillic;04BD +checkmark;2713 +checyrillic;0447 +chedescenderabkhasiancyrillic;04BF +chedescendercyrillic;04B7 +chedieresiscyrillic;04F5 +cheharmenian;0573 +chekhakassiancyrillic;04CC +cheverticalstrokecyrillic;04B9 +chi;03C7 +chieuchacirclekorean;3277 +chieuchaparenkorean;3217 +chieuchcirclekorean;3269 +chieuchkorean;314A +chieuchparenkorean;3209 +chochangthai;0E0A +chochanthai;0E08 +chochingthai;0E09 +chochoethai;0E0C +chook;0188 +cieucacirclekorean;3276 +cieucaparenkorean;3216 +cieuccirclekorean;3268 +cieuckorean;3148 +cieucparenkorean;3208 +cieucuparenkorean;321C +circle;25CB +circlemultiply;2297 +circleot;2299 +circleplus;2295 +circlepostalmark;3036 +circlewithlefthalfblack;25D0 +circlewithrighthalfblack;25D1 +circumflex;02C6 +circumflexbelowcmb;032D +circumflexcmb;0302 +clear;2327 +clickalveolar;01C2 +clickdental;01C0 +clicklateral;01C1 +clickretroflex;01C3 +club;2663 +clubsuitblack;2663 +clubsuitwhite;2667 +cmcubedsquare;33A4 +cmonospace;FF43 +cmsquaredsquare;33A0 +coarmenian;0581 +colon;003A +colonmonetary;20A1 +colonmonospace;FF1A +colonsign;20A1 +colonsmall;FE55 +colontriangularhalfmod;02D1 +colontriangularmod;02D0 +comma;002C +commaabovecmb;0313 +commaaboverightcmb;0315 +commaaccent;F6C3 +commaarabic;060C +commaarmenian;055D +commainferior;F6E1 +commamonospace;FF0C +commareversedabovecmb;0314 +commareversedmod;02BD +commasmall;FE50 +commasuperior;F6E2 +commaturnedabovecmb;0312 +commaturnedmod;02BB +compass;263C +congruent;2245 +contourintegral;222E +control;2303 +controlACK;0006 +controlBEL;0007 +controlBS;0008 +controlCAN;0018 +controlCR;000D +controlDC1;0011 +controlDC2;0012 +controlDC3;0013 +controlDC4;0014 +controlDEL;007F +controlDLE;0010 +controlEM;0019 +controlENQ;0005 +controlEOT;0004 +controlESC;001B +controlETB;0017 +controlETX;0003 +controlFF;000C +controlFS;001C +controlGS;001D +controlHT;0009 +controlLF;000A +controlNAK;0015 +controlRS;001E +controlSI;000F +controlSO;000E +controlSOT;0002 +controlSTX;0001 +controlSUB;001A +controlSYN;0016 +controlUS;001F +controlVT;000B +copyright;00A9 +copyrightsans;F8E9 +copyrightserif;F6D9 +cornerbracketleft;300C +cornerbracketlefthalfwidth;FF62 +cornerbracketleftvertical;FE41 +cornerbracketright;300D +cornerbracketrighthalfwidth;FF63 +cornerbracketrightvertical;FE42 +corporationsquare;337F +cosquare;33C7 +coverkgsquare;33C6 +cparen;249E +cruzeiro;20A2 +cstretched;0297 +curlyand;22CF +curlyor;22CE +currency;00A4 +cyrBreve;F6D1 +cyrFlex;F6D2 +cyrbreve;F6D4 +cyrflex;F6D5 +d;0064 +daarmenian;0564 +dabengali;09A6 +dadarabic;0636 +dadeva;0926 +dadfinalarabic;FEBE +dadinitialarabic;FEBF +dadmedialarabic;FEC0 +dagesh;05BC +dageshhebrew;05BC +dagger;2020 +daggerdbl;2021 +dagujarati;0AA6 +dagurmukhi;0A26 +dahiragana;3060 +dakatakana;30C0 +dalarabic;062F +dalet;05D3 +daletdagesh;FB33 +daletdageshhebrew;FB33 +dalethatafpatah;05D3 05B2 +dalethatafpatahhebrew;05D3 05B2 +dalethatafsegol;05D3 05B1 +dalethatafsegolhebrew;05D3 05B1 +dalethebrew;05D3 +dalethiriq;05D3 05B4 +dalethiriqhebrew;05D3 05B4 +daletholam;05D3 05B9 +daletholamhebrew;05D3 05B9 +daletpatah;05D3 05B7 +daletpatahhebrew;05D3 05B7 +daletqamats;05D3 05B8 +daletqamatshebrew;05D3 05B8 +daletqubuts;05D3 05BB +daletqubutshebrew;05D3 05BB +daletsegol;05D3 05B6 +daletsegolhebrew;05D3 05B6 +daletsheva;05D3 05B0 +daletshevahebrew;05D3 05B0 +dalettsere;05D3 05B5 +dalettserehebrew;05D3 05B5 +dalfinalarabic;FEAA +dammaarabic;064F +dammalowarabic;064F +dammatanaltonearabic;064C +dammatanarabic;064C +danda;0964 +dargahebrew;05A7 +dargalefthebrew;05A7 +dasiapneumatacyrilliccmb;0485 +dblGrave;F6D3 +dblanglebracketleft;300A +dblanglebracketleftvertical;FE3D +dblanglebracketright;300B +dblanglebracketrightvertical;FE3E +dblarchinvertedbelowcmb;032B +dblarrowleft;21D4 +dblarrowright;21D2 +dbldanda;0965 +dblgrave;F6D6 +dblgravecmb;030F +dblintegral;222C +dbllowline;2017 +dbllowlinecmb;0333 +dbloverlinecmb;033F +dblprimemod;02BA +dblverticalbar;2016 +dblverticallineabovecmb;030E +dbopomofo;3109 +dbsquare;33C8 +dcaron;010F +dcedilla;1E11 +dcircle;24D3 +dcircumflexbelow;1E13 +dcroat;0111 +ddabengali;09A1 +ddadeva;0921 +ddagujarati;0AA1 +ddagurmukhi;0A21 +ddalarabic;0688 +ddalfinalarabic;FB89 +dddhadeva;095C +ddhabengali;09A2 +ddhadeva;0922 +ddhagujarati;0AA2 +ddhagurmukhi;0A22 +ddotaccent;1E0B +ddotbelow;1E0D +decimalseparatorarabic;066B +decimalseparatorpersian;066B +decyrillic;0434 +degree;00B0 +dehihebrew;05AD +dehiragana;3067 +deicoptic;03EF +dekatakana;30C7 +deleteleft;232B +deleteright;2326 +delta;03B4 +deltaturned;018D +denominatorminusonenumeratorbengali;09F8 +dezh;02A4 +dhabengali;09A7 +dhadeva;0927 +dhagujarati;0AA7 +dhagurmukhi;0A27 +dhook;0257 +dialytikatonos;0385 +dialytikatonoscmb;0344 +diamond;2666 +diamondsuitwhite;2662 +dieresis;00A8 +dieresisacute;F6D7 +dieresisbelowcmb;0324 +dieresiscmb;0308 +dieresisgrave;F6D8 +dieresistonos;0385 +dihiragana;3062 +dikatakana;30C2 +dittomark;3003 +divide;00F7 +divides;2223 +divisionslash;2215 +djecyrillic;0452 +dkshade;2593 +dlinebelow;1E0F +dlsquare;3397 +dmacron;0111 +dmonospace;FF44 +dnblock;2584 +dochadathai;0E0E +dodekthai;0E14 +dohiragana;3069 +dokatakana;30C9 +dollar;0024 +dollarinferior;F6E3 +dollarmonospace;FF04 +dollaroldstyle;F724 +dollarsmall;FE69 +dollarsuperior;F6E4 +dong;20AB +dorusquare;3326 +dotaccent;02D9 +dotaccentcmb;0307 +dotbelowcmb;0323 +dotbelowcomb;0323 +dotkatakana;30FB +dotlessi;0131 +dotlessj;F6BE +dotlessjstrokehook;0284 +dotmath;22C5 +dottedcircle;25CC +doubleyodpatah;FB1F +doubleyodpatahhebrew;FB1F +downtackbelowcmb;031E +downtackmod;02D5 +dparen;249F +dsuperior;F6EB +dtail;0256 +dtopbar;018C +duhiragana;3065 +dukatakana;30C5 +dz;01F3 +dzaltone;02A3 +dzcaron;01C6 +dzcurl;02A5 +dzeabkhasiancyrillic;04E1 +dzecyrillic;0455 +dzhecyrillic;045F +e;0065 +eacute;00E9 +earth;2641 +ebengali;098F +ebopomofo;311C +ebreve;0115 +ecandradeva;090D +ecandragujarati;0A8D +ecandravowelsigndeva;0945 +ecandravowelsigngujarati;0AC5 +ecaron;011B +ecedillabreve;1E1D +echarmenian;0565 +echyiwnarmenian;0587 +ecircle;24D4 +ecircumflex;00EA +ecircumflexacute;1EBF +ecircumflexbelow;1E19 +ecircumflexdotbelow;1EC7 +ecircumflexgrave;1EC1 +ecircumflexhookabove;1EC3 +ecircumflextilde;1EC5 +ecyrillic;0454 +edblgrave;0205 +edeva;090F +edieresis;00EB +edot;0117 +edotaccent;0117 +edotbelow;1EB9 +eegurmukhi;0A0F +eematragurmukhi;0A47 +efcyrillic;0444 +egrave;00E8 +egujarati;0A8F +eharmenian;0567 +ehbopomofo;311D +ehiragana;3048 +ehookabove;1EBB +eibopomofo;311F +eight;0038 +eightarabic;0668 +eightbengali;09EE +eightcircle;2467 +eightcircleinversesansserif;2791 +eightdeva;096E +eighteencircle;2471 +eighteenparen;2485 +eighteenperiod;2499 +eightgujarati;0AEE +eightgurmukhi;0A6E +eighthackarabic;0668 +eighthangzhou;3028 +eighthnotebeamed;266B +eightideographicparen;3227 +eightinferior;2088 +eightmonospace;FF18 +eightoldstyle;F738 +eightparen;247B +eightperiod;248F +eightpersian;06F8 +eightroman;2177 +eightsuperior;2078 +eightthai;0E58 +einvertedbreve;0207 +eiotifiedcyrillic;0465 +ekatakana;30A8 +ekatakanahalfwidth;FF74 +ekonkargurmukhi;0A74 +ekorean;3154 +elcyrillic;043B +element;2208 +elevencircle;246A +elevenparen;247E +elevenperiod;2492 +elevenroman;217A +ellipsis;2026 +ellipsisvertical;22EE +emacron;0113 +emacronacute;1E17 +emacrongrave;1E15 +emcyrillic;043C +emdash;2014 +emdashvertical;FE31 +emonospace;FF45 +emphasismarkarmenian;055B +emptyset;2205 +enbopomofo;3123 +encyrillic;043D +endash;2013 +endashvertical;FE32 +endescendercyrillic;04A3 +eng;014B +engbopomofo;3125 +enghecyrillic;04A5 +enhookcyrillic;04C8 +enspace;2002 +eogonek;0119 +eokorean;3153 +eopen;025B +eopenclosed;029A +eopenreversed;025C +eopenreversedclosed;025E +eopenreversedhook;025D +eparen;24A0 +epsilon;03B5 +epsilontonos;03AD +equal;003D +equalmonospace;FF1D +equalsmall;FE66 +equalsuperior;207C +equivalence;2261 +erbopomofo;3126 +ercyrillic;0440 +ereversed;0258 +ereversedcyrillic;044D +escyrillic;0441 +esdescendercyrillic;04AB +esh;0283 +eshcurl;0286 +eshortdeva;090E +eshortvowelsigndeva;0946 +eshreversedloop;01AA +eshsquatreversed;0285 +esmallhiragana;3047 +esmallkatakana;30A7 +esmallkatakanahalfwidth;FF6A +estimated;212E +esuperior;F6EC +eta;03B7 +etarmenian;0568 +etatonos;03AE +eth;00F0 +etilde;1EBD +etildebelow;1E1B +etnahtafoukhhebrew;0591 +etnahtafoukhlefthebrew;0591 +etnahtahebrew;0591 +etnahtalefthebrew;0591 +eturned;01DD +eukorean;3161 +euro;20AC +evowelsignbengali;09C7 +evowelsigndeva;0947 +evowelsigngujarati;0AC7 +exclam;0021 +exclamarmenian;055C +exclamdbl;203C +exclamdown;00A1 +exclamdownsmall;F7A1 +exclammonospace;FF01 +exclamsmall;F721 +existential;2203 +ezh;0292 +ezhcaron;01EF +ezhcurl;0293 +ezhreversed;01B9 +ezhtail;01BA +f;0066 +fadeva;095E +fagurmukhi;0A5E +fahrenheit;2109 +fathaarabic;064E +fathalowarabic;064E +fathatanarabic;064B +fbopomofo;3108 +fcircle;24D5 +fdotaccent;1E1F +feharabic;0641 +feharmenian;0586 +fehfinalarabic;FED2 +fehinitialarabic;FED3 +fehmedialarabic;FED4 +feicoptic;03E5 +female;2640 +ff;FB00 +ffi;FB03 +ffl;FB04 +fi;FB01 +fifteencircle;246E +fifteenparen;2482 +fifteenperiod;2496 +figuredash;2012 +filledbox;25A0 +filledrect;25AC +finalkaf;05DA +finalkafdagesh;FB3A +finalkafdageshhebrew;FB3A +finalkafhebrew;05DA +finalkafqamats;05DA 05B8 +finalkafqamatshebrew;05DA 05B8 +finalkafsheva;05DA 05B0 +finalkafshevahebrew;05DA 05B0 +finalmem;05DD +finalmemhebrew;05DD +finalnun;05DF +finalnunhebrew;05DF +finalpe;05E3 +finalpehebrew;05E3 +finaltsadi;05E5 +finaltsadihebrew;05E5 +firsttonechinese;02C9 +fisheye;25C9 +fitacyrillic;0473 +five;0035 +fivearabic;0665 +fivebengali;09EB +fivecircle;2464 +fivecircleinversesansserif;278E +fivedeva;096B +fiveeighths;215D +fivegujarati;0AEB +fivegurmukhi;0A6B +fivehackarabic;0665 +fivehangzhou;3025 +fiveideographicparen;3224 +fiveinferior;2085 +fivemonospace;FF15 +fiveoldstyle;F735 +fiveparen;2478 +fiveperiod;248C +fivepersian;06F5 +fiveroman;2174 +fivesuperior;2075 +fivethai;0E55 +fl;FB02 +florin;0192 +fmonospace;FF46 +fmsquare;3399 +fofanthai;0E1F +fofathai;0E1D +fongmanthai;0E4F +forall;2200 +four;0034 +fourarabic;0664 +fourbengali;09EA +fourcircle;2463 +fourcircleinversesansserif;278D +fourdeva;096A +fourgujarati;0AEA +fourgurmukhi;0A6A +fourhackarabic;0664 +fourhangzhou;3024 +fourideographicparen;3223 +fourinferior;2084 +fourmonospace;FF14 +fournumeratorbengali;09F7 +fouroldstyle;F734 +fourparen;2477 +fourperiod;248B +fourpersian;06F4 +fourroman;2173 +foursuperior;2074 +fourteencircle;246D +fourteenparen;2481 +fourteenperiod;2495 +fourthai;0E54 +fourthtonechinese;02CB +fparen;24A1 +fraction;2044 +franc;20A3 +g;0067 +gabengali;0997 +gacute;01F5 +gadeva;0917 +gafarabic;06AF +gaffinalarabic;FB93 +gafinitialarabic;FB94 +gafmedialarabic;FB95 +gagujarati;0A97 +gagurmukhi;0A17 +gahiragana;304C +gakatakana;30AC +gamma;03B3 +gammalatinsmall;0263 +gammasuperior;02E0 +gangiacoptic;03EB +gbopomofo;310D +gbreve;011F +gcaron;01E7 +gcedilla;0123 +gcircle;24D6 +gcircumflex;011D +gcommaaccent;0123 +gdot;0121 +gdotaccent;0121 +gecyrillic;0433 +gehiragana;3052 +gekatakana;30B2 +geometricallyequal;2251 +gereshaccenthebrew;059C +gereshhebrew;05F3 +gereshmuqdamhebrew;059D +germandbls;00DF +gershayimaccenthebrew;059E +gershayimhebrew;05F4 +getamark;3013 +ghabengali;0998 +ghadarmenian;0572 +ghadeva;0918 +ghagujarati;0A98 +ghagurmukhi;0A18 +ghainarabic;063A +ghainfinalarabic;FECE +ghaininitialarabic;FECF +ghainmedialarabic;FED0 +ghemiddlehookcyrillic;0495 +ghestrokecyrillic;0493 +gheupturncyrillic;0491 +ghhadeva;095A +ghhagurmukhi;0A5A +ghook;0260 +ghzsquare;3393 +gihiragana;304E +gikatakana;30AE +gimarmenian;0563 +gimel;05D2 +gimeldagesh;FB32 +gimeldageshhebrew;FB32 +gimelhebrew;05D2 +gjecyrillic;0453 +glottalinvertedstroke;01BE +glottalstop;0294 +glottalstopinverted;0296 +glottalstopmod;02C0 +glottalstopreversed;0295 +glottalstopreversedmod;02C1 +glottalstopreversedsuperior;02E4 +glottalstopstroke;02A1 +glottalstopstrokereversed;02A2 +gmacron;1E21 +gmonospace;FF47 +gohiragana;3054 +gokatakana;30B4 +gparen;24A2 +gpasquare;33AC +gradient;2207 +grave;0060 +gravebelowcmb;0316 +gravecmb;0300 +gravecomb;0300 +gravedeva;0953 +gravelowmod;02CE +gravemonospace;FF40 +gravetonecmb;0340 +greater;003E +greaterequal;2265 +greaterequalorless;22DB +greatermonospace;FF1E +greaterorequivalent;2273 +greaterorless;2277 +greateroverequal;2267 +greatersmall;FE65 +gscript;0261 +gstroke;01E5 +guhiragana;3050 +guillemotleft;00AB +guillemotright;00BB +guilsinglleft;2039 +guilsinglright;203A +gukatakana;30B0 +guramusquare;3318 +gysquare;33C9 +h;0068 +haabkhasiancyrillic;04A9 +haaltonearabic;06C1 +habengali;09B9 +hadescendercyrillic;04B3 +hadeva;0939 +hagujarati;0AB9 +hagurmukhi;0A39 +haharabic;062D +hahfinalarabic;FEA2 +hahinitialarabic;FEA3 +hahiragana;306F +hahmedialarabic;FEA4 +haitusquare;332A +hakatakana;30CF +hakatakanahalfwidth;FF8A +halantgurmukhi;0A4D +hamzaarabic;0621 +hamzadammaarabic;0621 064F +hamzadammatanarabic;0621 064C +hamzafathaarabic;0621 064E +hamzafathatanarabic;0621 064B +hamzalowarabic;0621 +hamzalowkasraarabic;0621 0650 +hamzalowkasratanarabic;0621 064D +hamzasukunarabic;0621 0652 +hangulfiller;3164 +hardsigncyrillic;044A +harpoonleftbarbup;21BC +harpoonrightbarbup;21C0 +hasquare;33CA +hatafpatah;05B2 +hatafpatah16;05B2 +hatafpatah23;05B2 +hatafpatah2f;05B2 +hatafpatahhebrew;05B2 +hatafpatahnarrowhebrew;05B2 +hatafpatahquarterhebrew;05B2 +hatafpatahwidehebrew;05B2 +hatafqamats;05B3 +hatafqamats1b;05B3 +hatafqamats28;05B3 +hatafqamats34;05B3 +hatafqamatshebrew;05B3 +hatafqamatsnarrowhebrew;05B3 +hatafqamatsquarterhebrew;05B3 +hatafqamatswidehebrew;05B3 +hatafsegol;05B1 +hatafsegol17;05B1 +hatafsegol24;05B1 +hatafsegol30;05B1 +hatafsegolhebrew;05B1 +hatafsegolnarrowhebrew;05B1 +hatafsegolquarterhebrew;05B1 +hatafsegolwidehebrew;05B1 +hbar;0127 +hbopomofo;310F +hbrevebelow;1E2B +hcedilla;1E29 +hcircle;24D7 +hcircumflex;0125 +hdieresis;1E27 +hdotaccent;1E23 +hdotbelow;1E25 +he;05D4 +heart;2665 +heartsuitblack;2665 +heartsuitwhite;2661 +hedagesh;FB34 +hedageshhebrew;FB34 +hehaltonearabic;06C1 +heharabic;0647 +hehebrew;05D4 +hehfinalaltonearabic;FBA7 +hehfinalalttwoarabic;FEEA +hehfinalarabic;FEEA +hehhamzaabovefinalarabic;FBA5 +hehhamzaaboveisolatedarabic;FBA4 +hehinitialaltonearabic;FBA8 +hehinitialarabic;FEEB +hehiragana;3078 +hehmedialaltonearabic;FBA9 +hehmedialarabic;FEEC +heiseierasquare;337B +hekatakana;30D8 +hekatakanahalfwidth;FF8D +hekutaarusquare;3336 +henghook;0267 +herutusquare;3339 +het;05D7 +hethebrew;05D7 +hhook;0266 +hhooksuperior;02B1 +hieuhacirclekorean;327B +hieuhaparenkorean;321B +hieuhcirclekorean;326D +hieuhkorean;314E +hieuhparenkorean;320D +hihiragana;3072 +hikatakana;30D2 +hikatakanahalfwidth;FF8B +hiriq;05B4 +hiriq14;05B4 +hiriq21;05B4 +hiriq2d;05B4 +hiriqhebrew;05B4 +hiriqnarrowhebrew;05B4 +hiriqquarterhebrew;05B4 +hiriqwidehebrew;05B4 +hlinebelow;1E96 +hmonospace;FF48 +hoarmenian;0570 +hohipthai;0E2B +hohiragana;307B +hokatakana;30DB +hokatakanahalfwidth;FF8E +holam;05B9 +holam19;05B9 +holam26;05B9 +holam32;05B9 +holamhebrew;05B9 +holamnarrowhebrew;05B9 +holamquarterhebrew;05B9 +holamwidehebrew;05B9 +honokhukthai;0E2E +hookabovecomb;0309 +hookcmb;0309 +hookpalatalizedbelowcmb;0321 +hookretroflexbelowcmb;0322 +hoonsquare;3342 +horicoptic;03E9 +horizontalbar;2015 +horncmb;031B +hotsprings;2668 +house;2302 +hparen;24A3 +hsuperior;02B0 +hturned;0265 +huhiragana;3075 +huiitosquare;3333 +hukatakana;30D5 +hukatakanahalfwidth;FF8C +hungarumlaut;02DD +hungarumlautcmb;030B +hv;0195 +hyphen;002D +hypheninferior;F6E5 +hyphenmonospace;FF0D +hyphensmall;FE63 +hyphensuperior;F6E6 +hyphentwo;2010 +i;0069 +iacute;00ED +iacyrillic;044F +ibengali;0987 +ibopomofo;3127 +ibreve;012D +icaron;01D0 +icircle;24D8 +icircumflex;00EE +icyrillic;0456 +idblgrave;0209 +ideographearthcircle;328F +ideographfirecircle;328B +ideographicallianceparen;323F +ideographiccallparen;323A +ideographiccentrecircle;32A5 +ideographicclose;3006 +ideographiccomma;3001 +ideographiccommaleft;FF64 +ideographiccongratulationparen;3237 +ideographiccorrectcircle;32A3 +ideographicearthparen;322F +ideographicenterpriseparen;323D +ideographicexcellentcircle;329D +ideographicfestivalparen;3240 +ideographicfinancialcircle;3296 +ideographicfinancialparen;3236 +ideographicfireparen;322B +ideographichaveparen;3232 +ideographichighcircle;32A4 +ideographiciterationmark;3005 +ideographiclaborcircle;3298 +ideographiclaborparen;3238 +ideographicleftcircle;32A7 +ideographiclowcircle;32A6 +ideographicmedicinecircle;32A9 +ideographicmetalparen;322E +ideographicmoonparen;322A +ideographicnameparen;3234 +ideographicperiod;3002 +ideographicprintcircle;329E +ideographicreachparen;3243 +ideographicrepresentparen;3239 +ideographicresourceparen;323E +ideographicrightcircle;32A8 +ideographicsecretcircle;3299 +ideographicselfparen;3242 +ideographicsocietyparen;3233 +ideographicspace;3000 +ideographicspecialparen;3235 +ideographicstockparen;3231 +ideographicstudyparen;323B +ideographicsunparen;3230 +ideographicsuperviseparen;323C +ideographicwaterparen;322C +ideographicwoodparen;322D +ideographiczero;3007 +ideographmetalcircle;328E +ideographmooncircle;328A +ideographnamecircle;3294 +ideographsuncircle;3290 +ideographwatercircle;328C +ideographwoodcircle;328D +ideva;0907 +idieresis;00EF +idieresisacute;1E2F +idieresiscyrillic;04E5 +idotbelow;1ECB +iebrevecyrillic;04D7 +iecyrillic;0435 +ieungacirclekorean;3275 +ieungaparenkorean;3215 +ieungcirclekorean;3267 +ieungkorean;3147 +ieungparenkorean;3207 +igrave;00EC +igujarati;0A87 +igurmukhi;0A07 +ihiragana;3044 +ihookabove;1EC9 +iibengali;0988 +iicyrillic;0438 +iideva;0908 +iigujarati;0A88 +iigurmukhi;0A08 +iimatragurmukhi;0A40 +iinvertedbreve;020B +iishortcyrillic;0439 +iivowelsignbengali;09C0 +iivowelsigndeva;0940 +iivowelsigngujarati;0AC0 +ij;0133 +ikatakana;30A4 +ikatakanahalfwidth;FF72 +ikorean;3163 +ilde;02DC +iluyhebrew;05AC +imacron;012B +imacroncyrillic;04E3 +imageorapproximatelyequal;2253 +imatragurmukhi;0A3F +imonospace;FF49 +increment;2206 +infinity;221E +iniarmenian;056B +integral;222B +integralbottom;2321 +integralbt;2321 +integralex;F8F5 +integraltop;2320 +integraltp;2320 +intersection;2229 +intisquare;3305 +invbullet;25D8 +invcircle;25D9 +invsmileface;263B +iocyrillic;0451 +iogonek;012F +iota;03B9 +iotadieresis;03CA +iotadieresistonos;0390 +iotalatin;0269 +iotatonos;03AF +iparen;24A4 +irigurmukhi;0A72 +ismallhiragana;3043 +ismallkatakana;30A3 +ismallkatakanahalfwidth;FF68 +issharbengali;09FA +istroke;0268 +isuperior;F6ED +iterationhiragana;309D +iterationkatakana;30FD +itilde;0129 +itildebelow;1E2D +iubopomofo;3129 +iucyrillic;044E +ivowelsignbengali;09BF +ivowelsigndeva;093F +ivowelsigngujarati;0ABF +izhitsacyrillic;0475 +izhitsadblgravecyrillic;0477 +j;006A +jaarmenian;0571 +jabengali;099C +jadeva;091C +jagujarati;0A9C +jagurmukhi;0A1C +jbopomofo;3110 +jcaron;01F0 +jcircle;24D9 +jcircumflex;0135 +jcrossedtail;029D +jdotlessstroke;025F +jecyrillic;0458 +jeemarabic;062C +jeemfinalarabic;FE9E +jeeminitialarabic;FE9F +jeemmedialarabic;FEA0 +jeharabic;0698 +jehfinalarabic;FB8B +jhabengali;099D +jhadeva;091D +jhagujarati;0A9D +jhagurmukhi;0A1D +jheharmenian;057B +jis;3004 +jmonospace;FF4A +jparen;24A5 +jsuperior;02B2 +k;006B +kabashkircyrillic;04A1 +kabengali;0995 +kacute;1E31 +kacyrillic;043A +kadescendercyrillic;049B +kadeva;0915 +kaf;05DB +kafarabic;0643 +kafdagesh;FB3B +kafdageshhebrew;FB3B +kaffinalarabic;FEDA +kafhebrew;05DB +kafinitialarabic;FEDB +kafmedialarabic;FEDC +kafrafehebrew;FB4D +kagujarati;0A95 +kagurmukhi;0A15 +kahiragana;304B +kahookcyrillic;04C4 +kakatakana;30AB +kakatakanahalfwidth;FF76 +kappa;03BA +kappasymbolgreek;03F0 +kapyeounmieumkorean;3171 +kapyeounphieuphkorean;3184 +kapyeounpieupkorean;3178 +kapyeounssangpieupkorean;3179 +karoriisquare;330D +kashidaautoarabic;0640 +kashidaautonosidebearingarabic;0640 +kasmallkatakana;30F5 +kasquare;3384 +kasraarabic;0650 +kasratanarabic;064D +kastrokecyrillic;049F +katahiraprolongmarkhalfwidth;FF70 +kaverticalstrokecyrillic;049D +kbopomofo;310E +kcalsquare;3389 +kcaron;01E9 +kcedilla;0137 +kcircle;24DA +kcommaaccent;0137 +kdotbelow;1E33 +keharmenian;0584 +kehiragana;3051 +kekatakana;30B1 +kekatakanahalfwidth;FF79 +kenarmenian;056F +kesmallkatakana;30F6 +kgreenlandic;0138 +khabengali;0996 +khacyrillic;0445 +khadeva;0916 +khagujarati;0A96 +khagurmukhi;0A16 +khaharabic;062E +khahfinalarabic;FEA6 +khahinitialarabic;FEA7 +khahmedialarabic;FEA8 +kheicoptic;03E7 +khhadeva;0959 +khhagurmukhi;0A59 +khieukhacirclekorean;3278 +khieukhaparenkorean;3218 +khieukhcirclekorean;326A +khieukhkorean;314B +khieukhparenkorean;320A +khokhaithai;0E02 +khokhonthai;0E05 +khokhuatthai;0E03 +khokhwaithai;0E04 +khomutthai;0E5B +khook;0199 +khorakhangthai;0E06 +khzsquare;3391 +kihiragana;304D +kikatakana;30AD +kikatakanahalfwidth;FF77 +kiroguramusquare;3315 +kiromeetorusquare;3316 +kirosquare;3314 +kiyeokacirclekorean;326E +kiyeokaparenkorean;320E +kiyeokcirclekorean;3260 +kiyeokkorean;3131 +kiyeokparenkorean;3200 +kiyeoksioskorean;3133 +kjecyrillic;045C +klinebelow;1E35 +klsquare;3398 +kmcubedsquare;33A6 +kmonospace;FF4B +kmsquaredsquare;33A2 +kohiragana;3053 +kohmsquare;33C0 +kokaithai;0E01 +kokatakana;30B3 +kokatakanahalfwidth;FF7A +kooposquare;331E +koppacyrillic;0481 +koreanstandardsymbol;327F +koroniscmb;0343 +kparen;24A6 +kpasquare;33AA +ksicyrillic;046F +ktsquare;33CF +kturned;029E +kuhiragana;304F +kukatakana;30AF +kukatakanahalfwidth;FF78 +kvsquare;33B8 +kwsquare;33BE +l;006C +labengali;09B2 +lacute;013A +ladeva;0932 +lagujarati;0AB2 +lagurmukhi;0A32 +lakkhangyaothai;0E45 +lamaleffinalarabic;FEFC +lamalefhamzaabovefinalarabic;FEF8 +lamalefhamzaaboveisolatedarabic;FEF7 +lamalefhamzabelowfinalarabic;FEFA +lamalefhamzabelowisolatedarabic;FEF9 +lamalefisolatedarabic;FEFB +lamalefmaddaabovefinalarabic;FEF6 +lamalefmaddaaboveisolatedarabic;FEF5 +lamarabic;0644 +lambda;03BB +lambdastroke;019B +lamed;05DC +lameddagesh;FB3C +lameddageshhebrew;FB3C +lamedhebrew;05DC +lamedholam;05DC 05B9 +lamedholamdagesh;05DC 05B9 05BC +lamedholamdageshhebrew;05DC 05B9 05BC +lamedholamhebrew;05DC 05B9 +lamfinalarabic;FEDE +lamhahinitialarabic;FCCA +laminitialarabic;FEDF +lamjeeminitialarabic;FCC9 +lamkhahinitialarabic;FCCB +lamlamhehisolatedarabic;FDF2 +lammedialarabic;FEE0 +lammeemhahinitialarabic;FD88 +lammeeminitialarabic;FCCC +lammeemjeeminitialarabic;FEDF FEE4 FEA0 +lammeemkhahinitialarabic;FEDF FEE4 FEA8 +largecircle;25EF +lbar;019A +lbelt;026C +lbopomofo;310C +lcaron;013E +lcedilla;013C +lcircle;24DB +lcircumflexbelow;1E3D +lcommaaccent;013C +ldot;0140 +ldotaccent;0140 +ldotbelow;1E37 +ldotbelowmacron;1E39 +leftangleabovecmb;031A +lefttackbelowcmb;0318 +less;003C +lessequal;2264 +lessequalorgreater;22DA +lessmonospace;FF1C +lessorequivalent;2272 +lessorgreater;2276 +lessoverequal;2266 +lesssmall;FE64 +lezh;026E +lfblock;258C +lhookretroflex;026D +lira;20A4 +liwnarmenian;056C +lj;01C9 +ljecyrillic;0459 +ll;F6C0 +lladeva;0933 +llagujarati;0AB3 +llinebelow;1E3B +llladeva;0934 +llvocalicbengali;09E1 +llvocalicdeva;0961 +llvocalicvowelsignbengali;09E3 +llvocalicvowelsigndeva;0963 +lmiddletilde;026B +lmonospace;FF4C +lmsquare;33D0 +lochulathai;0E2C +logicaland;2227 +logicalnot;00AC +logicalnotreversed;2310 +logicalor;2228 +lolingthai;0E25 +longs;017F +lowlinecenterline;FE4E +lowlinecmb;0332 +lowlinedashed;FE4D +lozenge;25CA +lparen;24A7 +lslash;0142 +lsquare;2113 +lsuperior;F6EE +ltshade;2591 +luthai;0E26 +lvocalicbengali;098C +lvocalicdeva;090C +lvocalicvowelsignbengali;09E2 +lvocalicvowelsigndeva;0962 +lxsquare;33D3 +m;006D +mabengali;09AE +macron;00AF +macronbelowcmb;0331 +macroncmb;0304 +macronlowmod;02CD +macronmonospace;FFE3 +macute;1E3F +madeva;092E +magujarati;0AAE +magurmukhi;0A2E +mahapakhhebrew;05A4 +mahapakhlefthebrew;05A4 +mahiragana;307E +maichattawalowleftthai;F895 +maichattawalowrightthai;F894 +maichattawathai;0E4B +maichattawaupperleftthai;F893 +maieklowleftthai;F88C +maieklowrightthai;F88B +maiekthai;0E48 +maiekupperleftthai;F88A +maihanakatleftthai;F884 +maihanakatthai;0E31 +maitaikhuleftthai;F889 +maitaikhuthai;0E47 +maitholowleftthai;F88F +maitholowrightthai;F88E +maithothai;0E49 +maithoupperleftthai;F88D +maitrilowleftthai;F892 +maitrilowrightthai;F891 +maitrithai;0E4A +maitriupperleftthai;F890 +maiyamokthai;0E46 +makatakana;30DE +makatakanahalfwidth;FF8F +male;2642 +mansyonsquare;3347 +maqafhebrew;05BE +mars;2642 +masoracirclehebrew;05AF +masquare;3383 +mbopomofo;3107 +mbsquare;33D4 +mcircle;24DC +mcubedsquare;33A5 +mdotaccent;1E41 +mdotbelow;1E43 +meemarabic;0645 +meemfinalarabic;FEE2 +meeminitialarabic;FEE3 +meemmedialarabic;FEE4 +meemmeeminitialarabic;FCD1 +meemmeemisolatedarabic;FC48 +meetorusquare;334D +mehiragana;3081 +meizierasquare;337E +mekatakana;30E1 +mekatakanahalfwidth;FF92 +mem;05DE +memdagesh;FB3E +memdageshhebrew;FB3E +memhebrew;05DE +menarmenian;0574 +merkhahebrew;05A5 +merkhakefulahebrew;05A6 +merkhakefulalefthebrew;05A6 +merkhalefthebrew;05A5 +mhook;0271 +mhzsquare;3392 +middledotkatakanahalfwidth;FF65 +middot;00B7 +mieumacirclekorean;3272 +mieumaparenkorean;3212 +mieumcirclekorean;3264 +mieumkorean;3141 +mieumpansioskorean;3170 +mieumparenkorean;3204 +mieumpieupkorean;316E +mieumsioskorean;316F +mihiragana;307F +mikatakana;30DF +mikatakanahalfwidth;FF90 +minus;2212 +minusbelowcmb;0320 +minuscircle;2296 +minusmod;02D7 +minusplus;2213 +minute;2032 +miribaarusquare;334A +mirisquare;3349 +mlonglegturned;0270 +mlsquare;3396 +mmcubedsquare;33A3 +mmonospace;FF4D +mmsquaredsquare;339F +mohiragana;3082 +mohmsquare;33C1 +mokatakana;30E2 +mokatakanahalfwidth;FF93 +molsquare;33D6 +momathai;0E21 +moverssquare;33A7 +moverssquaredsquare;33A8 +mparen;24A8 +mpasquare;33AB +mssquare;33B3 +msuperior;F6EF +mturned;026F +mu;00B5 +mu1;00B5 +muasquare;3382 +muchgreater;226B +muchless;226A +mufsquare;338C +mugreek;03BC +mugsquare;338D +muhiragana;3080 +mukatakana;30E0 +mukatakanahalfwidth;FF91 +mulsquare;3395 +multiply;00D7 +mumsquare;339B +munahhebrew;05A3 +munahlefthebrew;05A3 +musicalnote;266A +musicalnotedbl;266B +musicflatsign;266D +musicsharpsign;266F +mussquare;33B2 +muvsquare;33B6 +muwsquare;33BC +mvmegasquare;33B9 +mvsquare;33B7 +mwmegasquare;33BF +mwsquare;33BD +n;006E +nabengali;09A8 +nabla;2207 +nacute;0144 +nadeva;0928 +nagujarati;0AA8 +nagurmukhi;0A28 +nahiragana;306A +nakatakana;30CA +nakatakanahalfwidth;FF85 +napostrophe;0149 +nasquare;3381 +nbopomofo;310B +nbspace;00A0 +ncaron;0148 +ncedilla;0146 +ncircle;24DD +ncircumflexbelow;1E4B +ncommaaccent;0146 +ndotaccent;1E45 +ndotbelow;1E47 +nehiragana;306D +nekatakana;30CD +nekatakanahalfwidth;FF88 +newsheqelsign;20AA +nfsquare;338B +ngabengali;0999 +ngadeva;0919 +ngagujarati;0A99 +ngagurmukhi;0A19 +ngonguthai;0E07 +nhiragana;3093 +nhookleft;0272 +nhookretroflex;0273 +nieunacirclekorean;326F +nieunaparenkorean;320F +nieuncieuckorean;3135 +nieuncirclekorean;3261 +nieunhieuhkorean;3136 +nieunkorean;3134 +nieunpansioskorean;3168 +nieunparenkorean;3201 +nieunsioskorean;3167 +nieuntikeutkorean;3166 +nihiragana;306B +nikatakana;30CB +nikatakanahalfwidth;FF86 +nikhahitleftthai;F899 +nikhahitthai;0E4D +nine;0039 +ninearabic;0669 +ninebengali;09EF +ninecircle;2468 +ninecircleinversesansserif;2792 +ninedeva;096F +ninegujarati;0AEF +ninegurmukhi;0A6F +ninehackarabic;0669 +ninehangzhou;3029 +nineideographicparen;3228 +nineinferior;2089 +ninemonospace;FF19 +nineoldstyle;F739 +nineparen;247C +nineperiod;2490 +ninepersian;06F9 +nineroman;2178 +ninesuperior;2079 +nineteencircle;2472 +nineteenparen;2486 +nineteenperiod;249A +ninethai;0E59 +nj;01CC +njecyrillic;045A +nkatakana;30F3 +nkatakanahalfwidth;FF9D +nlegrightlong;019E +nlinebelow;1E49 +nmonospace;FF4E +nmsquare;339A +nnabengali;09A3 +nnadeva;0923 +nnagujarati;0AA3 +nnagurmukhi;0A23 +nnnadeva;0929 +nohiragana;306E +nokatakana;30CE +nokatakanahalfwidth;FF89 +nonbreakingspace;00A0 +nonenthai;0E13 +nonuthai;0E19 +noonarabic;0646 +noonfinalarabic;FEE6 +noonghunnaarabic;06BA +noonghunnafinalarabic;FB9F +noonhehinitialarabic;FEE7 FEEC +nooninitialarabic;FEE7 +noonjeeminitialarabic;FCD2 +noonjeemisolatedarabic;FC4B +noonmedialarabic;FEE8 +noonmeeminitialarabic;FCD5 +noonmeemisolatedarabic;FC4E +noonnoonfinalarabic;FC8D +notcontains;220C +notelement;2209 +notelementof;2209 +notequal;2260 +notgreater;226F +notgreaternorequal;2271 +notgreaternorless;2279 +notidentical;2262 +notless;226E +notlessnorequal;2270 +notparallel;2226 +notprecedes;2280 +notsubset;2284 +notsucceeds;2281 +notsuperset;2285 +nowarmenian;0576 +nparen;24A9 +nssquare;33B1 +nsuperior;207F +ntilde;00F1 +nu;03BD +nuhiragana;306C +nukatakana;30CC +nukatakanahalfwidth;FF87 +nuktabengali;09BC +nuktadeva;093C +nuktagujarati;0ABC +nuktagurmukhi;0A3C +numbersign;0023 +numbersignmonospace;FF03 +numbersignsmall;FE5F +numeralsigngreek;0374 +numeralsignlowergreek;0375 +numero;2116 +nun;05E0 +nundagesh;FB40 +nundageshhebrew;FB40 +nunhebrew;05E0 +nvsquare;33B5 +nwsquare;33BB +nyabengali;099E +nyadeva;091E +nyagujarati;0A9E +nyagurmukhi;0A1E +o;006F +oacute;00F3 +oangthai;0E2D +obarred;0275 +obarredcyrillic;04E9 +obarreddieresiscyrillic;04EB +obengali;0993 +obopomofo;311B +obreve;014F +ocandradeva;0911 +ocandragujarati;0A91 +ocandravowelsigndeva;0949 +ocandravowelsigngujarati;0AC9 +ocaron;01D2 +ocircle;24DE +ocircumflex;00F4 +ocircumflexacute;1ED1 +ocircumflexdotbelow;1ED9 +ocircumflexgrave;1ED3 +ocircumflexhookabove;1ED5 +ocircumflextilde;1ED7 +ocyrillic;043E +odblacute;0151 +odblgrave;020D +odeva;0913 +odieresis;00F6 +odieresiscyrillic;04E7 +odotbelow;1ECD +oe;0153 +oekorean;315A +ogonek;02DB +ogonekcmb;0328 +ograve;00F2 +ogujarati;0A93 +oharmenian;0585 +ohiragana;304A +ohookabove;1ECF +ohorn;01A1 +ohornacute;1EDB +ohorndotbelow;1EE3 +ohorngrave;1EDD +ohornhookabove;1EDF +ohorntilde;1EE1 +ohungarumlaut;0151 +oi;01A3 +oinvertedbreve;020F +okatakana;30AA +okatakanahalfwidth;FF75 +okorean;3157 +olehebrew;05AB +omacron;014D +omacronacute;1E53 +omacrongrave;1E51 +omdeva;0950 +omega;03C9 +omega1;03D6 +omegacyrillic;0461 +omegalatinclosed;0277 +omegaroundcyrillic;047B +omegatitlocyrillic;047D +omegatonos;03CE +omgujarati;0AD0 +omicron;03BF +omicrontonos;03CC +omonospace;FF4F +one;0031 +onearabic;0661 +onebengali;09E7 +onecircle;2460 +onecircleinversesansserif;278A +onedeva;0967 +onedotenleader;2024 +oneeighth;215B +onefitted;F6DC +onegujarati;0AE7 +onegurmukhi;0A67 +onehackarabic;0661 +onehalf;00BD +onehangzhou;3021 +oneideographicparen;3220 +oneinferior;2081 +onemonospace;FF11 +onenumeratorbengali;09F4 +oneoldstyle;F731 +oneparen;2474 +oneperiod;2488 +onepersian;06F1 +onequarter;00BC +oneroman;2170 +onesuperior;00B9 +onethai;0E51 +onethird;2153 +oogonek;01EB +oogonekmacron;01ED +oogurmukhi;0A13 +oomatragurmukhi;0A4B +oopen;0254 +oparen;24AA +openbullet;25E6 +option;2325 +ordfeminine;00AA +ordmasculine;00BA +orthogonal;221F +oshortdeva;0912 +oshortvowelsigndeva;094A +oslash;00F8 +oslashacute;01FF +osmallhiragana;3049 +osmallkatakana;30A9 +osmallkatakanahalfwidth;FF6B +ostrokeacute;01FF +osuperior;F6F0 +otcyrillic;047F +otilde;00F5 +otildeacute;1E4D +otildedieresis;1E4F +oubopomofo;3121 +overline;203E +overlinecenterline;FE4A +overlinecmb;0305 +overlinedashed;FE49 +overlinedblwavy;FE4C +overlinewavy;FE4B +overscore;00AF +ovowelsignbengali;09CB +ovowelsigndeva;094B +ovowelsigngujarati;0ACB +p;0070 +paampssquare;3380 +paasentosquare;332B +pabengali;09AA +pacute;1E55 +padeva;092A +pagedown;21DF +pageup;21DE +pagujarati;0AAA +pagurmukhi;0A2A +pahiragana;3071 +paiyannoithai;0E2F +pakatakana;30D1 +palatalizationcyrilliccmb;0484 +palochkacyrillic;04C0 +pansioskorean;317F +paragraph;00B6 +parallel;2225 +parenleft;0028 +parenleftaltonearabic;FD3E +parenleftbt;F8ED +parenleftex;F8EC +parenleftinferior;208D +parenleftmonospace;FF08 +parenleftsmall;FE59 +parenleftsuperior;207D +parenlefttp;F8EB +parenleftvertical;FE35 +parenright;0029 +parenrightaltonearabic;FD3F +parenrightbt;F8F8 +parenrightex;F8F7 +parenrightinferior;208E +parenrightmonospace;FF09 +parenrightsmall;FE5A +parenrightsuperior;207E +parenrighttp;F8F6 +parenrightvertical;FE36 +partialdiff;2202 +paseqhebrew;05C0 +pashtahebrew;0599 +pasquare;33A9 +patah;05B7 +patah11;05B7 +patah1d;05B7 +patah2a;05B7 +patahhebrew;05B7 +patahnarrowhebrew;05B7 +patahquarterhebrew;05B7 +patahwidehebrew;05B7 +pazerhebrew;05A1 +pbopomofo;3106 +pcircle;24DF +pdotaccent;1E57 +pe;05E4 +pecyrillic;043F +pedagesh;FB44 +pedageshhebrew;FB44 +peezisquare;333B +pefinaldageshhebrew;FB43 +peharabic;067E +peharmenian;057A +pehebrew;05E4 +pehfinalarabic;FB57 +pehinitialarabic;FB58 +pehiragana;307A +pehmedialarabic;FB59 +pekatakana;30DA +pemiddlehookcyrillic;04A7 +perafehebrew;FB4E +percent;0025 +percentarabic;066A +percentmonospace;FF05 +percentsmall;FE6A +period;002E +periodarmenian;0589 +periodcentered;00B7 +periodhalfwidth;FF61 +periodinferior;F6E7 +periodmonospace;FF0E +periodsmall;FE52 +periodsuperior;F6E8 +perispomenigreekcmb;0342 +perpendicular;22A5 +perthousand;2030 +peseta;20A7 +pfsquare;338A +phabengali;09AB +phadeva;092B +phagujarati;0AAB +phagurmukhi;0A2B +phi;03C6 +phi1;03D5 +phieuphacirclekorean;327A +phieuphaparenkorean;321A +phieuphcirclekorean;326C +phieuphkorean;314D +phieuphparenkorean;320C +philatin;0278 +phinthuthai;0E3A +phisymbolgreek;03D5 +phook;01A5 +phophanthai;0E1E +phophungthai;0E1C +phosamphaothai;0E20 +pi;03C0 +pieupacirclekorean;3273 +pieupaparenkorean;3213 +pieupcieuckorean;3176 +pieupcirclekorean;3265 +pieupkiyeokkorean;3172 +pieupkorean;3142 +pieupparenkorean;3205 +pieupsioskiyeokkorean;3174 +pieupsioskorean;3144 +pieupsiostikeutkorean;3175 +pieupthieuthkorean;3177 +pieuptikeutkorean;3173 +pihiragana;3074 +pikatakana;30D4 +pisymbolgreek;03D6 +piwrarmenian;0583 +plus;002B +plusbelowcmb;031F +pluscircle;2295 +plusminus;00B1 +plusmod;02D6 +plusmonospace;FF0B +plussmall;FE62 +plussuperior;207A +pmonospace;FF50 +pmsquare;33D8 +pohiragana;307D +pointingindexdownwhite;261F +pointingindexleftwhite;261C +pointingindexrightwhite;261E +pointingindexupwhite;261D +pokatakana;30DD +poplathai;0E1B +postalmark;3012 +postalmarkface;3020 +pparen;24AB +precedes;227A +prescription;211E +primemod;02B9 +primereversed;2035 +product;220F +projective;2305 +prolongedkana;30FC +propellor;2318 +propersubset;2282 +propersuperset;2283 +proportion;2237 +proportional;221D +psi;03C8 +psicyrillic;0471 +psilipneumatacyrilliccmb;0486 +pssquare;33B0 +puhiragana;3077 +pukatakana;30D7 +pvsquare;33B4 +pwsquare;33BA +q;0071 +qadeva;0958 +qadmahebrew;05A8 +qafarabic;0642 +qaffinalarabic;FED6 +qafinitialarabic;FED7 +qafmedialarabic;FED8 +qamats;05B8 +qamats10;05B8 +qamats1a;05B8 +qamats1c;05B8 +qamats27;05B8 +qamats29;05B8 +qamats33;05B8 +qamatsde;05B8 +qamatshebrew;05B8 +qamatsnarrowhebrew;05B8 +qamatsqatanhebrew;05B8 +qamatsqatannarrowhebrew;05B8 +qamatsqatanquarterhebrew;05B8 +qamatsqatanwidehebrew;05B8 +qamatsquarterhebrew;05B8 +qamatswidehebrew;05B8 +qarneyparahebrew;059F +qbopomofo;3111 +qcircle;24E0 +qhook;02A0 +qmonospace;FF51 +qof;05E7 +qofdagesh;FB47 +qofdageshhebrew;FB47 +qofhatafpatah;05E7 05B2 +qofhatafpatahhebrew;05E7 05B2 +qofhatafsegol;05E7 05B1 +qofhatafsegolhebrew;05E7 05B1 +qofhebrew;05E7 +qofhiriq;05E7 05B4 +qofhiriqhebrew;05E7 05B4 +qofholam;05E7 05B9 +qofholamhebrew;05E7 05B9 +qofpatah;05E7 05B7 +qofpatahhebrew;05E7 05B7 +qofqamats;05E7 05B8 +qofqamatshebrew;05E7 05B8 +qofqubuts;05E7 05BB +qofqubutshebrew;05E7 05BB +qofsegol;05E7 05B6 +qofsegolhebrew;05E7 05B6 +qofsheva;05E7 05B0 +qofshevahebrew;05E7 05B0 +qoftsere;05E7 05B5 +qoftserehebrew;05E7 05B5 +qparen;24AC +quarternote;2669 +qubuts;05BB +qubuts18;05BB +qubuts25;05BB +qubuts31;05BB +qubutshebrew;05BB +qubutsnarrowhebrew;05BB +qubutsquarterhebrew;05BB +qubutswidehebrew;05BB +question;003F +questionarabic;061F +questionarmenian;055E +questiondown;00BF +questiondownsmall;F7BF +questiongreek;037E +questionmonospace;FF1F +questionsmall;F73F +quotedbl;0022 +quotedblbase;201E +quotedblleft;201C +quotedblmonospace;FF02 +quotedblprime;301E +quotedblprimereversed;301D +quotedblright;201D +quoteleft;2018 +quoteleftreversed;201B +quotereversed;201B +quoteright;2019 +quoterightn;0149 +quotesinglbase;201A +quotesingle;0027 +quotesinglemonospace;FF07 +r;0072 +raarmenian;057C +rabengali;09B0 +racute;0155 +radeva;0930 +radical;221A +radicalex;F8E5 +radoverssquare;33AE +radoverssquaredsquare;33AF +radsquare;33AD +rafe;05BF +rafehebrew;05BF +ragujarati;0AB0 +ragurmukhi;0A30 +rahiragana;3089 +rakatakana;30E9 +rakatakanahalfwidth;FF97 +ralowerdiagonalbengali;09F1 +ramiddlediagonalbengali;09F0 +ramshorn;0264 +ratio;2236 +rbopomofo;3116 +rcaron;0159 +rcedilla;0157 +rcircle;24E1 +rcommaaccent;0157 +rdblgrave;0211 +rdotaccent;1E59 +rdotbelow;1E5B +rdotbelowmacron;1E5D +referencemark;203B +reflexsubset;2286 +reflexsuperset;2287 +registered;00AE +registersans;F8E8 +registerserif;F6DA +reharabic;0631 +reharmenian;0580 +rehfinalarabic;FEAE +rehiragana;308C +rehyehaleflamarabic;0631 FEF3 FE8E 0644 +rekatakana;30EC +rekatakanahalfwidth;FF9A +resh;05E8 +reshdageshhebrew;FB48 +reshhatafpatah;05E8 05B2 +reshhatafpatahhebrew;05E8 05B2 +reshhatafsegol;05E8 05B1 +reshhatafsegolhebrew;05E8 05B1 +reshhebrew;05E8 +reshhiriq;05E8 05B4 +reshhiriqhebrew;05E8 05B4 +reshholam;05E8 05B9 +reshholamhebrew;05E8 05B9 +reshpatah;05E8 05B7 +reshpatahhebrew;05E8 05B7 +reshqamats;05E8 05B8 +reshqamatshebrew;05E8 05B8 +reshqubuts;05E8 05BB +reshqubutshebrew;05E8 05BB +reshsegol;05E8 05B6 +reshsegolhebrew;05E8 05B6 +reshsheva;05E8 05B0 +reshshevahebrew;05E8 05B0 +reshtsere;05E8 05B5 +reshtserehebrew;05E8 05B5 +reversedtilde;223D +reviahebrew;0597 +reviamugrashhebrew;0597 +revlogicalnot;2310 +rfishhook;027E +rfishhookreversed;027F +rhabengali;09DD +rhadeva;095D +rho;03C1 +rhook;027D +rhookturned;027B +rhookturnedsuperior;02B5 +rhosymbolgreek;03F1 +rhotichookmod;02DE +rieulacirclekorean;3271 +rieulaparenkorean;3211 +rieulcirclekorean;3263 +rieulhieuhkorean;3140 +rieulkiyeokkorean;313A +rieulkiyeoksioskorean;3169 +rieulkorean;3139 +rieulmieumkorean;313B +rieulpansioskorean;316C +rieulparenkorean;3203 +rieulphieuphkorean;313F +rieulpieupkorean;313C +rieulpieupsioskorean;316B +rieulsioskorean;313D +rieulthieuthkorean;313E +rieultikeutkorean;316A +rieulyeorinhieuhkorean;316D +rightangle;221F +righttackbelowcmb;0319 +righttriangle;22BF +rihiragana;308A +rikatakana;30EA +rikatakanahalfwidth;FF98 +ring;02DA +ringbelowcmb;0325 +ringcmb;030A +ringhalfleft;02BF +ringhalfleftarmenian;0559 +ringhalfleftbelowcmb;031C +ringhalfleftcentered;02D3 +ringhalfright;02BE +ringhalfrightbelowcmb;0339 +ringhalfrightcentered;02D2 +rinvertedbreve;0213 +rittorusquare;3351 +rlinebelow;1E5F +rlongleg;027C +rlonglegturned;027A +rmonospace;FF52 +rohiragana;308D +rokatakana;30ED +rokatakanahalfwidth;FF9B +roruathai;0E23 +rparen;24AD +rrabengali;09DC +rradeva;0931 +rragurmukhi;0A5C +rreharabic;0691 +rrehfinalarabic;FB8D +rrvocalicbengali;09E0 +rrvocalicdeva;0960 +rrvocalicgujarati;0AE0 +rrvocalicvowelsignbengali;09C4 +rrvocalicvowelsigndeva;0944 +rrvocalicvowelsigngujarati;0AC4 +rsuperior;F6F1 +rtblock;2590 +rturned;0279 +rturnedsuperior;02B4 +ruhiragana;308B +rukatakana;30EB +rukatakanahalfwidth;FF99 +rupeemarkbengali;09F2 +rupeesignbengali;09F3 +rupiah;F6DD +ruthai;0E24 +rvocalicbengali;098B +rvocalicdeva;090B +rvocalicgujarati;0A8B +rvocalicvowelsignbengali;09C3 +rvocalicvowelsigndeva;0943 +rvocalicvowelsigngujarati;0AC3 +s;0073 +sabengali;09B8 +sacute;015B +sacutedotaccent;1E65 +sadarabic;0635 +sadeva;0938 +sadfinalarabic;FEBA +sadinitialarabic;FEBB +sadmedialarabic;FEBC +sagujarati;0AB8 +sagurmukhi;0A38 +sahiragana;3055 +sakatakana;30B5 +sakatakanahalfwidth;FF7B +sallallahoualayhewasallamarabic;FDFA +samekh;05E1 +samekhdagesh;FB41 +samekhdageshhebrew;FB41 +samekhhebrew;05E1 +saraaathai;0E32 +saraaethai;0E41 +saraaimaimalaithai;0E44 +saraaimaimuanthai;0E43 +saraamthai;0E33 +saraathai;0E30 +saraethai;0E40 +saraiileftthai;F886 +saraiithai;0E35 +saraileftthai;F885 +saraithai;0E34 +saraothai;0E42 +saraueeleftthai;F888 +saraueethai;0E37 +saraueleftthai;F887 +sarauethai;0E36 +sarauthai;0E38 +sarauuthai;0E39 +sbopomofo;3119 +scaron;0161 +scarondotaccent;1E67 +scedilla;015F +schwa;0259 +schwacyrillic;04D9 +schwadieresiscyrillic;04DB +schwahook;025A +scircle;24E2 +scircumflex;015D +scommaaccent;0219 +sdotaccent;1E61 +sdotbelow;1E63 +sdotbelowdotaccent;1E69 +seagullbelowcmb;033C +second;2033 +secondtonechinese;02CA +section;00A7 +seenarabic;0633 +seenfinalarabic;FEB2 +seeninitialarabic;FEB3 +seenmedialarabic;FEB4 +segol;05B6 +segol13;05B6 +segol1f;05B6 +segol2c;05B6 +segolhebrew;05B6 +segolnarrowhebrew;05B6 +segolquarterhebrew;05B6 +segoltahebrew;0592 +segolwidehebrew;05B6 +seharmenian;057D +sehiragana;305B +sekatakana;30BB +sekatakanahalfwidth;FF7E +semicolon;003B +semicolonarabic;061B +semicolonmonospace;FF1B +semicolonsmall;FE54 +semivoicedmarkkana;309C +semivoicedmarkkanahalfwidth;FF9F +sentisquare;3322 +sentosquare;3323 +seven;0037 +sevenarabic;0667 +sevenbengali;09ED +sevencircle;2466 +sevencircleinversesansserif;2790 +sevendeva;096D +seveneighths;215E +sevengujarati;0AED +sevengurmukhi;0A6D +sevenhackarabic;0667 +sevenhangzhou;3027 +sevenideographicparen;3226 +seveninferior;2087 +sevenmonospace;FF17 +sevenoldstyle;F737 +sevenparen;247A +sevenperiod;248E +sevenpersian;06F7 +sevenroman;2176 +sevensuperior;2077 +seventeencircle;2470 +seventeenparen;2484 +seventeenperiod;2498 +seventhai;0E57 +sfthyphen;00AD +shaarmenian;0577 +shabengali;09B6 +shacyrillic;0448 +shaddaarabic;0651 +shaddadammaarabic;FC61 +shaddadammatanarabic;FC5E +shaddafathaarabic;FC60 +shaddafathatanarabic;0651 064B +shaddakasraarabic;FC62 +shaddakasratanarabic;FC5F +shade;2592 +shadedark;2593 +shadelight;2591 +shademedium;2592 +shadeva;0936 +shagujarati;0AB6 +shagurmukhi;0A36 +shalshelethebrew;0593 +shbopomofo;3115 +shchacyrillic;0449 +sheenarabic;0634 +sheenfinalarabic;FEB6 +sheeninitialarabic;FEB7 +sheenmedialarabic;FEB8 +sheicoptic;03E3 +sheqel;20AA +sheqelhebrew;20AA +sheva;05B0 +sheva115;05B0 +sheva15;05B0 +sheva22;05B0 +sheva2e;05B0 +shevahebrew;05B0 +shevanarrowhebrew;05B0 +shevaquarterhebrew;05B0 +shevawidehebrew;05B0 +shhacyrillic;04BB +shimacoptic;03ED +shin;05E9 +shindagesh;FB49 +shindageshhebrew;FB49 +shindageshshindot;FB2C +shindageshshindothebrew;FB2C +shindageshsindot;FB2D +shindageshsindothebrew;FB2D +shindothebrew;05C1 +shinhebrew;05E9 +shinshindot;FB2A +shinshindothebrew;FB2A +shinsindot;FB2B +shinsindothebrew;FB2B +shook;0282 +sigma;03C3 +sigma1;03C2 +sigmafinal;03C2 +sigmalunatesymbolgreek;03F2 +sihiragana;3057 +sikatakana;30B7 +sikatakanahalfwidth;FF7C +siluqhebrew;05BD +siluqlefthebrew;05BD +similar;223C +sindothebrew;05C2 +siosacirclekorean;3274 +siosaparenkorean;3214 +sioscieuckorean;317E +sioscirclekorean;3266 +sioskiyeokkorean;317A +sioskorean;3145 +siosnieunkorean;317B +siosparenkorean;3206 +siospieupkorean;317D +siostikeutkorean;317C +six;0036 +sixarabic;0666 +sixbengali;09EC +sixcircle;2465 +sixcircleinversesansserif;278F +sixdeva;096C +sixgujarati;0AEC +sixgurmukhi;0A6C +sixhackarabic;0666 +sixhangzhou;3026 +sixideographicparen;3225 +sixinferior;2086 +sixmonospace;FF16 +sixoldstyle;F736 +sixparen;2479 +sixperiod;248D +sixpersian;06F6 +sixroman;2175 +sixsuperior;2076 +sixteencircle;246F +sixteencurrencydenominatorbengali;09F9 +sixteenparen;2483 +sixteenperiod;2497 +sixthai;0E56 +slash;002F +slashmonospace;FF0F +slong;017F +slongdotaccent;1E9B +smileface;263A +smonospace;FF53 +sofpasuqhebrew;05C3 +softhyphen;00AD +softsigncyrillic;044C +sohiragana;305D +sokatakana;30BD +sokatakanahalfwidth;FF7F +soliduslongoverlaycmb;0338 +solidusshortoverlaycmb;0337 +sorusithai;0E29 +sosalathai;0E28 +sosothai;0E0B +sosuathai;0E2A +space;0020 +spacehackarabic;0020 +spade;2660 +spadesuitblack;2660 +spadesuitwhite;2664 +sparen;24AE +squarebelowcmb;033B +squarecc;33C4 +squarecm;339D +squarediagonalcrosshatchfill;25A9 +squarehorizontalfill;25A4 +squarekg;338F +squarekm;339E +squarekmcapital;33CE +squareln;33D1 +squarelog;33D2 +squaremg;338E +squaremil;33D5 +squaremm;339C +squaremsquared;33A1 +squareorthogonalcrosshatchfill;25A6 +squareupperlefttolowerrightfill;25A7 +squareupperrighttolowerleftfill;25A8 +squareverticalfill;25A5 +squarewhitewithsmallblack;25A3 +srsquare;33DB +ssabengali;09B7 +ssadeva;0937 +ssagujarati;0AB7 +ssangcieuckorean;3149 +ssanghieuhkorean;3185 +ssangieungkorean;3180 +ssangkiyeokkorean;3132 +ssangnieunkorean;3165 +ssangpieupkorean;3143 +ssangsioskorean;3146 +ssangtikeutkorean;3138 +ssuperior;F6F2 +sterling;00A3 +sterlingmonospace;FFE1 +strokelongoverlaycmb;0336 +strokeshortoverlaycmb;0335 +subset;2282 +subsetnotequal;228A +subsetorequal;2286 +succeeds;227B +suchthat;220B +suhiragana;3059 +sukatakana;30B9 +sukatakanahalfwidth;FF7D +sukunarabic;0652 +summation;2211 +sun;263C +superset;2283 +supersetnotequal;228B +supersetorequal;2287 +svsquare;33DC +syouwaerasquare;337C +t;0074 +tabengali;09A4 +tackdown;22A4 +tackleft;22A3 +tadeva;0924 +tagujarati;0AA4 +tagurmukhi;0A24 +taharabic;0637 +tahfinalarabic;FEC2 +tahinitialarabic;FEC3 +tahiragana;305F +tahmedialarabic;FEC4 +taisyouerasquare;337D +takatakana;30BF +takatakanahalfwidth;FF80 +tatweelarabic;0640 +tau;03C4 +tav;05EA +tavdages;FB4A +tavdagesh;FB4A +tavdageshhebrew;FB4A +tavhebrew;05EA +tbar;0167 +tbopomofo;310A +tcaron;0165 +tccurl;02A8 +tcedilla;0163 +tcheharabic;0686 +tchehfinalarabic;FB7B +tchehinitialarabic;FB7C +tchehmedialarabic;FB7D +tchehmeeminitialarabic;FB7C FEE4 +tcircle;24E3 +tcircumflexbelow;1E71 +tcommaaccent;0163 +tdieresis;1E97 +tdotaccent;1E6B +tdotbelow;1E6D +tecyrillic;0442 +tedescendercyrillic;04AD +teharabic;062A +tehfinalarabic;FE96 +tehhahinitialarabic;FCA2 +tehhahisolatedarabic;FC0C +tehinitialarabic;FE97 +tehiragana;3066 +tehjeeminitialarabic;FCA1 +tehjeemisolatedarabic;FC0B +tehmarbutaarabic;0629 +tehmarbutafinalarabic;FE94 +tehmedialarabic;FE98 +tehmeeminitialarabic;FCA4 +tehmeemisolatedarabic;FC0E +tehnoonfinalarabic;FC73 +tekatakana;30C6 +tekatakanahalfwidth;FF83 +telephone;2121 +telephoneblack;260E +telishagedolahebrew;05A0 +telishaqetanahebrew;05A9 +tencircle;2469 +tenideographicparen;3229 +tenparen;247D +tenperiod;2491 +tenroman;2179 +tesh;02A7 +tet;05D8 +tetdagesh;FB38 +tetdageshhebrew;FB38 +tethebrew;05D8 +tetsecyrillic;04B5 +tevirhebrew;059B +tevirlefthebrew;059B +thabengali;09A5 +thadeva;0925 +thagujarati;0AA5 +thagurmukhi;0A25 +thalarabic;0630 +thalfinalarabic;FEAC +thanthakhatlowleftthai;F898 +thanthakhatlowrightthai;F897 +thanthakhatthai;0E4C +thanthakhatupperleftthai;F896 +theharabic;062B +thehfinalarabic;FE9A +thehinitialarabic;FE9B +thehmedialarabic;FE9C +thereexists;2203 +therefore;2234 +theta;03B8 +theta1;03D1 +thetasymbolgreek;03D1 +thieuthacirclekorean;3279 +thieuthaparenkorean;3219 +thieuthcirclekorean;326B +thieuthkorean;314C +thieuthparenkorean;320B +thirteencircle;246C +thirteenparen;2480 +thirteenperiod;2494 +thonangmonthothai;0E11 +thook;01AD +thophuthaothai;0E12 +thorn;00FE +thothahanthai;0E17 +thothanthai;0E10 +thothongthai;0E18 +thothungthai;0E16 +thousandcyrillic;0482 +thousandsseparatorarabic;066C +thousandsseparatorpersian;066C +three;0033 +threearabic;0663 +threebengali;09E9 +threecircle;2462 +threecircleinversesansserif;278C +threedeva;0969 +threeeighths;215C +threegujarati;0AE9 +threegurmukhi;0A69 +threehackarabic;0663 +threehangzhou;3023 +threeideographicparen;3222 +threeinferior;2083 +threemonospace;FF13 +threenumeratorbengali;09F6 +threeoldstyle;F733 +threeparen;2476 +threeperiod;248A +threepersian;06F3 +threequarters;00BE +threequartersemdash;F6DE +threeroman;2172 +threesuperior;00B3 +threethai;0E53 +thzsquare;3394 +tihiragana;3061 +tikatakana;30C1 +tikatakanahalfwidth;FF81 +tikeutacirclekorean;3270 +tikeutaparenkorean;3210 +tikeutcirclekorean;3262 +tikeutkorean;3137 +tikeutparenkorean;3202 +tilde;02DC +tildebelowcmb;0330 +tildecmb;0303 +tildecomb;0303 +tildedoublecmb;0360 +tildeoperator;223C +tildeoverlaycmb;0334 +tildeverticalcmb;033E +timescircle;2297 +tipehahebrew;0596 +tipehalefthebrew;0596 +tippigurmukhi;0A70 +titlocyrilliccmb;0483 +tiwnarmenian;057F +tlinebelow;1E6F +tmonospace;FF54 +toarmenian;0569 +tohiragana;3068 +tokatakana;30C8 +tokatakanahalfwidth;FF84 +tonebarextrahighmod;02E5 +tonebarextralowmod;02E9 +tonebarhighmod;02E6 +tonebarlowmod;02E8 +tonebarmidmod;02E7 +tonefive;01BD +tonesix;0185 +tonetwo;01A8 +tonos;0384 +tonsquare;3327 +topatakthai;0E0F +tortoiseshellbracketleft;3014 +tortoiseshellbracketleftsmall;FE5D +tortoiseshellbracketleftvertical;FE39 +tortoiseshellbracketright;3015 +tortoiseshellbracketrightsmall;FE5E +tortoiseshellbracketrightvertical;FE3A +totaothai;0E15 +tpalatalhook;01AB +tparen;24AF +trademark;2122 +trademarksans;F8EA +trademarkserif;F6DB +tretroflexhook;0288 +triagdn;25BC +triaglf;25C4 +triagrt;25BA +triagup;25B2 +ts;02A6 +tsadi;05E6 +tsadidagesh;FB46 +tsadidageshhebrew;FB46 +tsadihebrew;05E6 +tsecyrillic;0446 +tsere;05B5 +tsere12;05B5 +tsere1e;05B5 +tsere2b;05B5 +tserehebrew;05B5 +tserenarrowhebrew;05B5 +tserequarterhebrew;05B5 +tserewidehebrew;05B5 +tshecyrillic;045B +tsuperior;F6F3 +ttabengali;099F +ttadeva;091F +ttagujarati;0A9F +ttagurmukhi;0A1F +tteharabic;0679 +ttehfinalarabic;FB67 +ttehinitialarabic;FB68 +ttehmedialarabic;FB69 +tthabengali;09A0 +tthadeva;0920 +tthagujarati;0AA0 +tthagurmukhi;0A20 +tturned;0287 +tuhiragana;3064 +tukatakana;30C4 +tukatakanahalfwidth;FF82 +tusmallhiragana;3063 +tusmallkatakana;30C3 +tusmallkatakanahalfwidth;FF6F +twelvecircle;246B +twelveparen;247F +twelveperiod;2493 +twelveroman;217B +twentycircle;2473 +twentyhangzhou;5344 +twentyparen;2487 +twentyperiod;249B +two;0032 +twoarabic;0662 +twobengali;09E8 +twocircle;2461 +twocircleinversesansserif;278B +twodeva;0968 +twodotenleader;2025 +twodotleader;2025 +twodotleadervertical;FE30 +twogujarati;0AE8 +twogurmukhi;0A68 +twohackarabic;0662 +twohangzhou;3022 +twoideographicparen;3221 +twoinferior;2082 +twomonospace;FF12 +twonumeratorbengali;09F5 +twooldstyle;F732 +twoparen;2475 +twoperiod;2489 +twopersian;06F2 +tworoman;2171 +twostroke;01BB +twosuperior;00B2 +twothai;0E52 +twothirds;2154 +u;0075 +uacute;00FA +ubar;0289 +ubengali;0989 +ubopomofo;3128 +ubreve;016D +ucaron;01D4 +ucircle;24E4 +ucircumflex;00FB +ucircumflexbelow;1E77 +ucyrillic;0443 +udattadeva;0951 +udblacute;0171 +udblgrave;0215 +udeva;0909 +udieresis;00FC +udieresisacute;01D8 +udieresisbelow;1E73 +udieresiscaron;01DA +udieresiscyrillic;04F1 +udieresisgrave;01DC +udieresismacron;01D6 +udotbelow;1EE5 +ugrave;00F9 +ugujarati;0A89 +ugurmukhi;0A09 +uhiragana;3046 +uhookabove;1EE7 +uhorn;01B0 +uhornacute;1EE9 +uhorndotbelow;1EF1 +uhorngrave;1EEB +uhornhookabove;1EED +uhorntilde;1EEF +uhungarumlaut;0171 +uhungarumlautcyrillic;04F3 +uinvertedbreve;0217 +ukatakana;30A6 +ukatakanahalfwidth;FF73 +ukcyrillic;0479 +ukorean;315C +umacron;016B +umacroncyrillic;04EF +umacrondieresis;1E7B +umatragurmukhi;0A41 +umonospace;FF55 +underscore;005F +underscoredbl;2017 +underscoremonospace;FF3F +underscorevertical;FE33 +underscorewavy;FE4F +union;222A +universal;2200 +uogonek;0173 +uparen;24B0 +upblock;2580 +upperdothebrew;05C4 +upsilon;03C5 +upsilondieresis;03CB +upsilondieresistonos;03B0 +upsilonlatin;028A +upsilontonos;03CD +uptackbelowcmb;031D +uptackmod;02D4 +uragurmukhi;0A73 +uring;016F +ushortcyrillic;045E +usmallhiragana;3045 +usmallkatakana;30A5 +usmallkatakanahalfwidth;FF69 +ustraightcyrillic;04AF +ustraightstrokecyrillic;04B1 +utilde;0169 +utildeacute;1E79 +utildebelow;1E75 +uubengali;098A +uudeva;090A +uugujarati;0A8A +uugurmukhi;0A0A +uumatragurmukhi;0A42 +uuvowelsignbengali;09C2 +uuvowelsigndeva;0942 +uuvowelsigngujarati;0AC2 +uvowelsignbengali;09C1 +uvowelsigndeva;0941 +uvowelsigngujarati;0AC1 +v;0076 +vadeva;0935 +vagujarati;0AB5 +vagurmukhi;0A35 +vakatakana;30F7 +vav;05D5 +vavdagesh;FB35 +vavdagesh65;FB35 +vavdageshhebrew;FB35 +vavhebrew;05D5 +vavholam;FB4B +vavholamhebrew;FB4B +vavvavhebrew;05F0 +vavyodhebrew;05F1 +vcircle;24E5 +vdotbelow;1E7F +vecyrillic;0432 +veharabic;06A4 +vehfinalarabic;FB6B +vehinitialarabic;FB6C +vehmedialarabic;FB6D +vekatakana;30F9 +venus;2640 +verticalbar;007C +verticallineabovecmb;030D +verticallinebelowcmb;0329 +verticallinelowmod;02CC +verticallinemod;02C8 +vewarmenian;057E +vhook;028B +vikatakana;30F8 +viramabengali;09CD +viramadeva;094D +viramagujarati;0ACD +visargabengali;0983 +visargadeva;0903 +visargagujarati;0A83 +vmonospace;FF56 +voarmenian;0578 +voicediterationhiragana;309E +voicediterationkatakana;30FE +voicedmarkkana;309B +voicedmarkkanahalfwidth;FF9E +vokatakana;30FA +vparen;24B1 +vtilde;1E7D +vturned;028C +vuhiragana;3094 +vukatakana;30F4 +w;0077 +wacute;1E83 +waekorean;3159 +wahiragana;308F +wakatakana;30EF +wakatakanahalfwidth;FF9C +wakorean;3158 +wasmallhiragana;308E +wasmallkatakana;30EE +wattosquare;3357 +wavedash;301C +wavyunderscorevertical;FE34 +wawarabic;0648 +wawfinalarabic;FEEE +wawhamzaabovearabic;0624 +wawhamzaabovefinalarabic;FE86 +wbsquare;33DD +wcircle;24E6 +wcircumflex;0175 +wdieresis;1E85 +wdotaccent;1E87 +wdotbelow;1E89 +wehiragana;3091 +weierstrass;2118 +wekatakana;30F1 +wekorean;315E +weokorean;315D +wgrave;1E81 +whitebullet;25E6 +whitecircle;25CB +whitecircleinverse;25D9 +whitecornerbracketleft;300E +whitecornerbracketleftvertical;FE43 +whitecornerbracketright;300F +whitecornerbracketrightvertical;FE44 +whitediamond;25C7 +whitediamondcontainingblacksmalldiamond;25C8 +whitedownpointingsmalltriangle;25BF +whitedownpointingtriangle;25BD +whiteleftpointingsmalltriangle;25C3 +whiteleftpointingtriangle;25C1 +whitelenticularbracketleft;3016 +whitelenticularbracketright;3017 +whiterightpointingsmalltriangle;25B9 +whiterightpointingtriangle;25B7 +whitesmallsquare;25AB +whitesmilingface;263A +whitesquare;25A1 +whitestar;2606 +whitetelephone;260F +whitetortoiseshellbracketleft;3018 +whitetortoiseshellbracketright;3019 +whiteuppointingsmalltriangle;25B5 +whiteuppointingtriangle;25B3 +wihiragana;3090 +wikatakana;30F0 +wikorean;315F +wmonospace;FF57 +wohiragana;3092 +wokatakana;30F2 +wokatakanahalfwidth;FF66 +won;20A9 +wonmonospace;FFE6 +wowaenthai;0E27 +wparen;24B2 +wring;1E98 +wsuperior;02B7 +wturned;028D +wynn;01BF +x;0078 +xabovecmb;033D +xbopomofo;3112 +xcircle;24E7 +xdieresis;1E8D +xdotaccent;1E8B +xeharmenian;056D +xi;03BE +xmonospace;FF58 +xparen;24B3 +xsuperior;02E3 +y;0079 +yaadosquare;334E +yabengali;09AF +yacute;00FD +yadeva;092F +yaekorean;3152 +yagujarati;0AAF +yagurmukhi;0A2F +yahiragana;3084 +yakatakana;30E4 +yakatakanahalfwidth;FF94 +yakorean;3151 +yamakkanthai;0E4E +yasmallhiragana;3083 +yasmallkatakana;30E3 +yasmallkatakanahalfwidth;FF6C +yatcyrillic;0463 +ycircle;24E8 +ycircumflex;0177 +ydieresis;00FF +ydotaccent;1E8F +ydotbelow;1EF5 +yeharabic;064A +yehbarreearabic;06D2 +yehbarreefinalarabic;FBAF +yehfinalarabic;FEF2 +yehhamzaabovearabic;0626 +yehhamzaabovefinalarabic;FE8A +yehhamzaaboveinitialarabic;FE8B +yehhamzaabovemedialarabic;FE8C +yehinitialarabic;FEF3 +yehmedialarabic;FEF4 +yehmeeminitialarabic;FCDD +yehmeemisolatedarabic;FC58 +yehnoonfinalarabic;FC94 +yehthreedotsbelowarabic;06D1 +yekorean;3156 +yen;00A5 +yenmonospace;FFE5 +yeokorean;3155 +yeorinhieuhkorean;3186 +yerahbenyomohebrew;05AA +yerahbenyomolefthebrew;05AA +yericyrillic;044B +yerudieresiscyrillic;04F9 +yesieungkorean;3181 +yesieungpansioskorean;3183 +yesieungsioskorean;3182 +yetivhebrew;059A +ygrave;1EF3 +yhook;01B4 +yhookabove;1EF7 +yiarmenian;0575 +yicyrillic;0457 +yikorean;3162 +yinyang;262F +yiwnarmenian;0582 +ymonospace;FF59 +yod;05D9 +yoddagesh;FB39 +yoddageshhebrew;FB39 +yodhebrew;05D9 +yodyodhebrew;05F2 +yodyodpatahhebrew;FB1F +yohiragana;3088 +yoikorean;3189 +yokatakana;30E8 +yokatakanahalfwidth;FF96 +yokorean;315B +yosmallhiragana;3087 +yosmallkatakana;30E7 +yosmallkatakanahalfwidth;FF6E +yotgreek;03F3 +yoyaekorean;3188 +yoyakorean;3187 +yoyakthai;0E22 +yoyingthai;0E0D +yparen;24B4 +ypogegrammeni;037A +ypogegrammenigreekcmb;0345 +yr;01A6 +yring;1E99 +ysuperior;02B8 +ytilde;1EF9 +yturned;028E +yuhiragana;3086 +yuikorean;318C +yukatakana;30E6 +yukatakanahalfwidth;FF95 +yukorean;3160 +yusbigcyrillic;046B +yusbigiotifiedcyrillic;046D +yuslittlecyrillic;0467 +yuslittleiotifiedcyrillic;0469 +yusmallhiragana;3085 +yusmallkatakana;30E5 +yusmallkatakanahalfwidth;FF6D +yuyekorean;318B +yuyeokorean;318A +yyabengali;09DF +yyadeva;095F +z;007A +zaarmenian;0566 +zacute;017A +zadeva;095B +zagurmukhi;0A5B +zaharabic;0638 +zahfinalarabic;FEC6 +zahinitialarabic;FEC7 +zahiragana;3056 +zahmedialarabic;FEC8 +zainarabic;0632 +zainfinalarabic;FEB0 +zakatakana;30B6 +zaqefgadolhebrew;0595 +zaqefqatanhebrew;0594 +zarqahebrew;0598 +zayin;05D6 +zayindagesh;FB36 +zayindageshhebrew;FB36 +zayinhebrew;05D6 +zbopomofo;3117 +zcaron;017E +zcircle;24E9 +zcircumflex;1E91 +zcurl;0291 +zdot;017C +zdotaccent;017C +zdotbelow;1E93 +zecyrillic;0437 +zedescendercyrillic;0499 +zedieresiscyrillic;04DF +zehiragana;305C +zekatakana;30BC +zero;0030 +zeroarabic;0660 +zerobengali;09E6 +zerodeva;0966 +zerogujarati;0AE6 +zerogurmukhi;0A66 +zerohackarabic;0660 +zeroinferior;2080 +zeromonospace;FF10 +zerooldstyle;F730 +zeropersian;06F0 +zerosuperior;2070 +zerothai;0E50 +zerowidthjoiner;FEFF +zerowidthnonjoiner;200C +zerowidthspace;200B +zeta;03B6 +zhbopomofo;3113 +zhearmenian;056A +zhebrevecyrillic;04C2 +zhecyrillic;0436 +zhedescendercyrillic;0497 +zhedieresiscyrillic;04DD +zihiragana;3058 +zikatakana;30B8 +zinorhebrew;05AE +zlinebelow;1E95 +zmonospace;FF5A +zohiragana;305E +zokatakana;30BE +zparen;24B5 +zretroflexhook;0290 +zstroke;01B6 +zuhiragana;305A +zukatakana;30BA +#--end diff --git a/lib/head.ps b/lib/head.ps @@ -0,0 +1,28 @@ +%%DocumentFonts: (atend) +/PicoEncoding + ISOLatin1Encoding dup length array copy +def +/isoLatin1 { + dup dup findfont dup length dict begin + {1 index /FID ne {def} {pop pop} ifelse} forall + /Encoding PicoEncoding def currentdict + end definefont +} def +/glyphArrayShow { + { + dup type /stringtype eq {show} {glyphshow} ifelse + } forall +} def +/glyphArrayWidth { + 0 exch + { + dup type /stringtype eq { + stringwidth pop + } { + matrix currentmatrix gsave + newpath nulldevice setmatrix 0 0 moveto glyphshow + currentpoint grestore pop + } ifelse + add + } forall +} def diff --git a/lib/heartbeat.l b/lib/heartbeat.l @@ -0,0 +1,19 @@ +# 16feb08abu +# (c) Software Lab. Alexander Burger + +(ifn (info "fifo/beat") + (de heartbeat ()) + + (de heartbeat @ + (out "fifo/beat" + (pr + (cons *Pid + (cons + (+ (* 86400 (date T)) (time T) 300) # Busy period 5 minutes + (rest) ) ) ) ) ) + + (task -54321 0 (heartbeat)) + (push1 '*Bye '(out "fifo/beat" (pr *Pid))) ) + +(de nobeat () + (task -54321) ) diff --git a/lib/http.l b/lib/http.l @@ -0,0 +1,440 @@ +# 21apr10abu +# (c) Software Lab. Alexander Burger + +# *Home *Gate *Host *Port *Port1 *Http1 *Chunked +# *Sock *Agent *ContLen *MPartLim *MPartEnd "*HtSet" +# *Post *Url *Timeout *SesId *ConId +# *Referer *Cookies "*Cookies" + +(default + *HPorts 0 + *Timeout (* 300 1000) ) + +(zero *Http1) + +(de *Mimes + (`(chop "html") "text/html; charset=utf-8") + (`(chop "au") "audio/basic" 3600) + (`(chop "wav") "audio/x-wav" 3600) + (`(chop "mp3") "audio/x-mpeg" 3600) + (`(chop "gif") "image/gif" 3600) + (`(chop "tif") "image/tiff" 3600) + (`(chop "tiff") "image/tiff" 3600) + (`(chop "bmp") "image/bmp" 3600) + (`(chop "png") "image/png" 3600) + (`(chop "jpg") "image/jpeg" 3600) + (`(chop "txt") "text/octet-stream" 1 T) + (`(chop "csv") "text/csv; charset=utf-8" 1 T) + (`(chop "css") "text/css" 3600) + (`(chop "js") "application/x-javascript" 3600) + (`(chop "ps") "application/postscript" 1) + (`(chop "pdf") "application/pdf" 1) + (`(chop "zip") "application/zip" 1) + (`(chop "jar") "application/java-archive" 3600) ) + +(de mime (S . @) + (let L (chop S) + (if (assoc L *Mimes) + (con @ (rest)) + (push '*Mimes (cons L (rest))) ) ) ) + +(de mimetype (File) + (in (list 'file "--brief" "--mime" File) + (line T) ) ) + + +### HTTP-Client ### +(de client (Host Port How . Prg) + (let? Sock (connect Host Port) + (prog1 + (out Sock + (if (atom How) + (prinl "GET /" How " HTTP/1.0^M") + (prinl "POST /" (car How) " HTTP/1.0^M") + (prinl "Content-Length: " (size (cdr How)) "^M") ) + (prinl "User-Agent: PicoLisp^M") + (prinl "Host: " Host "^M") + (prinl "Accept-Charset: utf-8^M") + (prinl "^M") + (and (pair How) (prin (cdr @))) + (flush) + (in Sock (run Prg 1)) ) + (close Sock) ) ) ) + +# Local Password +(de pw (N) + (if N + (out ".pw" (prinl (fmt64 (in "/dev/random" (rd N))))) + (in ".pw" (line T)) ) ) + +# PicoLisp Shell +(de psh (Pw Tty) + (off *Run) + (when (and (= Pw (pw)) (ctty Tty)) + (prinl *Pid) + (load "@dbg.l") + (off *Err) + (quit) ) ) + + +### HTTP-Server ### +(de server (P H) + (setq + *Port P + *Port1 P + *Home (cons H (chop H)) + P (port *Port) ) + (gc) + (loop + (setq *Sock (listen P)) + (NIL (fork) (close P)) + (close *Sock) ) + (task *Sock (http @)) + (http *Sock) + (or *SesId (bye)) + (task *Sock + (when (accept *Sock) + (task @ (http @)) ) ) ) + +(de baseHRef (Port) + (pack + (or *Gate "http") "://" *Host + (if *Gate "/" ":") (or Port *Port) "/" ) ) + +(de https @ + (pass pack "https://" *Host "/" *Port "/" *SesId) ) + +(de ext.html (Sym) + (pack (ht:Fmt Sym) ".html") ) + +(de disallowed () + (and + *Allow + (not (idx *Allow *Url)) + (or + (sub? ".." *Url) + (nor + (and *Tmp (pre? *Tmp *Url)) + (find pre? (cdr *Allow) (circ *Url)) ) ) ) ) + +# Application startup +(de app () + (unless *SesId + (setq + *SesId (pack (in "/dev/urandom" (rd 7)) "~") + *Sock (port *HPorts '*Port) ) + (timeout *Timeout) ) ) + +# Set a cookie +(de cookie @ + (if (assoc (next) "*Cookies") + (con @ (rest)) + (push '"*Cookies" (cons (arg) (rest))) ) ) + +# Handle HTTP-Transaction +(de http (S) + (use (*Post L @U @H @X) + (off *Post *ContLen *Cookies "*Cookies" "*HtSet") + (catch "http" + (in S + (cond + ((not (setq L (line))) + (close S) + (task S) + (off S) + (throw "http") ) + ((match '("G" "E" "T" " " "/" @U " " "H" "T" "T" "P" "/" "1" "." @H) L) + (_htHead) ) + ((match '("P" "O" "S" "T" " " "/" @U " " "H" "T" "T" "P" "/" "1" "." @H) L) + (on *Post) + (off *MPartLim *MPartEnd) + (_htHead) + (cond + (*MPartLim (_htMultipart)) + ((if *ContLen (ht:Read @) (line)) + (for L (split @ '&) + (when (cdr (setq L (split L "="))) + (_htSet (car L) (ht:Pack (cadr L))) ) ) ) + (T (throw "http")) ) ) + (T + (out S + (if + (and + (match '(@U " " @ " " "H" "T" "T" "P" . @) L) + (member @U + (quote + ("O" "P" "T" "I" "O" "N" "S") + ("H" "E" "A" "D") + ("P" "U" "T") + ("D" "E" "L" "E" "T" "E") + ("T" "R" "A" "C" "E") + ("C" "O" "N" "N" "E" "C" "T") ) ) ) + (httpStat 501 "Method Not Implemented" "Allow: GET, POST") + (httpStat 400 "Bad Request") ) ) + (close S) + (task S) + (off S) + (throw "http") ) ) + (if (<> *ConId *SesId) + (if *ConId + (out S (http404)) + (close S) + (task S) + (off S) ) + (setq + L (split @U "?") + @U (car L) + L (extract + '((L) + (cond + ((cdr (setq L (split L "="))) + (_htSet (car L) (htArg (cadr L))) + NIL ) + ((tail '`(chop ".html") (car L)) + (pack (car L)) ) + (T (htArg (car L))) ) ) + (split (cadr L) "&") ) ) + (unless (setq *Url (ht:Pack @U)) + (setq *Url (car *Home) @U (cdr *Home)) ) + (out S + (cond + ((match '("-" @X "." "h" "t" "m" "l") @U) + (and *SesId (timeout *Timeout)) + (try 'html> (extern (ht:Pack @X))) ) + ((= '@ (car @U)) + (if (disallowed) + (prog (msg *Url " not allowed") (http404)) + (and *SesId (timeout *Timeout)) + (apply (val (intern (ht:Pack (cdr @U)))) L) ) ) + ((disallowed) + (msg *Url " not allowed") + (http404) ) + ((tail '("." "l") @U) + (and *SesId (timeout *Timeout)) + (apply script L *Url) ) + ((assoc (stem @U ".") *Mimes) + (apply httpEcho (cdr @) *Url) ) + ((=T (car (info *Url))) + (if (info (setq *Url (pack *Url "default"))) + (apply script L *Url) + (http404) ) ) + (T (httpEcho *Url "application/octet-stream" 1 T)) ) ) ) ) ) + (and S (=0 *Http1) (close S) (task S)) ) ) + +(de _htHead () + (use (L @X @Y) + (setq *Http1 (format (car @H)) *Chunked (gt0 *Http1)) + (if (index "~" @U) + (setq *ConId (pack (head @ @U)) @U (cdr (nth @U @))) + (off *ConId) ) + (while (setq L (line)) + (cond + ((match '(~(chop "Gate: ") @X " " . @Y) L) + (setq *Gate (pack @X) *Adr (pack @Y)) ) + ((match '(~(chop "Host: ") . @X) L) + (setq *Host + (cond + (*Gate @X) + ((index ":" @X) (head (dec @) @X)) + (T @X) ) ) ) + ((match '(~(chop "Referer: ") . @X) L) + (setq *Referer @X) ) + ((match '(~(chop "Cookie: ") . @X) L) + (setq *Cookies + (mapcar + '((L) + (setq L (split L "=")) + (cons (htArg (clip (car L))) (htArg (cadr L))) ) + (split @X ";") ) ) ) + ((match '(~(chop "User-Agent: ") . @X) L) + (setq *Agent @X) ) + ((match '(~(chop "Content-@ength: ") . @X) L) + (setq *ContLen (format (pack @X))) ) + ((match '(~(chop "Content-@ype: multipart/form-data; boundary=") . @X) L) + (setq + *MPartLim (append '(- -) @X) + *MPartEnd (append *MPartLim '(- -)) ) ) ) ) ) ) + +# rfc1867 multipart/form-data +(de _htMultipart () + (use (L @X @N @V) + (setq L (line)) + (while (= *MPartLim L) + (unless (match '(~(chop "Content-Disposition: form-data; name=") . @X) (line)) + (throw "http") ) + (while (line)) + (cond + ((not (member ";" @X)) + (match '("\"" @X "\"") @X) + (_htSet @X + (pack + (make + (until + (or + (= *MPartLim (setq L (line))) + (= *MPartEnd L) ) + (when (eof) + (throw "http") ) + (when (made) + (link "^J") ) + (link (trim L)) ) ) ) ) ) + ((match '(@N ~(chop "; filename=") . @V) @X) + (match '("\"" @N "\"") @N) + (match '("\"" @V "\"") @V) + (if (_htSet @N (pack (stem @V '/ "\\"))) + (let F (tmp @) + (unless (out F (echo (pack "^M^J" *MPartLim))) + (call 'rm "-f" F) ) ) + (out "/dev/null" (echo (pack "^M^J" *MPartLim))) ) + (setq L (if (= "-" (car (line))) *MPartEnd *MPartLim)) ) ) ) ) ) + +(de _htSet ("Var" Val) + (let (@N NIL @Z NIL @V) + (setq "Var" + (intern + (ht:Pack + (ifn (match '(@V ":" @N ":" @Z) "Var") + "Var" + (setq @N (format (pack @N))) + @V ) ) ) ) + (when @Z + (setq Val + (cond + ((= @Z '("." "x")) (cons (format Val))) + ((= @Z '("." "y")) (cons NIL (format Val))) + (T (msg @Z " bad suffix") (throw "http")) ) ) ) + (cond + ((and *Allow (not (idx *Allow "Var"))) + (msg "Var" ': " not allowed") + (throw "http") ) + ((not @N) + (nond + ((= `(char '*) (char "Var")) (put "Var" 'http Val)) + ((and @Z (val "Var")) (set "Var" Val)) + ((car Val) (con (val "Var") (cdr Val))) + (NIL (set (val "Var") (car Val))) ) ) + ((not (memq "Var" "*HtSet")) + (push '"*HtSet" "Var") + (set "Var" (cons (cons @N Val))) + Val ) + ((assoc @N (val "Var")) + (let X @ + (cond + ((nand @Z (cdr X)) (con X Val)) + ((car Val) (set (cdr X) @)) + (T (con (cdr X) (cdr Val))) ) ) ) + (T + (queue "Var" (cons @N Val)) + Val ) ) ) ) + +(de htArg (Lst) + (case (car Lst) + ("$" (intern (ht:Pack (cdr Lst)))) + ("+" (format (pack (cdr Lst)))) + ("-" (extern (ht:Pack (cdr Lst)))) + ("_" (mapcar htArg (split (cdr Lst) "_"))) + (T (ht:Pack Lst)) ) ) + +# Http Transfer Header +(de http1 (Typ Upd File Att) + (prinl "HTTP/1." *Http1 " 200 OK^M") + (prinl "Server: PicoLisp^M") + (prin "Date: ") + (httpDate (date T) (time T)) + (when Upd + (prinl "Cache-Control: max-age=" Upd "^M") + (when (=0 Upd) + (prinl "Cache-Control: private, no-store, no-cache^M") ) ) + (prinl "Content-Type: " (or Typ "text/html; charset=utf-8") "^M") + (when File + (prinl + "Content-Disposition: " + (if Att "attachment" "inline") + "; filename=\"" File "\"^M" ) ) ) + +(de httpCookies () + (mapc + '((L) + (prin "Set-Cookie: " + (ht:Fmt (pop 'L)) "=" (ht:Fmt (pop 'L)) + "; path=" (or (pop 'L) "/") ) + (and (pop 'L) (prin "; expires=" @)) + (and (pop 'L) (prin "; domain=" @)) + (and (pop 'L) (prin "; secure")) + (and (pop 'L) (prin "; HttpOnly")) + (prinl) ) + "*Cookies" ) ) + +(de httpHead (Typ Upd File Att) + (http1 Typ Upd File Att) + (and *Chunked (prinl "Transfer-Encoding: chunked^M")) + (httpCookies) + (prinl "^M") ) + +(de httpDate (Dat Tim) + (let D (date Dat) + (prinl + (day Dat *Day) ", " + (pad 2 (caddr D)) " " + (get *Mon (cadr D)) " " + (car D) " " + (tim$ Tim T) " GMT^M" ) ) ) + +# Http Echo +(de httpEcho (File Typ Upd Att) + (and *Tmp (pre? *Tmp File) (one Upd)) + (ifn (info File) + (http404) + (http1 (or Typ (mimetype File)) Upd (stem (chop File) "/") Att) + (prinl "Content-Length: " (car @) "^M") + (prin "Last-Modified: ") + (httpDate (cadr @) (cddr @)) + (prinl "^M") + (in File (echo)) ) ) + +(de srcUrl (Url) + (if (or (pre? "http:" Url) (pre? "https:" Url)) + Url + (pack (baseHRef *Port1) Url) ) ) + +(de sesId (Url) + (if + (or + (pre? "http:" Url) + (pre? "https:" Url) + (pre? "mailto:" Url) + (pre? "javascript:" Url) ) + Url + (pack *SesId Url) ) ) + +(de httpStat (N Str . @) + (prinl "HTTP/1." *Http1 " " N " " Str "^M") + (prinl "Server: PicoLisp^M") + (while (args) + (prinl (next) "^M") ) + (prinl "Content-Type: text/html^M") + (httpCookies) + (prinl "Content-Length: " (+ 68 (length N) (* 2 (length Str))) "^M") + (prinl "^M") + (prinl "<HTML>") + (prinl "<HEAD><TITLE>" N " " Str "</TITLE></HEAD>") + (prinl "<BODY><H1>" Str "</H1></BODY>") + (prinl "</HTML>") ) + +(de noContent () + (httpStat 204 "No Content") ) + +(de redirect @ + (httpStat 303 "See Other" (pass pack "Location: ")) ) + +(de forbidden () + (httpStat 403 "No Permission") + (throw "http") ) + +(de http404 () + (httpStat 404 "Not Found") ) + +`*Dbg +(noLint 'http '"O") + +# vi:et:ts=3:sw=3 diff --git a/lib/import.l b/lib/import.l @@ -0,0 +1,30 @@ +# 15jul05abu +# (c) Software Lab. Alexander Burger + +### Import Parsing ### +(de getStr (N Lst) + (pack (clip (get Lst N))) ) + +(de getSym (N Lst) + (intern + (pack (replace (clip (get Lst N)) " " '_)) ) ) + +(de getStrLst (N Lst) + (mapcar pack (split (clip (get Lst N)) " ")) ) + +(de getSymLst (N Lst) + (mapcar + '((L) (intern (pack L))) + (split (clip (get Lst N)) " ") ) ) + +(de getNum (N Lst) + (format (getStr N Lst)) ) + +(de getFlt (P N Lst) + (format (getStr N Lst) P *Sep0 *Sep3) ) + +(de getDat (L Lst) + (date + (mapcar + '((N) (getNum N Lst)) + L ) ) ) diff --git a/lib/led.l b/lib/led.l @@ -0,0 +1,431 @@ +# 19apr10abu +# (c) Software Lab. Alexander Burger + +# Line editor +# vi-mode, just a subset: +# - Only single-key commands +# - No repeat count + +(setq + "Line" NIL # Holds current input line + "LPos" 1 # Position in line (1 .. length) + "HPos" 1 # Position in history + "UndoLine" NIL # Undo + "UndoPos" 0 + "Line1" NIL # Initial line + "Insert" T # Insert mode flag + "FKey" NIL # Function key bindings + "Clip" NIL # Cut/Copy/Paste buffer + "Item" NIL # Item to find + "Found" NIL # Find stack + "Complete" NIL # Input completion + + "HistMax" 1000 # History limit + + "History" # History of input lines + (in "+@.picoHistory" + (ctl NIL + (make (until (eof) (link (line T)))) ) ) + "Hist0" "History" ) + + +# Basic editing routine +(de chgLine (L N) + (let (D (length "Line") Tsm) + (for (P (dec "LPos") (>= P 1) (dec P)) # To start of old line + (unless + (and + *Tsm + (= "\"" (get "Line" P)) + ("skipQ" "LPos" P "Line") ) + (prin "^H") ) ) + (for (P . C) (setq "Line" L) # Output new line + (cond + ((> " " C) + (dec 'D) + (prin "_") ) + ((or (not *Tsm) (<> "\"" C) ("escQ" P L)) + (dec 'D) + (prin C) ) + (T + (prin + (and Tsm (cdr *Tsm)) + (unless ("skipQ" N P L) + (dec 'D) + C ) + (and (onOff Tsm) (car *Tsm)) ) ) ) ) + (and Tsm (prin (cdr *Tsm))) + (space D) # Clear rest of old line + (do D (prin "^H")) + (setq "LPos" (inc (length L))) + (until (= N "LPos") # To new position + (unless + (and + *Tsm + (= "\"" (get "Line" "LPos")) + ("skipQ" N "LPos" "Line") ) + (prin "^H") ) + (dec '"LPos") ) ) + (flush) ) + +# Skipped double quote +(de "skipQ" (N P L) + (nor + (>= (inc N) P (dec N)) + (= "\"" (get L (dec P))) + (= "\"" (get L (inc P))) + ("escQ" P L) ) ) + +# Escaped double quote +(de "escQ" () + (let Esc NIL + (for I (dec P) + ((if (= "\\" (get L I)) onOff off) Esc) ) ) ) + +# Check for delimiter +(de delim? (C) + (member C '`(chop '" ^I^J^M\"'()[]`~")) ) + +# Move left +(de lMove () + (chgLine "Line" (max 1 (dec "LPos"))) ) + +# Move to beginning +(de bMove () + (chgLine "Line" 1) ) + +# Move right +(de rMove () + (chgLine "Line" + (if (>= "LPos" (length "Line")) + "LPos" + (inc "LPos") ) ) ) + +# Move to end of line +(de eMove () + (chgLine "Line" (length "Line")) ) + +# Move beyond end of line +(de xMove () + (chgLine "Line" (inc (length "Line"))) ) + +# Move word left +(de lWord () + (use (N L) + (chgLine "Line" + (if (>= 1 (setq N "LPos")) + 1 + (loop + (T (= 1 (dec 'N)) 1) + (setq L (nth "Line" (dec N))) + (T (and (delim? (car L)) (not (delim? (cadr L)))) + N ) ) ) ) ) ) + +# Move word right +(de rWord () + (use (M N L) + (setq M (length "Line")) + (chgLine "Line" + (if (<= M (setq N "LPos")) + M + (loop + (T (= M (inc 'N)) M) + (setq L (nth "Line" (dec N))) + (T (and (delim? (car L)) (not (delim? (cadr L)))) + N ) ) ) ) ) ) + +# Match left parenthesis +(de lPar () + (let (N 1 I (dec "LPos")) + (loop + (T (=0 I)) + (case (get "Line" I) + (")" (inc 'N)) + ("(" (dec 'N)) ) + (T (=0 N) (chgLine "Line" I)) + (dec 'I) ) ) ) + +# Match right parenthesis +(de rPar () + (let (N 1 I (inc "LPos")) + (loop + (T (> I (length "Line"))) + (case (get "Line" I) + ("(" (inc 'N)) + (")" (dec 'N)) ) + (T (=0 N) (chgLine "Line" I)) + (inc 'I) ) ) ) + +# Clear to end of line +(de clrEol () + (let N (dec "LPos") + (if (=0 N) + (chgLine NIL 1) + (chgLine (head N "Line") N) ) ) ) + +# Insert a char +(de insChar (C) + (chgLine (insert "LPos" "Line" C) (inc "LPos")) ) + +(de del1 (L) + (ifn (nth L "LPos") + L + (setq "Clip" (append "Clip" (list (get L "LPos")))) + (remove "LPos" L) ) ) + +# Delete a char +(de delChar () + (use L + (off "Clip") + (chgLine + (setq L (del1 "Line")) + (max 1 (min "LPos" (length L))) ) ) ) + +# Delete a word (F: with trailing blank) +(de delWord (F) + (let L "Line" + (off "Clip") + (ifn (= "(" (get L "LPos")) + (while (and (nth L "LPos") (not (delim? (get L "LPos")))) + (setq L (del1 L)) ) + (for (N 1 (and (setq L (del1 L)) (< 0 N))) + (case (get L "LPos") + ("(" (inc 'N)) + (")" (dec 'N)) ) ) ) + (and + F + (sp? (get L "LPos")) + (setq L (del1 L)) ) + (chgLine L (max 1 (min "LPos" (length L)))) ) ) + +# Replace char +(de rplChar (C) + (chgLine + (insert "LPos" (remove "LPos" "Line") C) + "LPos" ) ) + +# Undo mechanism +(de doUndo () + (setq "UndoLine" "Line" "UndoPos" "LPos") ) + +# Paste clip +(de doPaste () + (if (= 1 "LPos") + (chgLine (append "Clip" "Line") 1) + (chgLine + (append + (head (dec "LPos") "Line") + "Clip" + (nth "Line" "LPos") ) + (+ "LPos" (length "Clip") -1) ) ) ) + +# Set history line +(de setHist (N) + (chgLine + (if (=0 (setq "HPos" N)) + "Line1" + (chop (get "History" "HPos")) ) + 1 ) ) + +# Searching +(de ledSearch (L) + (let (H (nth "History" (inc "HPos")) S (find '((X) (match "Item" (chop X))) H)) + (chgLine + (ifn S + (prog (beep) L) + (push '"Found" "HPos") + (inc '"HPos" (index S H)) + (chop S) ) + 1 ) ) ) + +# TAB expansion +(de expandTab () + (let ("L" (head (dec "LPos") "Line") "S" "L") + (while (find "skipFun" "S") + (pop '"S") ) + (ifn "S" + (prog + (off "Complete") + (do 3 (insChar " ")) ) + (ifn + (default "Complete" + (let "N" (inc (length "S")) + (mapcar + '((X) + (setq X + (nth + (mapcar + '((C) + (if (delim? C) (pack "\\" C) C) ) + (chop X) ) + "N" ) ) + (cons + (+ "LPos" (length X)) + (append "L" X (nth "Line" "LPos")) ) ) + ("tabFun" (pack "S")) ) ) ) + (beep) + (chgLine (cdar "Complete") (caar "Complete")) + (rot "Complete") ) ) ) ) + +# Insert mode +(de insMode ("C") + (if (= "C" "^I") + (expandTab) + (off "Complete") + (case "C" + (("^H" "^?") + (when (> "LPos" 1) + (chgLine (remove (dec "LPos") "Line") (dec "LPos")) ) ) + ("^V" (insChar (key))) + ("^[" + (loop + (NIL + (make + (while (and (setq "C" (key 50)) (<> "C" "^[")) + (link "C") ) ) + (off "Insert") + (lMove) ) + (and + (assoc (pack "^[" @) "FKey") + (let *Dbg "*Dbg" + (run (cdr @)) ) ) + (NIL "C") ) ) + (T + (when (= "C" ")") + (chgLine "Line" (prog1 "LPos" (lPar) (wait 200))) ) + (insChar "C") ) ) ) ) + +# Command mode +(de cmdMode ("C") + (case "C" + ("g" (prinl) (println "Clip")) + ("$" (eMove)) + ("%" + (case (get "Line" "LPos") + (")" (lPar)) + ("(" (rPar)) + (T (beep)) ) ) + ("/" + (let "L" "Line" + (_getLine '("/") '((C) (= C "/"))) + (unless (=T "Line") + (setq "Item" (append '(@) (cdr "Line") '(@))) + (ledSearch "L") + (off "Insert") ) ) ) + ("0" (bMove)) + ("A" (doUndo) (xMove) (on "Insert")) + ("a" (doUndo) ((if (= "LPos" (length "Line")) xMove rMove)) (on "Insert")) + ("b" (lWord)) + ("c" (doUndo) (delWord NIL) (on "Insert")) + ("C" (doUndo) (clrEol) (xMove) (on "Insert")) + ("d" (doUndo) (delWord T)) + ("D" (doUndo) (clrEol)) + ("f" + (ifn (setq "C" (index (key) (nth "Line" (inc "LPos")))) + (beep) + (chgLine "Line" (+ "C" "LPos")) ) ) + ("h" (lMove)) + ("i" (doUndo) (on "Insert")) + ("I" (doUndo) (bMove) (on "Insert")) + ("j" (unless (=0 "HPos") (setHist (dec "HPos")))) + ("k" (when (< "HPos" (length "History")) (setHist (inc "HPos")))) + ("l" (rMove)) + ("n" (ledSearch "Line")) + ("N" (if "Found" (setHist (pop '"Found")) (beep))) + ("p" (doUndo) ((if (= "LPos" (length "Line")) xMove rMove)) (doPaste)) + ("P" (doUndo) (doPaste)) + ("r" (ifn "Line" (beep) (doUndo) (rplChar (key)))) + ("s" (doUndo) (delChar) (on "Insert")) + ("S" (doUndo) (chgLine NIL 1) (on "Insert")) + ("U" (setHist "HPos")) + ("u" + (let ("L" "Line" "P" "LPos") + (chgLine "UndoLine" "UndoPos") + (setq "UndoLine" "L" "UndoPos" "P") ) ) + ("w" (rWord)) + ("x" (doUndo) (delChar)) + ("X" (lMove) (doUndo) (delChar)) + ("~" + (doUndo) + (rplChar + ((if (low? (setq "C" (get "Line" "LPos"))) uppc lowc) "C") ) + (rMove) ) + (T (beep)) ) ) + +# Get a line from console +(de _getLine ("L" "skipFun") + (use "C" + (chgLine "L" (inc (length "L"))) + (on "Insert") + (until + (member + (setq "C" (let *Dbg "*Dbg" (key))) + '("^J" "^M") ) + (case "C" + (NIL (bye)) + ("^D" (prinl) (tell 'bye) (bye)) + ("^X" (prin (cdr *Tsm)) (prinl) (quit)) ) + ((if "Insert" insMode cmdMode) "C") ) ) ) + +# Function keys +(de fkey (Key . Prg) + (setq "FKey" + (cond + ((not Key) "FKey") + ((not Prg) (delete (assoc Key "FKey") "FKey")) + ((assoc Key "FKey") + (cons (cons Key Prg) (delete @ "FKey")) ) + (T (cons (cons Key Prg) "FKey")) ) ) ) + +# Main editing functions +(de _led ("Line1" "tabFun" "skipFun") + (default "tabFun" + '((S) + (conc + (filter '((X) (pre? S X)) (all)) + (let P (rot (split (chop S) "/")) + (setq + S (pack (car P)) + P (and (cdr P) (pack (glue "/" @) "/")) ) + (extract + '((X) + (and (pre? S X) (pack P X)) ) + (dir P) ) ) ) ) ) + (setq "LPos" 1 "HPos" 0) + (_getLine "Line1" (or "skipFun" delim?)) + (prinl (cdr *Tsm)) ) + +(de revise ("X" "tabFun" "skipFun") + (let ("*Dbg" *Dbg *Dbg NIL) + (_led (chop "X") "tabFun" "skipFun") + (pack "Line") ) ) + +(de saveHistory () + (in "+@.picoHistory" + (ctl T + (let (Old (make (until (eof) (link (line T)))) New "History" N "HistMax") + (out "@.picoHistory" + (while (and New (n== New "Hist0")) + (prinl (pop 'New)) + (dec 'N) ) + (setq "Hist0" "History") + (do N + (NIL Old) + (prinl (pop 'Old)) ) ) ) ) ) ) + +# Enable line editing +(de *Led + (let ("*Dbg" *Dbg *Dbg NIL) + (push1 '*Bye '(saveHistory)) + (push1 '*Fork '(del '(saveHistory) '*Bye)) + (_led) + (let L (pack "Line") + (or + (>= 3 (length "Line")) + (sp? (car "Line")) + (= L (car "History")) + (push '"History" L) ) + (and (nth "History" "HistMax") (con @)) + L ) ) ) + +# vi:et:ts=3:sw=3 diff --git a/lib/led.min.l b/lib/led.min.l @@ -0,0 +1,23 @@ +# 05feb05abu +# (c) Software Lab. Alexander Burger + +# *Line + +# Line input editing +(de mkChar (C) + (prin C) + (queue '*Line C) ) + +# Enable line editing +(de *Led + (use C + (until (member (setq C (key)) '("^J" "^M")) + (case C + (("^H" "^?") + (when *Line + (prin "^H ^H") + (setq *Line (cdr (rot *Line))) ) ) + ("^I" (do 3 (mkChar " "))) + (T (mkChar C)) ) ) ) + (prinl) + (prog1 (pack *Line) (off *Line)) ) diff --git a/lib/lint.l b/lib/lint.l @@ -0,0 +1,257 @@ +# 31mar10abu +# (c) Software Lab. Alexander Burger + +# *NoLint + +(de noLint (X V) + (if V + (push1 '*NoLint (cons X V)) + (or (memq X *NoLint) (push '*NoLint X)) ) ) + +(de global? (S) + (or + (memq S '(NIL ^ @ @@ @@@ This T)) + (member (char S) '(`(char '*) `(char '+))) ) ) + +(de local? (S) + (or + (str? S) + (member (char S) '(`(char '*) `(char '_))) ) ) + +(de dlsym? (S) + (and + (car (setq S (split (chop S) ':))) + (cadr S) + (low? (caar S)) ) ) + +(de lint1 ("X") + (cond + ((atom "X") + (when (sym? "X") + (cond + ((memq "X" "*L") (setq "*Use" (delq "X" "*Use"))) + ((local? "X") (lint2 (val "X"))) + (T + (or + (getd "X") + (global? "X") + (member (cons "*X" "X") *NoLint) + (memq "X" "*Bnd") + (push '"*Bnd" "X") ) ) ) ) ) + ((num? (car "X"))) + (T + (case (car "X") + ((: ::)) + (; (lint1 (cadr "X"))) + (quote + (if (and (pair (fun? (cdr "X"))) (not (cdr (tail 1 @)))) + (use "*L" (lintFun (cdr "X"))) + (lint2 (cdr "X")) ) ) + ((de dm) + (let "*X" (cadr "X") + (lintFun (cddr "X")) ) ) + (recur + (let recurse (cdr "X") + (lintFun recurse) ) ) + (task + (lint1 (cadr "X")) + (let "Y" (cddr "X") + (use "*L" + (while (num? (car "Y")) + (pop '"Y") ) + (while (and (car "Y") (sym? @)) + (lintVar (pop '"Y")) + (pop '"Y") ) + (mapc lint1 "Y") ) ) ) + (let? + (use "*L" + (lintVar (cadr "X")) + (mapc lint1 (cddr "X")) ) ) + (let + (use "*L" + (if (atom (cadr "X")) + (lintVar (cadr "X")) + (for (L (cadr "X") L (cddr L)) + (lintDup (car L) + (extract '((X F) (and F X)) + (cddr L) + '(T NIL .) ) ) + (lintVar (car L)) + (lint1 (cadr L)) ) ) + (mapc lint1 (cddr "X")) ) ) + (use + (use "*L" + (if (atom (cadr "X")) + (lintVar (cadr "X")) + (mapc lintVar (cadr "X")) ) + (mapc lint1 (cddr "X")) ) ) + (for + (use "*L" + (let "Y" (cadr "X") + (cond + ((atom "Y") # (for X (1 2 ..) ..) + (lint1 (caddr "X")) + (lintVar "Y") + (lintLoop (cdddr "X")) ) + ((atom (cdr "Y")) # (for (I . X) (1 2 ..) ..) + (lintVar (car "Y")) + (lint1 (caddr "X")) + (lintVar (cdr "Y")) + (lintLoop (cdddr "X")) ) + ((atom (car "Y")) # (for (X (1 2 ..) ..) ..) + (lint1 (cadr "Y")) + (lintVar (car "Y")) + (mapc lint1 (cddr "Y")) + (lintLoop (cddr "X")) ) + (T # (for ((I . L) (1 2 ..) ..) ..) + (lintVar (caar "Y")) + (lint1 (cadr "Y")) + (lintVar (cdar "Y")) + (mapc lint1 (cddr "Y")) + (lintLoop (cddr "X")) ) ) ) ) ) + ((case state) + (lint1 (cadr "X")) + (for "X" (cddr "X") + (mapc lint1 (cdr "X")) ) ) + ((cond nond) + (for "X" (cdr "X") + (mapc lint1 "X") ) ) + (loop + (lintLoop (cdr "X")) ) + (do + (lint1 (cadr "X")) + (lintLoop (cddr "X")) ) + (=: + (lint1 (last (cddr "X"))) ) + ((dec inc pop push push1 queue fifo val idx accu) + (_lintq '(T)) ) + ((cut port) + (_lintq '(NIL T)) ) + (set + (_lintq '(T NIL .)) ) + (xchg + (_lintq '(T T .)) ) + (T + (cond + ((pair (car "X")) + (lint1 @) + (mapc lint2 (cdr "X")) ) + ((memq (car "X") "*L") + (setq "*Use" (delq (car "X") "*Use")) + (mapc lint2 (cdr "X")) ) + ((fun? (val (car "X"))) + (if (num? @) + (mapc lint1 (cdr "X")) + (when (local? (car "X")) + (lint2 (val (car "X"))) ) + (let "Y" (car (getd (pop '"X"))) + (while (and (pair "X") (pair "Y")) + (lint1 (pop '"X")) + (pop '"Y") ) + (if (or (== '@ "Y") (= "Prg" "Y") (= "*Prg" "Y")) + (mapc lint1 "X") + (lint2 "X") ) ) ) ) + (T + (or + (str? (car "X")) + (dlsym? (car "X")) + (== '@ (car "X")) + (memq (car "X") *NoLint) + (memq (car "X") "*Def") + (push '"*Def" (car "X")) ) + (mapc lint1 (cdr "X")) ) ) ) ) ) ) ) + +(de lint2 (X Mark) + (cond + ((memq X Mark)) + ((atom X) + (and (memq X "*L") (setq "*Use" (delq X "*Use"))) ) + (T (lint2 (car X)) + (lint2 (cdr X) (cons X Mark)) ) ) ) + +(de lintVar (X Flg) + (cond + ((or (not (sym? X)) (memq X '(NIL *DB *Solo ^ meth quote T))) + (push '"*Var" X) ) + ((not (global? X)) + (or + Flg + (member (cons "*X" X) *NoLint) + (memq X "*Use") + (push '"*Use" X) ) + (push '"*L" X) ) ) ) + +(de lintDup (X Lst) + (and + (memq X Lst) + (not (member (cons "*X" X) *NoLint)) + (push '"*Dup" X) ) ) + +(de lintLoop ("Lst") + (for "Y" "Lst" + (if (and (pair "Y") (or (=T (car "Y")) (not (car "Y")))) + (mapc lint1 (cdr "Y")) + (lint1 "Y") ) ) ) + +(de _lintq (Lst) + (mapc + '((X Flg) + (lint1 (if Flg (strip X) X)) ) + (cdr "X") + Lst ) ) + +(de lintFun ("Lst") + (let "A" (and (pair "Lst") (car "Lst")) + (while (pair "A") + (lintDup (car "A") (cdr "A")) + (lintVar (pop '"A") T) ) + (when "A" + (lintVar "A") ) + (mapc lint1 (cdr "Lst")) ) ) + +(de lint ("X" "C") + (let ("*L" NIL "*Var" NIL "*Dup" NIL "*Def" NIL "*Bnd" NIL "*Use" NIL) + (when (pair "X") + (setq "C" (cdr "X") "X" (car "X")) ) + (cond + ("C" # Method + (let "*X" (cons "X" "C") + (lintFun (method "X" "C")) ) ) + ((pair (val "X")) # Function + (let "*X" "X" + (lintFun (val "X")) ) ) + ((info "X") # File name + (let "*X" "X" + (in "X" (while (read) (lint1 @))) ) ) + (T (quit "Can't lint" "X")) ) + (when (or "*Var" "*Dup" "*Def" "*Bnd" "*Use") + (make + # Bad variables + (and "*Var" (link (cons 'var "*Var"))) + # Duplicate parameters + (and "*Dup" (link (cons 'dup "*Dup"))) + # Undefined functions + (and "*Def" (link (cons 'def "*Def"))) + # Unbound variables + (and "*Bnd" (<> `(char '_) (char "X")) (link (cons 'bnd "*Bnd"))) + # Unused variables + (and "*Use" (link (cons 'use "*Use"))) ) ) ) ) + +(de lintAll @ + (let *Dbg NIL + (make + (for "X" (all) + (cond + ((= `(char "+") (char "X")) + (for "Y" (val "X") + (and + (pair "Y") + (fun? (cdr "Y")) + (lint (car "Y") "X") + (link (cons (cons (car "Y") "X") @)) ) ) ) + ((and (not (global? "X")) (pair (getd "X")) (lint "X")) + (link (cons "X" @)) ) ) ) + (while (args) + (and (lint (next)) (link (cons (arg) @))) ) ) ) ) + +# vi:et:ts=3:sw=3 diff --git a/lib/math.l b/lib/math.l @@ -0,0 +1,11 @@ +# 18mar10abu +# (c) Software Lab. Alexander Burger + +(and (=0 *Scl) (scl 6)) # Default scale 6 +(setq # Global constants + pi 3.1415926535897931 + pi/2 1.5707963267948966 ) + +(load (if (== 64 64) "@lib/math64.l" "@lib/math32.l")) + +# vi:et:ts=3:sw=3 diff --git a/lib/math32.l b/lib/math32.l @@ -0,0 +1,22 @@ +# 21feb10abu +# (c) Software Lab. Alexander Burger + +(de exp (X) + (ext:Exp X 1.0) ) + +(de log (X) + (and (gt0 X) (ext:Log X 1.0)) ) + +(de sin (A) + (ext:Sin A 1.0) ) + +(de cos (A) + (ext:Cos A 1.0) ) + +(de tan (A) + (ext:Tan A 1.0) ) + +(de atan (X Y) + (ext:Atan X Y 1.0) ) + +# vi:et:ts=3:sw=3 diff --git a/lib/math64.l b/lib/math64.l @@ -0,0 +1,44 @@ +# 22feb10abu +# (c) Software Lab. Alexander Burger + +(load "lib/native.l") + +(de log (X) + (and (gt0 X) ("log" X 1.0)) ) + +(gcc "math" NIL + (exp (X) "Exp" 'N X 1.0) + ("log" (X) "Log" 'N X 1.0) + (sin (A) "Sin" 'N A 1.0) + (cos (A) "Cos" 'N A 1.0) + (tan (A) "Tan" 'N A 1.0) + (atan (X Y) "Atan" 'N X Y 1.0) ) + +#include <math.h> + +long Exp(long x, int scl) { + return round((double)scl * exp((double)x / (double)scl)); +} + +long Log(long x, int scl) { + return round((double)scl * log((double)x / (double)scl)); +} + +long Sin(long a, int scl) { + return round((double)scl * sin((double)a / (double)scl)); +} + +long Cos(long a, int scl) { + return round((double)scl * cos((double)a / (double)scl)); +} + +long Tan(long a, int scl) { + return round((double)scl * tan((double)a / (double)scl)); +} + +long Atan(long x, long y, int scl) { + return round((double)scl * atan2((double)x / (double)scl, (double)y / (double)scl)); +} +/**/ + +# vi:et:ts=3:sw=3 diff --git a/lib/misc.l b/lib/misc.l @@ -0,0 +1,480 @@ +# 27feb10abu +# (c) Software Lab. Alexander Burger + +# *Allow *Tmp + +(de *Day . (Mon Tue Wed Thu Fri Sat Sun .)) +(de *Mon . (Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec .)) +(de *mon . (jan feb mar apr may jun jul aug sep oct nov dec .)) + +### Locale ### +(de *Ctry) +(de *Lang) +(de *Sep0 . ".") +(de *Sep3 . ",") +(de *CtryCode) +(de *DateFmt @Y "-" @M "-" @D) +(de *DayFmt "Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday" "Sunday") +(de *MonFmt "January" "February" "March" "April" "May" "June" "July" "August" "September" "October" "November" "December") + +(de locale (Ctry Lang App) # "DE" "de" ["app/loc/"] + (load (if (setq *Ctry Ctry) (pack "@loc/" @ ".l") "@loc/NIL.l")) + (ifn (setq *Lang Lang) + (for S (idx '*Uni) + (set S S) ) + (let L + (sort + (make + ("loc" (pack "@loc/" Lang)) + (and App ("loc" (pack App Lang))) ) ) + (balance '*Uni L T) + (for S L + (set (car (idx '*Uni S)) (val S)) ) ) ) ) + +(de "loc" (F) + (in F + (use X + (while (setq X (read)) + (if (=T X) + ("loc" (read)) + (set (link @) (name (read))) ) ) ) ) ) + +### Math ### +(de sqrt (N) + (cond + ((lt0 N) (quit "Bad argument" N)) + (N + (let (A 1 B 0) + (while (>= N A) + (setq A (>> -2 A)) ) + (loop + (if (> (inc 'B A) N) + (dec 'B A) + (dec 'N B) + (inc 'B A) ) + (setq B (>> 1 B) A (>> 2 A)) + (T (=0 A)) ) + B ) ) ) ) + +# (Knuth Vol.2, p.442) +(de ** (X N) # N th power of X + (let Y 1 + (loop + (when (bit? 1 N) + (setq Y (* Y X)) ) + (T (=0 (setq N (>> 1 N))) + Y ) + (setq X (* X X)) ) ) ) + +(de accu (Var Key Val) + (when Val + (if (assoc Key (val Var)) + (con @ (+ Val (cdr @))) + (push Var (cons Key Val)) ) ) ) + +### String ### +(de align (X . @) + (pack + (if (pair X) + (mapcar + '((X) (need X (chop (next)) " ")) + X ) + (need X (chop (next)) " ") ) ) ) + +(de center (X . @) + (pack + (if (pair X) + (let R 0 + (mapcar + '((X) + (let (S (chop (next)) N (>> 1 (+ X (length S)))) + (prog1 + (need (+ N R) S " ") + (setq R (- X N)) ) ) ) + X ) ) + (let S (chop (next)) + (need (>> 1 (+ X (length S))) S " ") ) ) ) ) + +(de wrap (Max Lst) + (setq Lst (split Lst " " "^J")) + (pack + (make + (while Lst + (if (>= (length (car Lst)) Max) + (link (pop 'Lst) "^J") + (chain + (make + (link (pop 'Lst)) + (loop + (NIL Lst) + (T (>= (+ (length (car Lst)) (sum length (made))) Max) + (link "^J") ) + (link " " (pop 'Lst)) ) ) ) ) ) ) ) ) + +### Number ### +(de pad (N Val) + (pack (need N (chop Val) "0")) ) + +(de money (N Cur) + (if Cur + (pack (format N 2 *Sep0 *Sep3) " " Cur) + (format N 2 *Sep0 *Sep3) ) ) + +# Octal notation +(de oct (X) + (cond + ((num? X) + (let (S (and (lt0 X) '-) L (oct1 X)) + (until (=0 (setq X (>> 3 X))) + (push 'L (oct1 X)) ) + (pack S L) ) ) + ((setq X (chop X)) + (let (S (and (= '- (car X)) (pop 'X)) N 0) + (for C X + (setq N (+ (format C) (>> -3 N))) ) + (if S (- N) N) ) ) ) ) + +(de oct1 (N) + (char (+ (& N 7) `(char "0"))) ) + +# Hexadecimal notation +(de hex (X) + (cond + ((num? X) + (let (S (and (lt0 X) '-) L (hex1 X)) + (until (=0 (setq X (>> 4 X))) + (push 'L (hex1 X)) ) + (pack S L) ) ) + ((setq X (chop X)) + (let (S (and (= '- (car X)) (pop 'X)) N 0) + (for C X + (setq C (- (char C) `(char "0"))) + (and (> C 9) (dec 'C 7)) + (and (> C 22) (dec 'C 32)) + (setq N (+ C (>> -4 N))) ) + (if S (- N) N) ) ) ) ) + +(de hex1 (N) + (let C (& 15 N) + (and (> C 9) (inc 'C 7)) + (char (+ C `(char "0"))) ) ) + +# Hexadecimal/Alpha notation +(de hax (X) + (if (num? X) + (pack + (mapcar + '((C) + (when (> (setq C (- (char C) `(char "0"))) 9) + (dec 'C 7) ) + (char (+ `(char "@") C)) ) + (chop (hex X)) ) ) + (hex + (mapcar + '((C) + (when (> (setq C (- (char C) `(char "@"))) 9) + (inc 'C 7) ) + (char (+ `(char "0") C)) ) + (chop X) ) ) ) ) + +# Base 64 notation +(de fmt64 (X) + (if (num? X) + (let L (_fmt64 X) + (until (=0 (setq X (>> 6 X))) + (push 'L (_fmt64 X)) ) + (pack L) ) + (let N 0 + (for C (chop X) + (setq C (- (char C) `(char "0"))) + (and (> C 42) (dec 'C 6)) + (and (> C 11) (dec 'C 5)) + (setq N (+ C (>> -6 N))) ) + N ) ) ) + +(de _fmt64 (N) + (let C (& 63 N) + (and (> C 11) (inc 'C 5)) + (and (> C 42) (inc 'C 6)) + (char (+ C `(char "0"))) ) ) + +### Tree ### +(de balance ("Var" "Lst" "Flg") + (unless "Flg" (set "Var")) + (let "Len" (length "Lst") + (recur ("Lst" "Len") + (unless (=0 "Len") + (let ("N" (>> 1 (inc "Len")) "L" (nth "Lst" "N")) + (idx "Var" (car "L") T) + (recurse "Lst" (dec "N")) + (recurse (cdr "L") (- "Len" "N")) ) ) ) ) ) + +### Allow ### +(de allowed Lst + (setq *Allow (cons NIL (car Lst))) + (balance *Allow (sort (cdr Lst))) ) + +(de allow (X Flg) + (nond + (*Allow) + (Flg (idx *Allow X T)) + ((member X (cdr *Allow)) + (conc *Allow (cons X)) ) ) + X ) + +### Telephone ### +(de telStr (S) + (cond + ((not S)) + ((and *CtryCode (pre? (pack *CtryCode " ") S)) + (pack 0 (cdddr (chop S))) ) + (T (pack "+" S)) ) ) + +(de expTel (S) + (setq S + (make + (for (L (chop S) L) + (ifn (sub? (car L) " -") + (link (pop 'L)) + (let F NIL + (loop + (and (= '- (pop 'L)) (on F)) + (NIL L) + (NIL (sub? (car L) " -") + (link (if F '- " ")) ) ) ) ) ) ) ) + (cond + ((= "+" (car S)) (pack (cdr S))) + ((head '("0" "0") S) + (pack (cddr S)) ) + ((and *CtryCode (= "0" (car S))) + (pack *CtryCode " " (cdr S)) ) ) ) + +### Date ### +# ISO date +(de dat$ (Dat C) + (when (date Dat) + (pack (car @) C (pad 2 (cadr @)) C (pad 2 (caddr @))) ) ) + +(de $dat (S C) + (if C + (and + (= 3 + (length (setq S (split (chop S) C))) ) + (date + (format (pack (car S))) # Year + (or (format (pack (cadr S))) 0) # Month + (or (format (pack (caddr S))) 0) ) ) # Day + (and + (format S) + (date + (/ @ 10000) # Year + (% (/ @ 100) 100) # Month + (% @ 100) ) ) ) ) + +(de datSym (Dat) + (when (date Dat) + (pack + (pad 2 (caddr @)) + (get *mon (cadr @)) + (pad 2 (% (car @) 100)) ) ) ) + +# Localized +(de datStr (D F) + (when (setq D (date D)) + (let + (@Y (if F (pad 2 (% (car D) 100)) (pad 4 (car D))) + @M (pad 2 (cadr D)) + @D (pad 2 (caddr D)) ) + (pack (fill *DateFmt)) ) ) ) + +(de strDat (S) + (use (@Y @M @D) + (and + (match *DateFmt (chop S)) + (date + (format (pack @Y)) + (or (format (pack @M)) 0) + (or (format (pack @D)) 0) ) ) ) ) + +(de expDat (S) + (use (@Y @M @D X) + (unless (match *DateFmt (setq S (chop S))) + (if + (or + (cdr (setq S (split S "."))) + (>= 2 (length (car S))) ) + (setq + @D (car S) + @M (cadr S) + @Y (caddr S) ) + (setq + @D (head 2 (car S)) + @M (head 2 (nth (car S) 3)) + @Y (nth (car S) 5) ) ) ) + (and + (setq @D (format (pack @D))) + (date + (nond + (@Y (car (date (date)))) + ((setq X (format (pack @Y)))) + ((>= X 100) + (+ X + (* 100 (/ (car (date (date))) 100)) ) ) + (NIL X) ) + (nond + (@M (cadr (date (date)))) + ((setq X (format (pack @M))) 0) + ((n0 X) (cadr (date (date)))) + (NIL X) ) + @D ) ) ) ) + +# Day of the week +(de day (Dat Lst) + (get + (or Lst *DayFmt) + (inc (% (inc Dat) 7)) ) ) + +# Week of the year +(de week (Dat) + (let W + (- + (_week Dat) + (_week (date (car (date Dat)) 1 4)) + -1 ) + (if (=0 W) 53 W) ) ) + +(de _week (Dat) + (/ (- Dat (% (inc Dat) 7)) 7) ) + +# Last day of month +(de ultimo (Y M) + (dec + (if (= 12 M) + (date (inc Y) 1 1) + (date Y (inc M) 1) ) ) ) + +### Time ### +(de tim$ (Tim F) + (when Tim + (setq Tim (time Tim)) + (pack (pad 2 (car Tim)) ":" (pad 2 (cadr Tim)) + (and F ":") + (and F (pad 2 (caddr Tim))) ) ) ) + +(de $tim (S) + (setq S (split (chop S) ":")) + (unless (or (cdr S) (>= 2 (length (car S)))) + (setq S + (list + (head 2 (car S)) + (head 2 (nth (car S) 3)) + (nth (car S) 5) ) ) ) + (when (format (pack (car S))) + (time @ + (or (format (pack (cadr S))) 0) + (or (format (pack (caddr S))) 0) ) ) ) + +(de stamp (Dat Tim) + (default Dat (date) Tim (time T)) + (pack (dat$ Dat "-") " " (tim$ Tim T)) ) + +### I/O ### +(de chdir ("Dir" . "Prg") + (let? "Old" (cd "Dir") + (finally (cd "Old") + (run "Prg") ) ) ) + +(de dirname (F) + (pack (flip (member '/ (flip (chop F))))) ) + +# Temporary Files +(de tmp @ + (unless *Tmp + (push '*Bye '(call 'rm "-r" *Tmp)) + (push '*Fork '(off *Tmp) '(del '(call 'rm "-r" *Tmp) '*Bye)) + (call 'mkdir "-p" (setq *Tmp (pack "tmp/" *Pid "/"))) ) + (pass pack *Tmp) ) + + +# Print or eval +(de prEval (Prg Ofs) + (default Ofs 1) + (for X Prg + (if (atom X) + (prinl (eval X Ofs)) + (eval X Ofs) ) ) ) + +# Echo here-documents +(de here (S) + (line) + (echo S) ) + +# Send mail +(de mail (Host Port From To Sub Att . Prg) + (let? S (connect Host Port) + (let B (pack "==" (date) "-" (time T) "==") + (prog1 + (and + (pre? "220 " (in S (line T))) + (out S (prinl "HELO " (cdr (member "@" (chop From))) "^M")) + (pre? "250 " (in S (line T))) + (out S (prinl "MAIL FROM:" From "^M")) + (pre? "250 " (in S (line T))) + (if (atom To) + (_rcpt To) + (find bool (mapcar _rcpt To)) ) + (out S (prinl "DATA^M")) + (pre? "354 " (in S (line T))) + (out S + (prinl "From: " From "^M") + (prinl "To: " (or (fin To) (glue "," To)) "^M") + (prinl "Subject: " Sub "^M") + (prinl "User-Agent: PicoLisp^M") + (prinl "MIME-Version: 1.0^M") + (when Att + (prinl "Content-Type: multipart/mixed; boundary=\"" B "\"^M") + (prinl "^M") + (prinl "--" B "^M") ) + (prinl "Content-Type: text/plain; charset=utf-8^M") + (prinl "Content-Transfer-Encoding: 8bit^M") + (prinl "^M") + (prEval Prg 2) + (prinl "^M") + (when Att + (loop + (prinl "--" B "^M") + (prinl + "Content-Type: " + (or (caddr Att) "application/octet-stream") + "; name=\"" + (cadr Att) + "\"^M" ) + (prinl "Content-Transfer-Encoding: base64^M") + (prinl "^M") + (in (car Att) + (while + (do 15 + (NIL (ext:Base64 (rd 1) (rd 1) (rd 1))) + T ) + (prinl) ) ) + (prinl) + (prinl "^M") + (NIL (setq Att (cdddr Att))) ) + (prinl "--" B "--^M") ) + (prinl ".^M") + (prinl "QUIT^M") ) + T ) + (close S) ) ) ) ) + +(de _rcpt (To) + (out S (prinl "RCPT TO:" To "^M")) + (pre? "250 " (in S (line T))) ) + +### Testing ### +(de test (Pat . Prg) + (bind (fish pat? Pat) + (unless (match Pat (run Prg 1)) + (msg Prg) + (quit 'fail Pat) ) ) ) + +# vi:et:ts=3:sw=3 diff --git a/lib/native.l b/lib/native.l @@ -0,0 +1,23 @@ +# 19feb10abu +# (c) Software Lab. Alexander Burger + +(de gcc (Nm L . Lst) + (out (tmp Nm ".c") (here "/**/")) + ~(case *OS + (("Linux" "FreeBSD") + (quote + (apply call L 'gcc "-o" (tmp Nm) + "-fPIC" "-shared" "-export-dynamic" + "-O" "-falign-functions" "-fomit-frame-pointer" + "-W" "-Wimplicit" "-Wreturn-type" "-Wunused" "-Wformat" + "-Wuninitialized" "-Wstrict-prototypes" + "-pipe" "-D_GNU_SOURCE" (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) ) ) ) + +# vi:et:ts=3:sw=3 diff --git a/lib/pilog.l b/lib/pilog.l @@ -0,0 +1,550 @@ +# 28jan10abu +# (c) Software Lab. Alexander Burger + +# *Rule + +(de be CL + (with (car CL) + (if (== *Rule This) + (=: T (conc (: T) (cons (cdr CL)))) + (=: T (cons (cdr CL))) + (setq *Rule This) ) + This ) ) + +(de repeat () + (conc (get *Rule T) (get *Rule T)) ) + +(de asserta (CL) + (with (car CL) + (=: T (cons (cdr CL) (: T))) ) ) + +(de assertz (CL) + (with (car CL) + (=: T (conc (: T) (cons (cdr CL)))) ) ) + +(de retract (X) + (if (sym? X) + (put X T) + (put (car X) T + (delete (cdr X) (get (car X) T)) ) ) ) + +(de rules @ + (while (args) + (let S (next) + (for ((N . L) (get S T) L) + (prin N " (be ") + (print S) + (for X (pop 'L) + (space) + (print X) ) + (prinl ")") + (T (== L (get S T)) + (println '(repeat)) ) ) + S ) ) ) + +### Pilog Interpreter ### +(de goal ("CL" . @) + (let "Env" '(T) + (while (args) + (push '"Env" + (cons (cons 0 (next)) 1 (next)) ) ) + (while (and "CL" (pat? (car "CL"))) + (push '"Env" + (cons + (cons 0 (pop '"CL")) + (cons 1 (eval (pop '"CL"))) ) ) ) + (cons + (cons + (conc (list 1 (0) NIL "CL" NIL) "Env") ) ) ) ) + +(de fail () + (goal '((NIL))) ) + +(de pilog ("CL" . "Prg") + (for ("Q" (goal "CL") (prove "Q")) + (bind @ (run "Prg")) ) ) + +(de solve ("CL" . "Prg") + (make + (if "Prg" + (for ("Q" (goal "CL") (prove "Q")) + (link (bind @ (run "Prg"))) ) + (for ("Q" (goal "CL") (prove "Q")) + (link @) ) ) ) ) + +(de query ("Q" "Dbg") + (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 ? "CL" + (let "L" + (make + (while (nor (pat? (car "CL")) (lst? (car "CL"))) + (link (pop '"CL")) ) ) + (query (goal "CL") "L") ) ) + +### Basic Rules ### +(be repeat) +(repeat) + +(be true) + +(be not @P (1 -> @P) T (fail)) +(be not @P) + +(be call @P + (2 cons (-> @P)) ) + +(be or @L (@C box (-> @L)) (_or @C)) + +(be _or (@C) (3 pop (-> @C))) +(be _or (@C) (@ not (val (-> @C))) T (fail)) +(repeat) + +(be nil (@X) (@ not (-> @X))) + +(be equal (@X @X)) + +(be different (@X @X) T (fail)) +(be different (@ @)) + +(be append (NIL @X @X)) +(be append ((@A . @X) @Y (@A . @Z)) (append @X @Y @Z)) + +(be member (@X (@X . @))) +(be member (@X (@ . @Y)) (member @X @Y)) + +(be delete (@A (@A . @Z) @Z)) +(be delete (@A (@X . @Y) (@X . @Z)) + (delete @A @Y @Z) ) + +(be permute ((@X) (@X))) +(be permute (@L (@X . @Y)) + (delete @X @L @D) + (permute @D @Y) ) + +(be uniq (@B @X) + (@ not (idx (-> @B) (-> @X) T)) ) + +(be asserta (@C) (@ asserta (-> @C))) + +(be assertz (@C) (@ assertz (-> @C))) + +(be retract (@C) + (2 cons (-> @C)) + (@ retract (list (car (-> @C)) (cdr (-> @C)))) ) + +(be clause ("@H" "@B") + ("@A" get (-> "@H") T) + (member "@B" "@A") ) + +(be show (@X) (@ show (-> @X))) + +### DB ### +(de initQuery (Var Cls Hook Val) + (let (Tree (tree Var Cls Hook) Rel (get Cls Var)) + (when (find '((B) (isa '+index B)) (get Rel 'bag)) + (setq Rel @) ) + (cond + ((pair Val) + (cond + ((pair (cdr Val)) + (cond + ((not (; Rel aux)) (quit "No Aux")) + ((atom (car Val)) + (init Tree Val (append Val T)) ) + ((>= (cdr Val) (car Val)) + (init Tree (car Val) (append (cdr Val) T)) ) + (T (init Tree (append (car Val) T) (cdr Val))) ) ) + ((isa '+Key Rel) + (init Tree (car Val) (cdr Val)) ) + ((>= (cdr Val) (car Val)) + (init Tree + (cons (car Val)) + (cons (cdr Val) T) ) ) + (T + (init Tree + (cons (car Val) T) + (cons (cdr Val)) ) ) ) ) + ((or (num? Val) (ext? Val)) + (if (isa '+Key Rel) + (init Tree Val Val) + (init Tree (cons Val) (cons Val T)) ) ) + ((=T Val) (init Tree)) + ((isa '+Key Rel) + (init Tree Val (pack Val `(char T))) ) + ((isa '+Idx Rel) + (let Q (init Tree (cons Val) (cons (pack Val `(char T)) T)) + (if (cdr Q) + Q + (setq Val (pack (car (split (chop Val) " ")))) + (init Tree (cons Val) (cons (pack Val `(char T)) T)) ) ) ) + (T (init Tree (cons Val) (cons (pack Val `(char T)) T))) ) ) ) + +# (db var cls obj) +(be db (@Var @Cls @Obj) + (@Q box + (with (or (get (-> @Cls) (-> @Var)) (meta (-> @Cls) (-> @Var))) + (initQuery (: var) (: cls) NIL '(NIL . T)) ) ) + (_db @Obj) ) + +# (db var cls hook|val obj) +(be db (@Var @Cls @X @Obj) + (@Q box + (with (or (get (-> @Cls) (-> @Var)) (meta (-> @Cls) (-> @Var))) + (cond + ((: hook) + (initQuery (: var) (: cls) (-> @X) '(NIL . T)) ) + ((isa '+Fold This) + (initQuery (: var) (: cls) NIL (fold (-> @X))) ) + (T + (initQuery (: var) (: cls) NIL (-> @X)) ) ) ) ) + (_db @Obj) ) + +# (db var cls hook val obj) +(be db (@Var @Cls @Hook @Val @Obj) + (@Q box + (with (or (get (-> @Cls) (-> @Var)) (meta (-> @Cls) (-> @Var))) + (initQuery (: var) (: cls) (-> @Hook) + (if (isa '+Fold This) + (fold (-> @Val)) + (-> @Val) ) ) ) ) + (_db @Obj) ) + +(be _db (@Obj) + (@ let (Q (val (-> @Q 2)) Cls (-> @Cls 2)) + (loop + (NIL (step Q (= '(NIL) (caaar Q))) T) + (T (isa Cls (setq "R" @))) ) ) + T + (fail) ) + +(be _db (@Obj) (@Obj . "R")) + +(repeat) + + +(be val (@V . @L) + (@V apply get (-> @L)) + T ) + +(be lst (@V . @L) + (@Lst box (apply get (-> @L))) + (_lst @V @Lst) ) + +(be _lst (@Val @Lst) (@ not (val (-> @Lst))) T (fail)) +(be _lst (@Val @Lst) (@Val pop (-> @Lst))) +(repeat) + +(be map (@V . @L) + (@Lst box (apply get (-> @L))) + (_map @V @Lst) ) + +(be _map (@Val @Lst) (@ not (val (-> @Lst))) T (fail)) +(be _map (@Val @Lst) (@Val prog1 (val (-> @Lst)) (pop (-> @Lst)))) +(repeat) + + +(be isa (@Typ . @L) + (@ or + (not (-> @Typ)) + (isa (-> @Typ) (apply get (-> @L))) ) ) + +(be same (@V . @L) + (@ let V (-> @V) + (or + (not V) + (let L (-> @L) + ("same" (car L) (cdr L)) ) ) ) ) + +(de "same" (X L) + (cond + ((not L) + (if (atom X) + (= V X) + (member V X) ) ) + ((atom X) + ("same" (get X (car L)) (cdr L)) ) + ((atom (car L)) + (pick + '((Y) ("same" (get Y (car L)) (cdr L))) + X ) ) + (T ("same" (apply get (car L) X) (cdr L))) ) ) + +(be bool (@F . @L) + (@ or + (not (-> @F)) + (apply get (-> @L)) ) ) + +(be range (@N . @L) + (@ let N (-> @N) + (or + (not N) + (let L (-> @L) + ("range" (car L) (cdr L)) ) ) ) ) + +(de "range" (X L) + (cond + ((not L) + (if (atom X) + (or + (<= (car N) X (cdr N)) + (>= (car N) X (cdr N)) ) + (find + '((Y) + (or + (<= (car N) Y (cdr N)) + (>= (car N) Y (cdr N)) ) ) + X ) ) ) + ((atom X) + ("range" (get X (car L)) (cdr L)) ) + ((atom (car L)) + (pick + '((Y) ("range" (get Y (car L)) (cdr L))) + X ) ) + (T ("range" (apply get (car L) X) (cdr L))) ) ) + +(be head (@S . @L) + (@ let S (-> @S) + (or + (not S) + (let L (-> @L) + ("head" (car L) (cdr L)) ) ) ) ) + +(de "head" (X L) + (cond + ((not L) + (if (atom X) + (pre? S X) + (find '((Y) (pre? S Y)) X) ) ) + ((atom X) + ("head" (get X (car L)) (cdr L)) ) + ((atom (car L)) + (pick + '((Y) ("head" (get Y (car L)) (cdr L))) + X ) ) + (T ("head" (apply get (car L) X) (cdr L))) ) ) + +(be fold (@S . @L) + (@ let S (-> @S) + (or + (not S) + (let L (-> @L) + ("fold" (car L) (cdr L)) ) ) ) ) + +(de "fold" (X L) + (cond + ((not L) + (let P (fold S) + (if (atom X) + (pre? P (fold X)) + (find '((Y) (pre? P (fold Y))) X) ) ) ) + ((atom X) + ("fold" (get X (car L)) (cdr L)) ) + ((atom (car L)) + (pick + '((Y) ("fold" (get Y (car L)) (cdr L))) + X ) ) + (T ("fold" (apply get (car L) X) (cdr L))) ) ) + +(be part (@S . @L) + (@ let S (-> @S) + (or + (not S) + (let L (-> @L) + ("part" (car L) (cdr L)) ) ) ) ) + +(de "part" (X L) + (cond + ((not L) + (let P (fold S) + (if (atom X) + (sub? P (fold X)) + (find '((Y) (sub? P (fold Y))) X) ) ) ) + ((atom X) + ("part" (get X (car L)) (cdr L)) ) + ((atom (car L)) + (pick + '((Y) ("part" (get Y (car L)) (cdr L))) + X ) ) + (T ("part" (apply get (car L) X) (cdr L))) ) ) + +(be tolr (@S . @L) + (@ let S (-> @S) + (or + (not S) + (let L (-> @L) + ("tolr" (car L) (cdr L)) ) ) ) ) + +(de "tolr" (X L) + (cond + ((not L) + (if (atom X) + (or (sub? S X) (pre? (ext:Snx S) (ext:Snx X))) + (let P (ext:Snx S) + (find + '((Y) + (or (sub? S Y) (pre? P (ext:Snx Y))) ) + X ) ) ) ) + ((atom X) + ("tolr" (get X (car L)) (cdr L)) ) + ((atom (car L)) + (pick + '((Y) ("tolr" (get Y (car L)) (cdr L))) + X ) ) + (T ("tolr" (apply get (car L) X) (cdr L))) ) ) + + +(de "select" (Lst Flg) + (let? X + (nond + ((atom (car Lst)) + (make + (for (L (pop 'Lst) L) + (let + (Var (pop 'L) + Cls (pop 'L) + Hook (and (get Cls Var 'hook) (pop 'L)) + Val (pop 'L) ) + (and (or Val Flg) (chain ("initSel"))) ) ) ) ) + ((pat? (car Lst)) + (let + (Var (pop 'Lst) + Cls (pop 'Lst) + Hook (and (get Cls Var 'hook) (pop 'Lst)) + Val (pop 'Lst) ) + (and (or Val Flg) ("initSel")) ) ) + (NIL + (let (Var (pop 'Lst) Val (pop 'Lst)) + (and + (or Flg (apply or Val)) + (cons Var (goal (pop 'Lst))) ) ) ) ) + (cons + (cons + (for (L NIL Lst) + (push 'L (pop 'Lst) NIL) + L ) + X ) ) ) ) + +(de "initSel" () + (with (treeRel Var Cls) + (cond + ((isa '+Fold This) + (initQuery Var (: cls) Hook (fold Val)) ) + ((isa '+Sn This) + (conc + (initQuery Var (: cls) Hook Val) + (initQuery Var (: cls) Hook (ext:Snx Val)) ) ) + (T (initQuery Var (: cls) Hook Val)) ) ) ) + +(de _gen (Lst Q) + (cond + (Lst + (use X + (loop + (T + (cond + ((atom (car Lst)) + (prog1 (car Lst) (set Lst)) ) + ((atom (caar Lst)) (pop Lst)) + (T + (prog1 + (step (car Lst) (= '(NIL) (caar (caar Lst)))) + (or (cdaar Lst) (set Lst)) ) ) ) + @ ) + (NIL (setq X (_gen (cddr Lst) Q))) + (set Lst + (let Y (cadr Lst) + (cond + ((atom Y) (get X Y)) + ((=T (caddr Y)) + (initQuery (car Y) (cadr Y) X (cadddr Y)) ) # X = Hook + (T + (initQuery + (car Y) + (cadr Y) + (caddr Y) + (if (cadddr Y) + (cons + (cons X (car @)) + (cons X (cdr @)) ) + X ) ) ) ) ) ) ) ) ) + ((pat? (car Q)) (get (prove (cdr Q)) @)) + (T (step Q (= '(NIL) (caaar Q)))) ) ) + +(be select (("@Obj" . "@X") . "@Lst") + (@ unify (-> "@X")) + ("@P" box (cdr (-> "@Lst"))) + ("@C" box # ((obj ..) curr . lst) + (let L (car (-> "@Lst")) + (setq L + (or + (mapcan "select" L) + ("select" (car L) T) ) ) + (cons NIL L L) ) ) + (_gen "@Obj") + (_sel) ) + +(be _gen (@Obj) + (@ let C (caadr (val (-> "@C" 2))) + (not (setq "*R" (_gen (car C) (cdr C)))) ) + T + (fail) ) + +(be _gen (@Obj) (@Obj . "*R")) + +(repeat) + +(be _sel () + (2 val (-> "@P" 2)) + (@ let C (val (-> "@C" 2)) + (unless (idx C "*R" T) + (rot (cddr C) (offset (cadr C) (cddr C))) + (set (cdr C) (cddr C)) ) ) + T ) + +(be _sel () + (@ let C (cdr (val (-> "@C" 2))) + (set C (or (cdar C) (cdr C))) ) + (fail) ) + +### Remote queries ### +(de rqry Args + (for (Q (goal (cdr Args)) (prove Q)) + (pr (get @ (car Args))) + (NIL (flush)) ) + (bye) ) + +(be remote ("@Lst" . "@CL") + (@Sockets box + (prog1 (cdr (-> "@Lst")) + (for X @ # (out . in) + ((car X) + (cons 'rqry (car (-> "@Lst")) (-> "@CL")) ) ) ) ) + (@ unify (car (-> "@Lst"))) + (_remote "@Lst") ) + +(be _remote ((@Obj . @)) + (@ not (val (-> @Sockets 2))) + T + (fail) ) + +(be _remote ((@Obj . @)) + (@Obj let (Box (-> @Sockets 2) Lst (val Box)) + (rot Lst) + (loop + (T ((cdar Lst)) @) + (NIL (set Box (setq Lst (cdr Lst)))) ) ) ) + +(repeat) + +# vi:et:ts=3:sw=3 diff --git a/lib/prof.l b/lib/prof.l @@ -0,0 +1,51 @@ +# 15may07abu +# (c) Software Lab. Alexander Burger + +# *Profile + +(de _prf? (Lst) + (and (pair Lst) (== 'tick (caadr Lst))) ) + +(de _prf (Lst) + (when (pair Lst) + (if (_prf? Lst) + (prog1 + (cadr (cadr Lst)) + (set (cdadr Lst) (cons (+ 0) (+ 0))) ) + (con + Lst + (list (cons 'tick (cons (+ 0) (+ 0)) (cdr Lst))) ) + T ) ) ) + +(de "uprf" (Lst) + (when (_prf? Lst) + (con Lst (cddr (cadr Lst))) + T ) ) + +(de prof ("X" "C") + (when (pair "X") + (setq "C" (cdr "X") "X" (car "X")) ) + (and (not "C") (num? (getd "X")) (expr "X")) + (unless + (and + (_prf (if "C" (method "X" "C") (getd "X"))) + (push1 '*Profile (cons "X" "C")) ) + (quit "Can't profile" "X") ) ) + +(de unprof ("X" "C") + (del (cons "X" "C") '*Profile) + ("uprf" (if "C" (method "X" "C") (getd "X"))) ) + +(de profile () + (mapc println + (flip + (by '((X) (+ (car X) (cadr X))) sort + (mapcar + '(("X") + (let P + (_prf + (if (cdr "X") + (method (car "X") (cdr "X")) + (getd (car "X")) ) ) + (cons (car P) (cdr P) "X") ) ) + *Profile ) ) ) ) ) diff --git a/lib/ps.l b/lib/ps.l @@ -0,0 +1,318 @@ +# 12nov09abu +# (c) Software Lab. Alexander Burger + +# "*Glyph" "*PgX" "*PgY" +# "*DX" "*DY" "*Pos" "*Fonts" "*Size" "*Font" "*Pag" "*Lim" "*FF" "*UL" + +(once + (balance '"*Glyph" + (sort + (make + (in "@lib/glyphlist.txt" + (use (L C) + (while (setq L (line)) + (unless (or (= "#" (car L)) (member " " L)) + (setq + L (split L ";") + C (char (hex (pack (cadr L)))) ) + (set (link C) (pack (car L))) ) ) ) ) ) ) ) ) + +(de glyph (C) + (val (car (idx '"*Glyph" C))) ) + +(de pdf (Nm . Prg) + (let (Ps (tmp Nm ".ps") Pdf (tmp Nm ".pdf")) + (out Ps (run Prg 1)) + (_pdf) + Pdf ) ) + +(de psOut (How Nm . Prg) + (ifn Nm + (out (list "lpr" (pack "-P" How)) (run Prg 1)) + (let (Ps (tmp Nm ".ps") Pdf (tmp Nm ".pdf")) + (out Ps (run Prg 1)) + (cond + ((not How) (_pdf) (url Pdf "PDF")) + ((=0 How) (_pdf) (url Pdf)) + ((=T How) (_pdf) (httpEcho Pdf "application/pdf" 1)) + ((fun? How) (How Ps) (_pdf)) + (T (call 'lpr (pack "-P" How) Ps) (_pdf)) ) + Pdf ) ) ) + +(de _pdf () + (if (= *OS "Darwin") + (call 'pstopdf Ps) + (call 'ps2pdf + (pack "-dDEVICEWIDTHPOINTS=" "*PgX") + (pack "-dDEVICEHEIGHTPOINTS=" "*PgY") + Ps Pdf ) ) ) + +(de psHead (DX DY) + (prinl "%!PS-Adobe-1.0") + (prinl "%%Creator: PicoLisp") + (prinl "%%BoundingBox: 0 0 " + (setq "*DX" DX "*PgX" DX) " " + (setq "*DY" DY "*PgY" DY) ) + (in "@lib/head.ps" (echo)) + (zero "*Pos") + (off "*Fonts" "*Lim" "*UL") + (setq "*Size" 12) ) + +(de a4 () + (psHead 595 842) ) + +(de a4L () + (psHead 842 595) ) + +(de a5 () + (psHead 420 595) ) + +(de a5L () + (psHead 595 420) ) + +(de _font () + (prinl "/" "*Font" " findfont " "*Size" " scalefont setfont") ) + +(de font ("F" . "Prg") + (use "N" + (cond + ((pair "F") + (setq "N" (pop '"F")) ) + ((num? "F") + (setq "N" "F" "F" "*Font") ) + (T (setq "N" "*Size")) ) + (unless (member "F" "*Fonts") + (push '"*Fonts" "F") + (prinl "/" "F" " isoLatin1 def") ) + (ifn "Prg" + (setq "*Size" "N" "*Font" "F") + (let ("*Size" "N" "*Font" "F") + (_font) + (psEval "Prg") ) ) ) + (_font) ) + +(de bold "Prg" + (let "*Font" (pack "*Font" "-Bold") + (_font) + (psEval "Prg") ) + (_font) ) + +(de width ("N" . "Prg") + (and "Prg" (prinl "currentlinewidth")) + (prinl "N" " setlinewidth") + (when "Prg" + (psEval "Prg") + (prinl "setlinewidth") ) ) + +(de gray ("N" . "Prg") + (and "Prg" (prinl "currentgray")) + (prinl (- 100 "N") " 100 div setgray") + (when "Prg" + (psEval "Prg") + (prinl "setgray") ) ) + +(de color ("R" "G" "B" . "Prg") + (and "Prg" (prinl "currentrgbcolor")) + (prinl "R" " 100 div " "G" " 100 div " "B" " 100 div setrgbcolor") + (when "Prg" + (psEval "Prg") + (prinl "setrgbcolor") ) ) + +(de poly (F X Y . @) + (prin "newpath " X " " (- "*PgY" Y) " moveto ") + (while (args) + (if (pair (next)) + (for P (arg) + (prin (car P) " " (- "*PgY" (cdr P)) " lineto ") ) + (prin (arg) " " (- "*PgY" (next)) " lineto ") ) ) + (prinl (if F "fill" "stroke")) ) + +(de rect (X1 Y1 X2 Y2 F) + (poly F X1 Y1 X2 Y1 X2 Y2 X1 Y2 X1 Y1) ) + +(de arc (X Y R F A B) + (prinl + "newpath " + X " " (- "*PgY" Y) " " R " " + (or A 0) " " + (or B 360) " arc " + (if F "fill" "stroke") ) ) + +(de ellipse (X Y DX DY F A B) + (prinl "matrix currentmatrix") + (prinl + "newpath " + X " " (- "*PgY" Y) " translate " + DX " " DY " scale 0 0 1 " + (or A 0) " " + (or B 360) " arc" ) + (prinl "setmatrix " (if F "fill" "stroke")) ) + + +(de indent (X DX) + (prinl X " 0 translate") + (dec '"*DX" X) + (and DX (dec '"*DX" DX)) ) + +(de window ("*X" "*Y" "*DX" "*DY" . "Prg") + ("?ff") + (prinl "gsave") + (prinl "*X" " " (- "*Y") " translate") + (let "*Pos" 0 + (psEval "Prg") ) + (prinl "grestore") ) + +(de ?ps ("X" "H" "V") + (and "X" (ps "X" "H" "V")) ) + +(de ps ("X" "H" "V") + (cond + ((not "X") (inc '"*Pos" "*Size")) + ((num? "X") (_ps (chop "X"))) + ((pair "X") (_ps "X")) + (T (mapc _ps (split (chop "X") "^J"))) ) ) + +(de ps+ ("X") + (fmtPs (chop "X")) + (?ul1) + (prinl " glyphArrayShow") + (?ul2) ) + +(de _ps ("L") + ("?ff") + (fmtPs "L") + (ifn "H" + (prin " 0") + (prin " dup glyphArrayWidth " "*DX" " exch sub") + (and (=0 "H") (prin " 2 div")) ) + (prin + " " + (- + "*PgY" + (cond + ((not "V") + (inc '"*Pos" "*Size") ) + ((=0 "V") + (setq "*Pos" (+ (/ "*Size" 4) (/ "*DY" 2))) ) + (T (setq "*Pos" "*DY")) ) ) ) + (prin " moveto") + (?ul1) + (prinl " glyphArrayShow") + (?ul2) ) + +(de escPs (C) + (and (sub? C "\\()") (prin "\\")) + (prin C) ) + +(de fmtPs (Lst) + (prin "[") + (while Lst + (if (>= (car Lst) `(char 128)) + (prin "/" (or (glyph (pop 'Lst)) ".notdef")) + (prin "(") + (escPs (pop 'Lst)) + (while (and Lst (>= `(char 127) (car Lst))) + (escPs (pop 'Lst)) ) + (prin ")") ) + (and Lst (space)) ) + (prin "]") ) + +(de ?ul1 () + (and "*UL" (prin " currentpoint " "*UL" " sub 3 -1 roll")) ) + +(de ?ul2 () + (when "*UL" + (prinl "currentpoint " "*UL" " sub") + (prinl "gsave newpath 4 -2 roll moveto lineto stroke grestore") ) ) + +(de pos (N) + (if N (+ N "*Pos") "*Pos") ) + +(de down (N) + (inc '"*Pos" (or N "*Size")) ) + +(de table ("Lst" . "Prg") #> Y + ("?ff") + (let ("PosX" 0 "Max" "*Size") + (mapc + '(("N" "X") + (window "PosX" "*Pos" "N" "Max" + (if (atom "X") (ps (eval "X")) (eval "X")) + (inc '"PosX" "N") + (setq "Max" (max "*Pos" "Max")) ) ) + "Lst" + "Prg" ) + (inc '"*Pos" "Max") ) ) + +(de underline ("*UL" . "Prg") + (psEval "Prg") ) + +(de hline (Y X2 X1) + (inc 'Y "*Pos") + (poly NIL (or X2 "*DX") Y (or X1 0) Y) ) + +(de vline (X Y2 Y1) + (poly NIL X (or Y2 "*DY") X (or Y1 0)) ) + +(de border (Y) + (rect 0 (or Y 0) "*DX" "*Pos") ) + +(de psEval ("Prg") + (while "Prg" + (if (atom (car "Prg")) + (ps (eval (pop '"Prg"))) + (eval (pop '"Prg")) ) ) ) + +(de page (Flg) + (when (=T Flg) + (prinl "gsave") ) + (prinl "showpage") + (zero "*Pos") + (cond + ((=T Flg) + (prinl "grestore") ) + ((=0 Flg) + (setq "*DX" "*PgX" "*DY" "*PgY" "*Lim") ) + (T (prin "%%DocumentFonts:") + (while "*Fonts" + (prin " " (pop '"*Fonts")) ) + (prinl) + (prinl "%%EOF") ) ) ) + +(de pages (Lst . Prg) + (setq "*Pag" Lst "*Lim" (pop '"*Pag") "*FF" Prg) ) + +(de "?ff" () + (when (and "*Lim" (>= "*Pos" "*Lim")) + (off "*Lim") + (run "*FF") + (setq "*Lim" (pop '"*Pag")) ) ) + +(de noff "Prg" + (let "*Lim" NIL + (psEval "Prg") ) ) + +(de eps (Eps X Y DX DY) + (prinl "gsave " (or X 0) " " (- "*PgY" (or Y 0)) " translate") + (when DX + (prinl DX " 100. div " (or DY DX) " 100. div scale") ) + (in Eps (echo)) + (prinl "grestore") ) + +(====) + +(de brief ("F" "Fnt" "Abs" . "Prg") + (when "F" + (poly NIL 10 265 19 265) # Faltmarken + (poly NIL 10 421 19 421) ) + (poly NIL 50 106 50 103 53 103) # Fenstermarken + (poly NIL 50 222 50 225 53 225) + (poly NIL 288 103 291 103 291 106) + (poly NIL 288 225 291 225 291 222) + (poly NIL 50 114 291 114) # Absender + (window 60 102 220 10 + (font "Fnt" (ps "Abs" 0)) ) + (window 65 125 210 90 + (psEval "Prg") ) ) + +# vi:et:ts=3:sw=3 diff --git a/lib/readline.l b/lib/readline.l @@ -0,0 +1,28 @@ +# 05dec08abu +# (c) Software Lab. Alexander Burger + +(load "@lib/gcc.l") + +(gcc "readline" '("-lreadline") '_led) + +#include <readline/readline.h> +#include <readline/history.h> + +any _led(any ex __attribute__((unused))) { + char *p; + any x; + + rl_already_prompted = YES; + if ((p = readline(": ")) && *p) + add_history(p); + x = mkStr(p); + free(p); + return x; +} + +/**/ + +# Enable line editing +(de *Led (_led)) + +# vi:et:ts=3:sw=3 diff --git a/lib/rsa.l b/lib/rsa.l @@ -0,0 +1,109 @@ +# 10nov04abu +# (c) Software Lab. Alexander Burger + +# *InND + +# Generate long random number +(de longRand (N) + (use (R D) + (while (=0 (setq R (abs (rand))))) + (until (> R N) + (unless (=0 (setq D (abs (rand)))) + (setq R (* R D)) ) ) + (% R N) ) ) + +# X power Y modulus N +(de **Mod (X Y N) + (let M 1 + (loop + (when (bit? 1 Y) + (setq M (% (* M X) N)) ) + (T (=0 (setq Y (>> 1 Y))) + M ) + (setq X (% (* X X) N)) ) ) ) + +# Probabilistic prime check +(de prime? (N) + (and + (> N 1) + (bit? 1 N) + (let (Q (dec N) K 0) + (until (bit? 1 Q) + (setq + Q (>> 1 Q) + K (inc K) ) ) + (do 50 + (NIL (_prim? N Q K)) + T ) ) ) ) + +# (Knuth Vol.2, p.379) +(de _prim? (N Q K) + (use (X J Y) + (while (> 2 (setq X (longRand N)))) + (setq + J 0 + Y (**Mod X Q N) ) + (loop + (T + (or + (and (=0 J) (= 1 Y)) + (= Y (dec N)) ) + T ) + (T + (or + (and (> J 0) (= 1 Y)) + (<= K (inc 'J)) ) + NIL ) + (setq Y (% (* Y Y) N)) ) ) ) + +# Find a prime number with `Len' digits +(de prime (Len) + (let P (longRand (** 10 (*/ Len 2 3))) + (unless (bit? 1 P) + (inc 'P) ) + (until (prime? P) # P: Prime number of size 2/3 Len + (inc 'P 2) ) + # R: Random number of size 1/3 Len + (let (R (longRand (** 10 (/ Len 3))) K (+ R (% (- P R) 3))) + (when (bit? 1 K) + (inc 'K 3) ) + (until (prime? (setq R (inc (* K P)))) + (inc 'K 6) ) + R ) ) ) + +# Generate RSA key +(de rsaKey (N) #> (Encrypt . Decrypt) + (let (P (prime (*/ N 5 10)) Q (prime (*/ N 6 10))) + (cons + (* P Q) + (/ + (inc (* 2 (dec P) (dec Q))) + 3 ) ) ) ) + +# Encrypt a list of characters +(de encrypt (Key Lst) + (let Siz (>> 1 (size Key)) + (make + (while Lst + (let N (char (pop 'Lst)) + (while (> Siz (size N)) + (setq N (>> -16 N)) + (inc 'N (char (pop 'Lst))) ) + (link (**Mod N 3 Key)) ) ) ) ) ) + +# Decrypt a list of numbers +(de decrypt (Keys Lst) + (mapcan + '((N) + (let Res NIL + (setq N (**Mod N (cdr Keys) (car Keys))) + (until (=0 N) + (push 'Res (char (& `(dec (** 2 16)) N))) + (setq N (>> 16 N)) ) + Res ) ) + Lst ) ) + +# Init crypt +(de rsa (N) + (seed (in "/dev/urandom" (rd 20))) + (setq *InND (rsaKey N)) ) diff --git a/lib/scrape.l b/lib/scrape.l @@ -0,0 +1,160 @@ +# 08apr09abu +# (c) Software Lab. Alexander Burger + +# *ScrHost *ScrPort *Title *Expect *Found +# *Links *Forms *Buttons *Fields *Errors + +# Scrape HTML form(s) +(de scrape (Host Port How) + (client (setq *ScrHost Host) (setq *ScrPort Port) How + (off *Links *Forms *Buttons *Fields *Errors) + (while + (from + "<title>" + "<base href=\"http://" + "<a href=\"" + " action=\"" + "<input type=\"submit\" name=\"" + "<input type=\"hidden\" name=\"" + "<input type=\"text\" name=\"" + "<input type=\"password\" name=\"" + "<select name=\"" + "<option selected=\"selected\">" + "<textarea name=\"" + "<span id=\"" + "<div class=\"err\">" + *Expect ) + (case @ + ("<title>" + (setq *Title (ht:Pack (till "<"))) ) + ("<base href=\"http://" + (setq + *ScrHost (rot (cdr (rot (split (till "\"") '/ ':)))) + *ScrPort (format (pack (pop '*ScrHost))) + *ScrHost (pack *ScrHost) ) ) + ("<a href=\"" + (let Url (till "\"" T) + (from ">") + (cond + ((till "<") + (queue '*Links (cons (ht:Pack @) Url)) ) + ((= "<img" (till " " T)) + (from "alt=\"") + (queue '*Links (cons (ht:Pack (till "\"")) Url)) ) ) ) ) + (" action=\"" + (queue '*Forms (list (till "\"" T))) ) # (action . fields) + ("<input type=\"submit\" name=\"" + (let Nm (till "\"" T) + (from "value=\"") + (queue '*Buttons # (label field . form) + (cons + (ht:Pack (till "\"")) + (cons Nm T) + (last *Forms) ) ) ) ) + ("<input type=\"hidden\" name=\"" + (conc (last *Forms) + (cons + (cons (till "\"" T) + (prog (from "value=\"") (ht:Pack (till "\"")))) ) ) ) + (("<input type=\"text\" name=\"" "<input type=\"password\" name=\"") + (conc (last *Forms) + (cons + (queue '*Fields + (cons (till "\"" T) + (prog (from "value=\"") (ht:Pack (till "\"")))) ) ) ) ) + ("<select name=\"" + (conc (last *Forms) + (cons + (queue '*Fields (cons (till "\"" T))) ) ) ) + ("<option selected=\"selected\">" + (con (last *Fields) (ht:Pack (till "<"))) ) + ("<textarea name=\"" + (conc (last *Forms) + (cons + (queue '*Fields + (cons (till "\"" T) + (prog (from ">") (ht:Pack (till "<"))) ) ) ) ) ) + ("<span id=\"" + (from ">") + (queue '*Fields (ht:Pack (till "<"))) ) + ("<div class=\"err\">" + (queue '*Errors (ht:Pack (till "<"))) ) + (T (on *Found)) ) ) + (or *Errors *Title) ) ) + +# Expect content +(de expect (*Expect . "Prg") + (let *Found NIL + (run "Prg") + (unless *Found + (quit "Content not found" *Expect) ) ) ) + +# Click on a link +(de click (Lbl Cnt) + (let L (cdr (target *Links Lbl Cnt)) + (when (pre? "http://" L) + (setq + L (split (nth (chop L) 8) '/ ':) + *ScrHost (pack (pop 'L)) + *ScrPort (ifn (format (pack (car L))) 80 (pop 'L) @) + L (glue '/ L) ) ) + (scrape *ScrHost *ScrPort L) ) ) + +# Press a button +(de press (Lbl Cnt) + (let B (target *Buttons Lbl Cnt) + (scrape *ScrHost *ScrPort + (cons + (caddr B) + (glue "&" + (mapcar + '((X) + (list (car X) '= (ht:Fmt (cdr X))) ) + (cons (cadr B) (cdddr B)) ) ) ) ) ) ) + +# Retrieve a field's value +(de value (Fld Cnt) + (fin (field Fld Cnt)) ) + +# Set a field's value +(de enter (Fld Str Cnt) + (con (field Fld Cnt) Str) ) + +### Utilities ### +(de display () + (prinl "###############") + (apply println (mapcar car *Links) 'click) + (prinl) + (apply println (mapcar car *Buttons) 'press) + (prinl) + (apply println (trim (mapcar fin *Fields)) 'value) + (prinl) + *Title ) + +(de target (Lst Lbl Cnt) + (cond + ((num? Lbl) + (get Lst Lbl) ) + ((pair Lbl) Lbl) + (T + (default Cnt 1) + (or + (find + '((L) + (and + (pre? Lbl (car L)) + (=0 (dec 'Cnt)) ) ) + Lst ) + (quit "Target not found" Lbl) ) ) ) ) + +(de field (Fld Cnt) + (or + (cond + ((gt0 Fld) + (get *Fields Fld) ) + ((lt0 Fld) + (get *Fields (+ (length *Fields) Fld 1)) ) + (T (assoc Fld (cdr (get *Forms (or Cnt 1))))) ) + (quit "Field not found" Fld) ) ) + +# vi:et:ts=3:sw=3 diff --git a/lib/simul.l b/lib/simul.l @@ -0,0 +1,154 @@ +# 22mar10abu +# (c) Software Lab. Alexander Burger + +(de permute (Lst) + (ifn (cdr Lst) + (cons Lst) + (mapcan + '((X) + (mapcar + '((Y) (cons X Y)) + (permute (delete X Lst)) ) ) + Lst ) ) ) + +(de shuffle (Lst) + (make + (for (N (length Lst) (gt0 N)) + (setq Lst + (conc + (cut (rand 0 (dec 'N)) 'Lst) + (prog (link (car Lst)) (cdr Lst)) ) ) ) ) ) + +(de samples (Cnt Lst) + (make + (until (=0 Cnt) + (when (>= Cnt (rand 1 (length Lst))) + (link (car Lst)) + (dec 'Cnt) ) + (pop 'Lst) ) ) ) + + +# Genetic Algorithm +(de gen ("Pop" "Cond" "Re" "Mu" "Se") + (until ("Cond" "Pop") + (for ("P" "Pop" "P" (cdr "P")) + (set "P" + (maxi "Se" # Selection + (make + (for ("P" "Pop" "P") + (rot "P" (rand 1 (length "P"))) + (link # Recombination + Mutation + ("Mu" ("Re" (pop '"P") (pop '"P"))) ) ) ) ) ) ) ) + (maxi "Se" "Pop") ) + + +# Alpha-Beta tree search +(de game ("Flg" "Cnt" "Moves" "Move" "Cost") + (let ("Alpha" '(1000000) "Beta" -1000000) + (recur ("Flg" "Cnt" "Alpha" "Beta") + (if (=0 (dec '"Cnt")) + (let? "Lst" ("Moves" "Flg") + (loop + ("Move" (caar "Lst")) + (setq "*Val" (list ("Cost" "Flg") (car "Lst"))) + ("Move" (cdar "Lst")) + (T (>= "Beta" (car "*Val")) + (cons "Beta" (car "Lst") (cdr "Alpha")) ) + (when (> (car "Alpha") (car "*Val")) + (setq "Alpha" "*Val") ) + (NIL (setq "Lst" (cdr "Lst")) "Alpha") ) ) + (let? "Lst" + (sort + (mapcar + '(("Mov") + (prog2 + ("Move" (car "Mov")) + (cons ("Cost" "Flg") "Mov") + ("Move" (cdr "Mov")) ) ) + ("Moves" "Flg") ) ) + (loop + ("Move" (cadar "Lst")) + (setq "*Val" + (if (recurse (not "Flg") "Cnt" (cons (- "Beta")) (- (car "Alpha"))) + (cons (- (car @)) (cdar "Lst") (cdr @)) + (list (caar "Lst") (cdar "Lst")) ) ) + ("Move" (cddar "Lst")) + (T (>= "Beta" (car "*Val")) + (cons "Beta" (cdar "Lst") (cdr "Alpha")) ) + (when (> (car "Alpha") (car "*Val")) + (setq "Alpha" "*Val") ) + (NIL (setq "Lst" (cdr "Lst")) "Alpha") ) ) ) ) ) ) + + +### Grids ### +(de grid (DX DY) + (prog1 + (make + (for X DX + (link + (make + (for Y DY + (link + (def + (if (> DX 26) + (box) + (intern (pack (char (+ X 96)) Y)) ) + (cons (cons) (cons)) ) ) ) ) ) ) ) + (let (Lst @ West) + (while Lst + (let (East (cadr Lst) South) + (for (L (car Lst) (pop 'L)) + (with @ + (and (pop 'West) (set (: 0 1) @)) # west + (and (pop 'East) (con (: 0 1) @)) # east + (and South (set (: 0 -1) @)) # south + (and (car L) (con (: 0 -1) @)) # north + (setq South This) ) ) ) + (setq West (pop 'Lst)) ) ) ) ) + +(de west (This) + (: 0 1 1) ) + +(de east (This) + (: 0 1 -1) ) + +(de south (This) + (: 0 -1 1) ) + +(de north (This) + (: 0 -1 -1) ) + +(de disp ("Grid" "How" "Fun" "X" "Y" "DX" "DY") + (setq "Grid" + (if "X" + (mapcar + '((L) (flip (head "DY" (nth L "Y")))) + (head "DX" (nth "Grid" "X")) ) + (mapcar reverse "Grid") ) ) + (let (N (+ (length (cdar "Grid")) (or "Y" 1)) Sp (length N)) + ("border" north) + (while (caar "Grid") + (prin " " (align Sp N) " " + (and "How" (if (and (nT "How") (west (caar "Grid"))) " " '|)) ) + (for L "Grid" + (prin + ("Fun" (car L)) + (and "How" (if (and (nT "How") (east (car L))) " " '|)) ) ) + (prinl) + ("border" south) + (map pop "Grid") + (dec 'N) ) + (unless (> (default "X" 1) 26) + (space (inc Sp)) + (for @ "Grid" + (prin " " (and "How" " ") (char (+ 96 "X"))) + (T (> (inc '"X") 26)) ) + (prinl) ) ) ) + +(de "border" (Dir) + (when "How" + (space Sp) + (prin " +") + (for L "Grid" + (prin (if (and (nT "How") (Dir (car L))) " +" "---+")) ) + (prinl) ) ) diff --git a/lib/sq.l b/lib/sq.l @@ -0,0 +1,131 @@ +# 24dec09abu +# (c) Software Lab. Alexander Burger + +# (select [var ..] cls [hook|T] [var val ..]) +(de select Lst + (let + (Vars + (make + (until + (or + (atom Lst) + (and + (sym? (car Lst)) + (= `(char "+") (char (car Lst))) ) ) + (link (pop 'Lst)) ) ) + Cls (pop 'Lst) + Hook (cond + ((ext? (car Lst)) (pop 'Lst)) + ((=T (car Lst)) (pop 'Lst) *DB) ) ) + (default Lst + (cons + (or + (car Vars) + (and + (find + '((X) (isa '(+Need +index) (car X))) + (getl Cls) ) + (get (car @) 'var) ) + (cdr + (maxi caar + (getl (get (or Hook *DB) Cls)) ) ) ) ) ) + (let Q + (goal + (cons + (make + (link + 'select + '(@@) + (make + (for (L Lst L) + (link + (make + (link (pop 'L) Cls) + (and Hook (link Hook)) + (link (if L (pop 'L) '(NIL . T))) ) ) ) ) ) + (while Lst + (let (Var (pop 'Lst) Val (if Lst (pop 'Lst) '(NIL . T))) + (link + (list + (cond + ((pair Val) 'range) + ((or (num? Val) (ext? Val)) 'same) + ((=T Val) 'bool) + ((isa '+Fold (get Cls Var)) 'fold) + ((isa '+Sn (get Cls Var)) 'tolr) + (T 'head) ) + Val '@@ Var ) ) ) ) ) ) ) + (use Obj + (loop + (NIL (setq Obj (cdr (asoq '@@ (prove Q))))) + (ifn Vars + (show Obj) + (for Var Vars + (cond + ((pair Var) + (print (apply get Var Obj)) ) + ((meta Obj Var) + (print> @ (get Obj Var)) ) + (T (print (get Obj Var))) ) + (space) ) + (print Obj) ) + (T (line) Obj) ) ) ) ) ) + +(dm (print> . +relation) (Val) + (print Val) ) + +(dm (print> . +Number) (Val) + (prin (format Val (: scl))) ) + +(dm (print> . +Date) (Val) + (print (datStr Val)) ) + + +# (update 'obj ['var]) +(de update (Obj Var) + (let *Dbg NIL + (printsp Obj) + (if Var + (_update (get Obj Var) Var) + (set!> Obj + (any (revise (sym (val Obj)))) ) + (for X (getl Obj) + (_update (or (atom X) (pop 'X)) X) ) ) + Obj ) ) + +(de _update (Val Var) + (printsp Var) + (let New + (if (meta Obj Var) + (revise> @ Val) + (any (revise (sym Val))) ) + (unless (= New Val) + (if (mis> Obj Var New) + (quit "mismatch" @) + (put!> Obj Var New) ) ) ) ) + + +(dm (revise> . +relation) (Val) + (any (revise (sym Val))) ) + +(dm (revise> . +Bag) (Lst) + (mapcar + '((V B) (space 6) (revise> B V)) + (any (revise (sym Lst))) + (: bag) ) ) + +(dm (revise> . +Number) (Val) + (format + (revise (format Val (: scl))) + (: scl) ) ) + +(dm (revise> . +Date) (Val) + (expDat + (revise + (datStr Val) + '((S) (list (datStr (expDat S)))) ) ) ) + +(dm (revise> . +List) (Val) + (mapcar + '((X) (space 3) (extra X)) + (any (revise (sym Val))) ) ) diff --git a/lib/tags b/lib/tags @@ -0,0 +1,346 @@ +! (2560 . "@src64/flow.l") +$ (2662 . "@src64/flow.l") +% (2238 . "@src64/big.l") +& (2459 . "@src64/big.l") +* (2057 . "@src64/big.l") +*/ (2114 . "@src64/big.l") ++ (1839 . "@src64/big.l") +- (1877 . "@src64/big.l") +-> (3788 . "@src64/subr.l") +/ (2179 . "@src64/big.l") +: (2896 . "@src64/sym.l") +:: (2920 . "@src64/sym.l") +; (2822 . "@src64/sym.l") +< (2192 . "@src64/subr.l") +<= (2222 . "@src64/subr.l") +<> (2129 . "@src64/subr.l") += (2100 . "@src64/subr.l") +=0 (2158 . "@src64/subr.l") +=: (2851 . "@src64/sym.l") +== (2044 . "@src64/subr.l") +==== (967 . "@src64/sym.l") +=T (2166 . "@src64/subr.l") +> (2252 . "@src64/subr.l") +>= (2282 . "@src64/subr.l") +>> (2293 . "@src64/big.l") +abs (2383 . "@src64/big.l") +accept (140 . "@src64/net.l") +alarm (455 . "@src64/main.l") +all (772 . "@src64/sym.l") +and (1637 . "@src64/flow.l") +any (3750 . "@src64/io.l") +append (1329 . "@src64/subr.l") +apply (581 . "@src64/apply.l") +arg (1858 . "@src64/main.l") +args (1834 . "@src64/main.l") +argv (2467 . "@src64/main.l") +as (146 . "@src64/flow.l") +asoq (2938 . "@src64/subr.l") +assoc (2903 . "@src64/subr.l") +at (2122 . "@src64/flow.l") +atom (2370 . "@src64/subr.l") +bind (1375 . "@src64/flow.l") +bit? (2400 . "@src64/big.l") +bool (1737 . "@src64/flow.l") +box (839 . "@src64/flow.l") +box? (999 . "@src64/sym.l") +by (1535 . "@src64/apply.l") +bye (3137 . "@src64/flow.l") +caaaar (271 . "@src64/subr.l") +caaadr (288 . "@src64/subr.l") +caaar (99 . "@src64/subr.l") +caadar (311 . "@src64/subr.l") +caaddr (334 . "@src64/subr.l") +caadr (116 . "@src64/subr.l") +caar (31 . "@src64/subr.l") +cadaar (360 . "@src64/subr.l") +cadadr (383 . "@src64/subr.l") +cadar (136 . "@src64/subr.l") +caddar (409 . "@src64/subr.l") +cadddr (435 . "@src64/subr.l") +caddr (156 . "@src64/subr.l") +cadr (45 . "@src64/subr.l") +call (2793 . "@src64/flow.l") +car (5 . "@src64/subr.l") +case (1978 . "@src64/flow.l") +catch (2478 . "@src64/flow.l") +cd (2234 . "@src64/main.l") +cdaaar (464 . "@src64/subr.l") +cdaadr (487 . "@src64/subr.l") +cdaar (179 . "@src64/subr.l") +cdadar (513 . "@src64/subr.l") +cdaddr (539 . "@src64/subr.l") +cdadr (199 . "@src64/subr.l") +cdar (62 . "@src64/subr.l") +cddaar (568 . "@src64/subr.l") +cddadr (594 . "@src64/subr.l") +cddar (222 . "@src64/subr.l") +cdddar (623 . "@src64/subr.l") +cddddr (652 . "@src64/subr.l") +cdddr (245 . "@src64/subr.l") +cddr (79 . "@src64/subr.l") +cdr (17 . "@src64/subr.l") +chain (1132 . "@src64/subr.l") +char (3231 . "@src64/io.l") +chop (1093 . "@src64/sym.l") +circ (816 . "@src64/subr.l") +clip (1784 . "@src64/subr.l") +close (4137 . "@src64/io.l") +cmd (2449 . "@src64/main.l") +cnt (1279 . "@src64/apply.l") +commit (1503 . "@src64/db.l") +con (725 . "@src64/subr.l") +conc (781 . "@src64/subr.l") +cond (1932 . "@src64/flow.l") +connect (202 . "@src64/net.l") +cons (747 . "@src64/subr.l") +copy (1216 . "@src64/subr.l") +ctl (4077 . "@src64/io.l") +ctty (2259 . "@src64/main.l") +cut (1795 . "@src64/sym.l") +date (1973 . "@src64/main.l") +dbck (2092 . "@src64/db.l") +de (551 . "@src64/flow.l") +dec (1991 . "@src64/big.l") +def (475 . "@src64/flow.l") +default (1659 . "@src64/sym.l") +del (1850 . "@src64/sym.l") +delete (1392 . "@src64/subr.l") +delq (1443 . "@src64/subr.l") +diff (2561 . "@src64/subr.l") +dir (2392 . "@src64/main.l") +dm (563 . "@src64/flow.l") +do (2152 . "@src64/flow.l") +e (2623 . "@src64/flow.l") +echo (4157 . "@src64/io.l") +env (510 . "@src64/main.l") +eof (3308 . "@src64/io.l") +eol (3299 . "@src64/io.l") +errno (1193 . "@src64/main.l") +eval (208 . "@src64/flow.l") +ext (4852 . "@src64/io.l") +ext? (1034 . "@src64/sym.l") +extern (900 . "@src64/sym.l") +extra (1280 . "@src64/flow.l") +extract (1084 . "@src64/apply.l") +fifo (1961 . "@src64/sym.l") +file (2339 . "@src64/main.l") +fill (3165 . "@src64/subr.l") +filter (1027 . "@src64/apply.l") +fin (2018 . "@src64/subr.l") +finally (2536 . "@src64/flow.l") +find (1188 . "@src64/apply.l") +fish (1479 . "@src64/apply.l") +flg? (2417 . "@src64/subr.l") +flip (1686 . "@src64/subr.l") +flush (4827 . "@src64/io.l") +fold (3341 . "@src64/sym.l") +for (2241 . "@src64/flow.l") +fork (2960 . "@src64/flow.l") +format (1769 . "@src64/big.l") +free (2034 . "@src64/db.l") +from (3327 . "@src64/io.l") +full (1066 . "@src64/subr.l") +fun? (734 . "@src64/sym.l") +gc (378 . "@src64/gc.l") +ge0 (2359 . "@src64/big.l") +get (2748 . "@src64/sym.l") +getd (742 . "@src64/sym.l") +getl (3030 . "@src64/sym.l") +glue (1232 . "@src64/sym.l") +gt0 (2370 . "@src64/big.l") +head (1805 . "@src64/subr.l") +heap (481 . "@src64/main.l") +hear (3049 . "@src64/io.l") +host (185 . "@src64/net.l") +id (1034 . "@src64/db.l") +idx (2035 . "@src64/sym.l") +if (1818 . "@src64/flow.l") +if2 (1837 . "@src64/flow.l") +ifn (1878 . "@src64/flow.l") +in (3974 . "@src64/io.l") +inc (1924 . "@src64/big.l") +index (2609 . "@src64/subr.l") +info (2296 . "@src64/main.l") +intern (875 . "@src64/sym.l") +ipid (2905 . "@src64/flow.l") +isa (976 . "@src64/flow.l") +job (1442 . "@src64/flow.l") +journal (977 . "@src64/db.l") +key (3158 . "@src64/io.l") +kill (2937 . "@src64/flow.l") +last (2029 . "@src64/subr.l") +length (2685 . "@src64/subr.l") +let (1492 . "@src64/flow.l") +let? (1553 . "@src64/flow.l") +lieu (1163 . "@src64/db.l") +line (3483 . "@src64/io.l") +lines (3636 . "@src64/io.l") +link (1163 . "@src64/subr.l") +list (887 . "@src64/subr.l") +listen (152 . "@src64/net.l") +lit (183 . "@src64/flow.l") +load (3951 . "@src64/io.l") +lock (1191 . "@src64/db.l") +loop (2184 . "@src64/flow.l") +low? (3213 . "@src64/sym.l") +lowc (3243 . "@src64/sym.l") +lst? (2387 . "@src64/subr.l") +lt0 (2348 . "@src64/big.l") +lup (2224 . "@src64/sym.l") +made (1098 . "@src64/subr.l") +make (1079 . "@src64/subr.l") +map (715 . "@src64/apply.l") +mapc (757 . "@src64/apply.l") +mapcan (967 . "@src64/apply.l") +mapcar (853 . "@src64/apply.l") +mapcon (907 . "@src64/apply.l") +maplist (799 . "@src64/apply.l") +maps (656 . "@src64/apply.l") +mark (1952 . "@src64/db.l") +match (3058 . "@src64/subr.l") +max (2312 . "@src64/subr.l") +maxi (1377 . "@src64/apply.l") +member (2427 . "@src64/subr.l") +memq (2449 . "@src64/subr.l") +meta (3135 . "@src64/sym.l") +meth (1102 . "@src64/flow.l") +method (1066 . "@src64/flow.l") +min (2341 . "@src64/subr.l") +mini (1428 . "@src64/apply.l") +mix (1251 . "@src64/subr.l") +mmeq (2477 . "@src64/subr.l") +n0 (2174 . "@src64/subr.l") +n== (2072 . "@src64/subr.l") +nT (2183 . "@src64/subr.l") +name (499 . "@src64/sym.l") +nand (1672 . "@src64/flow.l") +native (1201 . "@src64/main.l") +need (918 . "@src64/subr.l") +new (850 . "@src64/flow.l") +next (1841 . "@src64/main.l") +nil (1755 . "@src64/flow.l") +nond (1955 . "@src64/flow.l") +nor (1693 . "@src64/flow.l") +not (1745 . "@src64/flow.l") +nth (685 . "@src64/subr.l") +num? (2398 . "@src64/subr.l") +off (1596 . "@src64/sym.l") +offset (2649 . "@src64/subr.l") +on (1581 . "@src64/sym.l") +onOff (1611 . "@src64/sym.l") +one (1644 . "@src64/sym.l") +open (4099 . "@src64/io.l") +opid (2921 . "@src64/flow.l") +opt (2570 . "@src64/main.l") +or (1653 . "@src64/flow.l") +out (3994 . "@src64/io.l") +pack (1144 . "@src64/sym.l") +pair (2379 . "@src64/subr.l") +pass (620 . "@src64/apply.l") +pat? (720 . "@src64/sym.l") +path (1168 . "@src64/io.l") +peek (3215 . "@src64/io.l") +pick (1235 . "@src64/apply.l") +pid (157 . "@src64/flow.l") +pipe (4015 . "@src64/io.l") +poll (3111 . "@src64/io.l") +pool (657 . "@src64/db.l") +pop (1771 . "@src64/sym.l") +port (5 . "@src64/net.l") +pr (4941 . "@src64/io.l") +pre? (1409 . "@src64/sym.l") +prin (4751 . "@src64/io.l") +prinl (4765 . "@src64/io.l") +print (4791 . "@src64/io.l") +println (4822 . "@src64/io.l") +printsp (4807 . "@src64/io.l") +prog (1773 . "@src64/flow.l") +prog1 (1781 . "@src64/flow.l") +prog2 (1798 . "@src64/flow.l") +prop (2779 . "@src64/sym.l") +protect (471 . "@src64/main.l") +prove (3412 . "@src64/subr.l") +push (1686 . "@src64/sym.l") +push1 (1722 . "@src64/sym.l") +put (2696 . "@src64/sym.l") +putl (2948 . "@src64/sym.l") +pwd (2223 . "@src64/main.l") +queue (1918 . "@src64/sym.l") +quit (914 . "@src64/main.l") +quote (141 . "@src64/flow.l") +rand (2627 . "@src64/big.l") +range (988 . "@src64/subr.l") +rank (2966 . "@src64/subr.l") +raw (433 . "@src64/main.l") +rd (4869 . "@src64/io.l") +read (2489 . "@src64/io.l") +replace (1490 . "@src64/subr.l") +rest (1887 . "@src64/main.l") +reverse (1665 . "@src64/subr.l") +rewind (4835 . "@src64/io.l") +rollback (1885 . "@src64/db.l") +rot (848 . "@src64/subr.l") +rpc (4974 . "@src64/io.l") +run (332 . "@src64/flow.l") +sect (2513 . "@src64/subr.l") +seed (2612 . "@src64/big.l") +seek (1141 . "@src64/apply.l") +send (1146 . "@src64/flow.l") +seq (1090 . "@src64/db.l") +set (1480 . "@src64/sym.l") +setq (1513 . "@src64/sym.l") +size (2750 . "@src64/subr.l") +skip (3285 . "@src64/io.l") +sort (3837 . "@src64/subr.l") +sp? (711 . "@src64/sym.l") +space (4769 . "@src64/io.l") +split (1579 . "@src64/subr.l") +state (2022 . "@src64/flow.l") +stem (1974 . "@src64/subr.l") +str (3804 . "@src64/io.l") +str? (1013 . "@src64/sym.l") +strip (1563 . "@src64/subr.l") +sub? (1442 . "@src64/sym.l") +sum (1326 . "@src64/apply.l") +super (1233 . "@src64/flow.l") +sym (3790 . "@src64/io.l") +sym? (2406 . "@src64/subr.l") +sync (3011 . "@src64/io.l") +sys (2764 . "@src64/flow.l") +t (1764 . "@src64/flow.l") +tail (1896 . "@src64/subr.l") +tell (3081 . "@src64/io.l") +text (1270 . "@src64/sym.l") +throw (2504 . "@src64/flow.l") +tick (2873 . "@src64/flow.l") +till (3394 . "@src64/io.l") +time (2106 . "@src64/main.l") +touch (1049 . "@src64/sym.l") +trim (1746 . "@src64/subr.l") +try (1187 . "@src64/flow.l") +type (929 . "@src64/flow.l") +udp (269 . "@src64/net.l") +unify (3810 . "@src64/subr.l") +unless (1914 . "@src64/flow.l") +until (2098 . "@src64/flow.l") +up (597 . "@src64/main.l") +upp? (3228 . "@src64/sym.l") +uppc (3292 . "@src64/sym.l") +use (1586 . "@src64/flow.l") +usec (2211 . "@src64/main.l") +val (1461 . "@src64/sym.l") +version (2584 . "@src64/main.l") +wait (2973 . "@src64/io.l") +when (1897 . "@src64/flow.l") +while (2074 . "@src64/flow.l") +wipe (3088 . "@src64/sym.l") +with (1343 . "@src64/flow.l") +wr (4958 . "@src64/io.l") +xchg (1536 . "@src64/sym.l") +xor (1714 . "@src64/flow.l") +x| (2539 . "@src64/big.l") +yoke (1187 . "@src64/subr.l") +zap (1063 . "@src64/sym.l") +zero (1629 . "@src64/sym.l") +| (2499 . "@src64/big.l") diff --git a/lib/term.l b/lib/term.l @@ -0,0 +1,47 @@ +# 16mar10abu +# (c) Software Lab. Alexander Burger + +### Key codes ### +(setq + *XtF1 (in '("tput" "kf1") (line T)) + *XtF2 (in '("tput" "kf2") (line T)) + *XtF3 (in '("tput" "kf3") (line T)) + *XtF4 (in '("tput" "kf4") (line T)) + *XtF5 (in '("tput" "kf5") (line T)) + *XtF6 (in '("tput" "kf6") (line T)) + *XtF7 (in '("tput" "kf7") (line T)) + *XtF8 (in '("tput" "kf8") (line T)) + *XtF9 (in '("tput" "kf9") (line T)) + *XtF10 (in '("tput" "kf10") (line T)) + *XtF11 (in '("tput" "kf11") (line T)) + *XtF12 (in '("tput" "kf12") (line T)) + + *XtMenu "^[[29~" #? + + *XtIns (in '("tput" "kich1") (line T)) + *XtDel (in '("tput" "kdch1") (line T)) + + *XtPgUp (in '("tput" "kpp") (line T)) + *XtPgDn (in '("tput" "knp") (line T)) + *XtUp (in '("tput" "cuu1") (line T)) + *XtDown "^[[B" #? + *XtRight (in '("tput" "cuf1") (line T)) + *XtLeft "^[[D" #? + *XtEnd "^[[F" #? + *XtHome (in '("tput" "home") (line T)) ) + + +### Cursor movements ### +(de xtUp (N) + (do N (prin *XtUp)) ) + +(de xtDown (N) + (do N (prin *XtDown)) ) + +(de xtRight (N) + (do N (prin *XtRight)) ) + +(de xtLeft (N) + (do N (prin *XtLeft)) ) + +# vi:et:ts=3:sw=3 diff --git a/lib/test.l b/lib/test.l @@ -0,0 +1,31 @@ +# 09sep09abu +# (c) Software Lab. Alexander Burger + +### Unit Tests ### +# $(/bin/pwd)/p lib/test.l -bye + +(load "dbg.l") + +(test T (pool (tmp "db"))) + +(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/misc.l") + +(load "test/lib/lint.l") + +(msg 'OK) + +# vi:et:ts=3:sw=3 diff --git a/lib/tex.l b/lib/tex.l @@ -0,0 +1,164 @@ +# 03jun07abu +# (c) Software Lab. Alexander Burger + +# Convert to PDF document +(de dviPdf (Doc) + (prog1 + (tmp Doc ".pdf") + (call "/usr/bin/dvips" "-q" (pack Doc ".dvi")) + (call "ps2pdf" (pack Doc ".ps") @) + (call 'rm "-f" + (pack Doc ".tex") + (pack Doc ".dvi") + (pack Doc ".ps") ) ) ) + +# Tex Formatter +(de texFmt (S) + (_tex S) + (prinl) ) + +(de tex (S . @) + (prin "\\" S "{") + (_tex (next)) + (while (args) + (when (next) + (prin "\\\\") + (_tex (arg)) ) ) + (prinl "}") ) + +(de texl (S Lst) + (prin "\\" S "{") + (_tex (pop 'Lst)) + (while Lst + (when (pop 'Lst) + (prin "\\\\") + (_tex @) ) ) + (prinl "}") ) + +(de _tex (X) + (when X + (ifn (sym? X) + (prin X) + (let N 0 + (for (L (chop X) L (cdr L)) + (cond + ((and (= "!" (car L)) (= "{" (cadr L))) + (prin "\\textbf{") + (inc 'N) + (pop 'L) ) + ((and (= "/" (car L)) (= "{" (cadr L))) + (prin "\\textit{") + (inc 'N) + (pop 'L) ) + ((and (= "_" (car L)) (= "{" (cadr L))) + (prin "\\underline{") + (inc 'N) + (pop 'L) ) + ((and (= "\^" (car L)) (= "{" (cadr L))) + (prin "\^{") + (inc 'N) + (pop 'L) ) + ((= `(char 8364) (car L)) + (prin "\\EUR") ) + ((sub? (car L) "#$%&_{") + (prin "\\" (car L)) ) + ((sub? (car L) "<²>") + (prin "$" (car L) "$") ) + (T + (prin + (case (car L) + ("\"" "\\char34") + ("\\" "$\\backslash$") + ("\^" "\\char94") + ("}" (if (=0 N) "\\}" (dec 'N) "}")) + ("~" "\\char126") + (T (car L)) ) ) ) ) ) + (do N (prin "}")) ) ) ) ) + + +### TeX Document ### +(de document (Doc Cls Typ Use . Prg) + (out (list "bin/lat1" (pack Doc ".tex")) + (prinl "\\documentclass[" Cls "]{" Typ "}") + (while Use + (if (atom (car Use)) + (prinl "\\usepackage{" (pop 'Use) "}") + (prinl "\\usepackage[" (caar Use) "]{" (cdr (pop 'Use)) "}") ) ) + (prinl "\\begin{document}") + (prEval Prg 2) + (prinl "\\end{document}") ) + (call 'sh "-c" + (pack "latex -interaction=batchmode " Doc ".tex >/dev/null") ) + (call 'rm (pack Doc ".aux") (pack Doc ".log")) ) + +(de \block (S . Prg) + (prinl "\\begin{" S "}") + (prEval Prg 2) + (prinl "\\end{" S "}") ) + + +### Tabular environment ### +(de \table (Fmt . Prg) + (prinl "\\begin{tabular}[c]{" Fmt "}") + (prEval Prg 2) + (prinl "\\end{tabular}") ) + +(de \carry () + (prinl "\\end{tabular}") + (prinl) + (prinl "\\begin{tabular}[c]{" "Fmt" "}") ) + +(de \head @ + (prin "\\textbf{" (next) "}") + (while (args) + (prin " & \\textbf{") + (_tex (next)) + (prin "}") ) + (prinl "\\\\") ) + +(de \row @ + (when (=0 (next)) + (next) + (prin "\\raggedleft ") ) + (ifn (=T (arg)) + (_tex (arg)) + (prin "\\textbf{") + (_tex (next)) + (prin "}") ) + (while (args) + (prin " & ") + (when (=0 (next)) + (next) + (prin "\\raggedleft ") ) + (ifn (=T (arg)) + (_tex (arg)) + (prin "\\textbf{") + (_tex (next)) + (prin "}") ) ) + (prinl "\\\\") ) + +(de \hline () + (prinl "\\hline") ) + +(de \cline (C1 C2) + (prinl "\\cline{" C1 "-" C2 "}") ) + + +### Letter Document Class ### +(de \letter (Lst . Prg) + (prin "\\begin{letter}{" (pop 'Lst)) + (while Lst + (when (pop 'Lst) + (prin "\\\\" @) ) ) + (prinl "}") + (prEval Prg 2) + (prinl "\\end{letter}") ) + +(de \signature (S) + (tex "signature" S) ) + +(de \opening (S) + (tex "opening" S) ) + +(de \closing (S) + (tex "closing" S) ) diff --git a/lib/too.l b/lib/too.l @@ -0,0 +1,487 @@ +# 16apr10abu +# (c) Software Lab. Alexander Burger + +### DB Garbage Collection ### +(de dbgc () + (markExt *DB) + (let Cnt 0 + (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) ) ) ) ) + (commit) + (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 (replace @S '/)))) + (get S (intern (pack @R))) ) + (inc 'Cnt) + (call 'rm (pack F)) ) + (wipe S) ) ) ) ) ) ) + (gt0 Cnt) ) ) + +(de markExt (S) + (unless (mark S T) + (markData (val S)) + (maps markData S) + (wipe S) ) ) + +(de markData (X) + (while (pair X) + (markData (pop 'X)) ) + (and (ext? X) (markExt X)) ) + + +### DB Mapping ### +(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 (pop '"X")) ) + (and (ext? "X") (_dbMap "X")) ) + + +### DB Check ### +(de dbCheck () + (and (lock) (quit 'lock @)) # Lock whole database + (for (F . N) (or *Dbs (2)) # Low-level integrity check + (unless (pair (println F N (dbck F T))) + (quit 'dbck @) ) ) + (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 + T ) + +(de dangling () + (make + (dbMap + '((This) + (and + (not (: T)) + (dangle This) + (link @) ) ) ) ) ) + +# Check Index References +(de dangle (Obj) + (and + (make + (for X (getl Obj) + (let V (or (atom X) (pop 'X)) + (with (meta Obj X) + (cond + ((isa '+Joint This) + (if (isa '+List This) + (when + (find + '((Y) + (if (atom (setq Y (get Y (: slot)))) + (n== Obj Y) + (not (memq Obj Y)) ) ) + V ) + (link X) ) + (let Y (get V (: slot)) + (if (atom Y) + (unless (== Obj Y) (link X)) + (unless (memq Obj Y) (link X)) ) ) ) ) + ((isa '+Key This) + (and + (<> Obj + (fetch + (tree X (: cls) (get Obj (: hook))) + V ) ) + (link X) ) ) + ((isa '+Ref This) + (let + (Tree (tree X (: cls) (get Obj (: hook))) + Aux (conc (mapcar '((S) (get Obj S)) (: aux)) Obj) ) + (if (isa '+List This) + (when + (find + '((Y) + (and + (or + (not (isa '+Fold This)) + (setq V (fold V)) ) + (<> Obj (fetch Tree (cons Y Aux))) ) ) + V ) + (link X) ) + (and + (or + (not (isa '+Fold This)) + (setq V (fold V)) ) + (<> Obj (fetch Tree (cons V Aux))) + (link X) ) ) ) ) + (T + (for B (: bag) + (cond + ((isa '+Key B) + (let N (index B (: bag)) + (with B + (when + (find + '((L) + (and + (get L N) + (<> Obj + (fetch + (tree (: var) (: cls) + (get + (if (sym? (: hook)) Obj L) + (: hook) ) ) + (get L N) ) ) ) ) + V ) + (link X) ) ) ) ) + ((isa '+Ref B) + (let N (index B (: bag)) + (with B + (when + (find + '((L) + (and + (get L N) + (<> Obj + (fetch + (tree (: var) (: cls) + (get + (if (sym? (: hook)) Obj L) + (: hook) ) ) + (cons (get L N) Obj) ) ) ) ) + V ) + (link X) ) ) ) ) ) ) ) ) ) ) ) ) + (cons Obj @) ) ) + + +### 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) + (recurse Lst (dec N)) + (recurse (cdr L) (- Len N)) ) ) ) ) ) + ((atom X) + (for Obj X + (re-index Obj Var) ) ) + (NIL + (for (Obj X Obj (seq Obj)) + (and (isa Cls Obj) (re-index Obj Var)) ) ) ) + (commit) ) ) + +(de re-index (Obj Var) + (unless (get Obj T) + (when (get Obj Var) + (rel> (meta Obj Var) Obj NIL + (put> (meta Obj Var) Obj NIL @) ) + (at (0 . 10000) (commit)) ) ) ) + + +### Database file management ### +(de dbfCheck () + (for "Cls" (all) + (when (and (= `(char "+") (char "Cls")) (isa '+Entity "Cls")) + (or + (get "Cls" 'Dbf) + (meta "Cls" 'Dbf) + (println 'dbfCheck "Cls") ) + (for Rel (getl "Cls") + (and + (pair Rel) + (or + (isa '+index (car Rel)) + (find '((B) (isa '+index B)) (; Rel 1 bag)) ) + (unless (; Rel 1 dbf) + (println 'dbfCheck (cdr Rel) "Cls") ) ) ) ) ) ) + +(de dbfMigrate (Pool Dbs) + (let + (scan + '(("Tree" "Fun") + (let "Node" (cdr (root "Tree")) + (if (ext? (fin (val "Node"))) + (recur ("Node") + (let? "X" (val "Node") + (recurse (cadr "X")) + ("Fun" (car "X") (cdddr "X")) + (recurse (caddr "X")) + (wipe "Node") ) ) + (recur ("Node") + (let? "X" (val "Node") + (recurse (car "X")) + (for "Y" (cdr "X") + ("Fun" (car "Y") (or (cddr "Y") (fin (car "Y")))) + (recurse (cadr "Y")) ) + (wipe "Node") ) ) ) ) ) + iter + '(("Tree" "Bar") + (scan "Tree" '(("K" "V") ("Bar" "V"))) ) + zapTree + '((Node) + (let? X (val Node) + (zapTree (cadr X)) + (zapTree (caddr X)) + (zap Node) ) ) ) + (dbfUpdate) ) + (let Lst + (make + (for (S *DB S (seq S)) + (link (cons S (val S) (getl S))) ) ) + (pool) + (call 'rm (pack Pool 1)) + (pool Pool Dbs) + (set *DB (cadar Lst)) + (putl *DB (cddr (pop 'Lst))) + (for L Lst + (let New (new T) + (set New (cadr L)) + (putl New (cddr L)) + (con L New) ) ) + (set *DB (dbfReloc0 (val *DB) Lst)) + (for X Lst + (set (cdr X) (dbfReloc0 (val (cdr X)) Lst)) + (putl (cdr X) (dbfReloc0 (getl (cdr X)) Lst)) ) + (commit) + (dbMap # Relocate base symbols + '((Obj) + (putl Obj (dbfReloc0 (getl Obj) Lst)) + (commit) ) + '((Base Root Var Cls Hook) + (when (asoq (cdr Root) Lst) + (con Root (cdr @)) + (touch Base) + (commit) ) ) ) ) ) + +(de dbfUpdate () + (dbMap # Move + '((Obj) + (let N (or (meta Obj 'Dbf 1) 1) + (unless (= N (car (id Obj T))) + (let New (new N) + (set New (val Obj)) + (putl New (getl Obj)) + (set Obj (cons T New)) ) + (commit) ) ) ) ) + (when *Blob + (for X + (make + (use (@S @R F S) + (let Pat (conc (chop *Blob) '(@S "." @R)) + (in (list 'find *Blob "-type" "f") + (while (setq F (line)) + (and + (match Pat F) + (setq S (extern (pack (replace @S '/)))) + (=T (car (pair (val S)))) + (link + (cons (pack F) (blob (cdr (val S)) @R)) ) ) ) ) ) ) ) + (and (dirname (cdr X)) (call 'mkdir "-p" @)) + (call 'mv (car X) (cdr X)) ) ) + (dbMap # Relocate + '((Obj) + (when (=T (car (pair (val Obj)))) + (setq Obj (cdr (val Obj))) ) + (when (isa '+Entity Obj) + (putl Obj (dbfReloc (getl Obj))) + (commit) ) ) + '((Base Root Var Cls Hook) + (if Var + (dbfRelocTree Base Root (tree Var Cls Hook) (get Cls Var 'dbf)) + (dbfRelocTree Base Root Base) ) ) ) + (dbgc) ) + +(de dbfReloc (X) + (cond + ((pair X) + (cons (dbfReloc (car X)) (dbfReloc (cdr X))) ) + ((and (ext? X) (=T (car (pair (val X))))) + (cdr (val X)) ) + (T X) ) ) + +(de dbfReloc0 (X Lst) + (cond + ((pair X) + (cons (dbfReloc0 (car X) Lst) (dbfReloc0 (cdr X) Lst)) ) + ((asoq X Lst) (cdr @)) + (T X) ) ) + +(de dbfRelocTree (Base Root Tree Dbf) + (let? Lst (make (scan Tree '((K V) (link (cons K V))))) + (zapTree (cdr Root)) + (touch Base) + (set Root 0) + (con Root) + (commit) + (for X + (make + (for + (Lst (cons Lst) Lst + (mapcan + '((L) + (let (N (/ (inc (length L)) 2) X (nth L N)) + (link (car X)) + (make + (and (>= N 2) (link (head (dec N) L))) + (and (cdr X) (link @)) ) ) ) + Lst ) ) ) ) + (store Tree + (dbfReloc (car X)) + (dbfReloc (cdr X)) + Dbf ) ) + (commit) ) ) + + +### Dump Objects ### +(de dump CL + (let B 0 + (for ("Q" (goal CL) (asoq '@@ (prove "Q"))) + (let (Obj (cdr @) Lst) + (prin "(obj ") + (_dmp Obj) + (maps + '((X) + (unless (member X Lst) + (prinl) + (space 3) + (cond + ((pair X) + (printsp (cdr X)) + (_dmp (car X) T) ) + ((isa '+Blob (meta Obj X)) + (prin X " `(tmp " (inc 'B) ")") + (out (tmp B) + (in (blob Obj X) (echo)) ) ) + (T (print X T)) ) ) ) + Obj ) + (prinl " )") + Obj ) ) ) ) + +(de _dmp (Obj Flg) + (cond + ((pair Obj) + (prin "(") + (_dmp (pop 'Obj) T) + (while (pair Obj) + (space) + (_dmp (pop 'Obj) T) ) + (when Obj + (prin " . ") + (_dmp Obj T) ) + (prin ")") ) + ((ext? Obj) + (when Flg + (prin "`(obj ") ) + (prin "(") + (catch NIL + (maps + '((X) + (with (and (pair X) (meta Obj (cdr X))) + (when (isa '+Key This) + (or Flg (push 'Lst X)) + (printsp (type Obj) (: var)) + (when (: hook) + (_dmp (: hook) T) + (space) ) + (_dmp (car X) T) + (throw) ) ) ) + Obj ) + (print (type Obj)) + (maps + '((X) + (with (and (pair X) (meta Obj (cdr X))) + (when (isa '+Ref This) + (space) + (or Flg (push 'Lst X)) + (print (: var)) + (when (: hook) + (space) + (_dmp (: hook) T) ) + (space) + (_dmp (car X) T) ) ) ) + Obj ) ) + (when Flg + (prin ")") ) + (prin ")") ) + (T (print Obj)) ) ) + +`*Dbg +(noLint 'dbfMigrate 'iter) + +# vi:et:ts=3:sw=3 diff --git a/lib/xhtml.l b/lib/xhtml.l @@ -0,0 +1,669 @@ +# 20apr10abu +# (c) Software Lab. Alexander Burger + +# *JS *Style *Menu *Tab *ID + +(mapc allow '(*Menu *Tab *ID)) +(setq *Menu 0 *Tab 1) + +(de htPrin (Prg Ofs) + (default Ofs 1) + (for X Prg + (if (atom X) + (ht:Prin (eval X Ofs)) + (eval X Ofs) ) ) ) + +(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 "</" Nm '>) ) + +(de <tag> (Nm Attr . Prg) + (tag Nm Attr 2 Prg) ) + +(de style (X Prg) + (let *Style + (nond + (X *Style) + (*Style X) + ((pair X) + (cond + ((atom *Style) (pack *Style " " X)) + ((and (atom (car *Style)) (atom (cdr *Style))) + (list X *Style) ) + ((find atom *Style) + (replace *Style @ (pack @ " " X)) ) + (T (cons X *Style)) ) ) + ((or (pair (car X)) (pair (cdr X))) + (cond + ((atom *Style) (list *Style X)) + ((and (atom (car *Style)) (atom (cdr *Style))) + (if (= (car X) (car *Style)) + X + (list *Style X) ) ) + (T + (cons X (delete (assoc (car X) *Style) *Style)) ) ) ) + (NIL X) ) + (run Prg 2 '(*Style)) ) ) + +(de <style> ("X" . "Prg") + (style "X" "Prg") ) + +(de nonblank (Str) + (or Str `(pack (char 160) (char 160))) ) + + +### XHTML output ### +(de html (Upd Ttl Css Attr . Prg) + (httpHead NIL Upd) + (ht:Out *Chunked + ## (xml? T) + (prinl "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">") + (prinl + "<html xmlns=\"http://www.w3.org/1999/xhtml\" xml:lang=\"" + (or *Lang "en") + "\" lang=\"" + (or *Lang "en") + "\">" ) + (prinl "<head>") + (and Ttl (<tag> 'title NIL Ttl) (prinl)) + (and *Host *Port (prinl "<base href=\"" (baseHRef) "\"/>")) + (when Css + (if (atom Css) ("css" Css) (mapc "css" Css)) ) + (mapc javascript *JS) + (prinl "</head>") + (tag 'body Attr 2 Prg) + (prinl "</html>") ) ) + +(de "css" (Css) + (prinl "<link rel=\"stylesheet\" type=\"text/css\" href=\"" (srcUrl Css) "\"/>") ) + +(de javascript (JS . @) + (when *JS + (when JS + (prinl "<script type=\"text/javascript\" src=\"" (srcUrl JS) "\"></script>") ) + (when (rest) + (prinl "<script type=\"text/javascript\">" @ "</script>") ) ) ) + +(de <div> (Attr . Prg) + (tag 'div Attr 2 Prg) + (prinl) ) + +(de <span> (Attr . Prg) + (tag 'span Attr 2 Prg) ) + +(de <br> Prg + (htPrin Prg 2) + (prinl "<br/>") ) + +(de -- () + (prinl "<br/>") ) + +(de ---- () + (prinl "<br/><br/>") ) + +(de <hr> () + (prinl "<hr/>") ) + +(de <nbsp> (N) + (do (or N 1) (prin "&nbsp;")) ) + +(de <small> Prg + (tag 'small NIL 2 Prg) ) + +(de <big> Prg + (tag 'big NIL 2 Prg) ) + +(de <em> Prg + (tag 'em NIL 2 Prg) ) + +(de <strong> Prg + (tag 'strong NIL 2 Prg) ) + +(de <h1> (Attr . Prg) + (tag 'h1 Attr 2 Prg) + (prinl) ) + +(de <h2> (Attr . Prg) + (tag 'h2 Attr 2 Prg) + (prinl) ) + +(de <h3> (Attr . Prg) + (tag 'h3 Attr 2 Prg) + (prinl) ) + +(de <h4> (Attr . Prg) + (tag 'h4 Attr 2 Prg) + (prinl) ) + +(de <h5> (Attr . Prg) + (tag 'h5 Attr 2 Prg) + (prinl) ) + +(de <h6> (Attr . Prg) + (tag 'h6 Attr 2 Prg) + (prinl) ) + +(de <p> (Attr . Prg) + (tag 'p Attr 2 Prg) + (prinl) ) + +(de <pre> (Attr . Prg) + (tag 'pre Attr 2 Prg) + (prinl) ) + +(de <ol> (Attr . Prg) + (tag 'ol Attr 2 Prg) + (prinl) ) + +(de <ul> (Attr . Prg) + (tag 'ul Attr 2 Prg) + (prinl) ) + +(de <li> (Attr . Prg) + (tag 'li Attr 2 Prg) + (prinl) ) + +(de <href> (Str Url) + (prin "<a href=\"" (sesId Url) "\"") + (and *Style (htStyle @)) + (prin '>) + (ht:Prin Str) + (prin "</a>") ) + +(de <img> (Src Alt Url DX DY) + (and Url (prin "<a href=\"" (sesId Url) "\">")) + (prin "<img src=\"" (sesId Src) "\"") + (when Alt + (prin " alt=\"") + (ht:Prin Alt) + (prin "\"") ) + (and DX (prin " width=\"" DX "\"")) + (and DY (prin " height=\"" DY "\"")) + (and *Style (htStyle @)) + (prin "/>") + (and Url (prin "</a>")) ) + +(de <this> (Var Val . Prg) + (prin "<a href=\"" (sesId *Url) '? Var '= (ht:Fmt Val) "\"") + (and *Style (htStyle @)) + (prin '>) + (htPrin Prg 2) + (prin "</a>") ) + +(de <table> (Attr Ttl "Head" . Prg) + (tag 'table Attr 1 + (quote + (and Ttl (tag 'caption NIL 1 Ttl)) + (when (find cdr "Head") + (tag 'tr NIL 1 + (quote + (for X "Head" + (tag 'th (car X) 2 (cdr X)) ) ) ) ) + (htPrin Prg 2) ) ) + (prinl) ) + +(de <row> (Cls . Prg) + (tag 'tr NIL 1 + (quote + (let (L Prg H (up "Head")) + (while L + (let (X (pop 'L) C (pack Cls (and Cls (caar H) " ") (caar H)) N 1) + (while (== '- (car L)) + (inc 'N) + (pop 'L) + (pop 'H) ) + (setq C + (if2 C (> N 1) + (list C (cons 'colspan N)) + C + (cons 'colspan N) ) ) + (tag 'td + (if (== 'align (car (pop 'H))) + (list '(align . right) C) + C ) + 1 + (quote + (if (atom X) + (ht:Prin (eval X 1)) + (eval X 1) ) ) ) ) ) ) ) ) ) + +(de <th> (Attr . Prg) + (tag 'th Attr 2 Prg) ) + +(de <tr> (Attr . Prg) + (tag 'tr Attr 2 Prg) ) + +(de <td> (Attr . Prg) + (tag 'td Attr 2 Prg) ) + +(de <grid> (X . Lst) + (tag 'table 'grid 1 + (quote + (while Lst + (tag 'tr NIL 1 + (quote + (use X + (let L (and (sym? X) (chop X)) + (do (or (num? X) (length X)) + (tag 'td + (cond + ((pair X) (pop 'X)) + ((= "." (pop 'L)) 'align) ) + 1 + (quote + (if (atom (car Lst)) + (ht:Prin (eval (pop 'Lst) 1)) + (eval (pop 'Lst) 1) ) ) ) ) ) ) ) ) ) ) ) + (prinl) ) + +(de <spread> Lst + (<table> '(width . "100%") NIL '((norm) (align)) + (<row> NIL + (eval (car Lst) 1) + (run (cdr Lst) 1) ) ) ) + +(de tip ("Str" "Txt") + (<span> (cons 'title "Str") "Txt") ) + +(de <tip> ("Str" . "Prg") + (style (cons 'title "Str") "Prg") ) + + +# Menus +(de urlMT (Url Menu Tab Id Str) + (pack Url '? "*Menu=+" Menu "&*Tab=+" Tab "&*ID=" (ht:Fmt Id) Str) ) + +(de <menu> Lst + (let (M 1 N 1 E 2 U) + (recur (Lst N E) + (<ul> NIL + (for L Lst + (nond + ((car L) (<li> NIL (htPrin (cdr L) 2))) + ((=T (car L)) + (if (setq U (eval (cadr L) E)) + (<li> (pack (if (= U *Url) 'act 'cmd) N) + (<tip> "-->" + (<href> (eval (car L) E) + (urlMT U *Menu (if (= U *Url) *Tab 1) + (eval (caddr L)) + (eval (cadddr L)) ) ) ) ) + (<li> (pack 'cmd N) + (ht:Prin (eval (car L) E)) ) ) ) + ((bit? M *Menu) + (<li> (pack 'sub N) + (<tip> ,"Open submenu" + (<href> + (eval (cadr L) E) + (urlMT *Url (| M *Menu) *Tab *ID) ) ) ) + (setq M (>> -1 M)) + (recur (L) + (for X (cddr L) + (when (=T (car X)) + (recurse X) + (setq M (>> -1 M)) ) ) ) ) + (NIL + (<li> (pack 'top N) + (<tip> ,"Close submenu" + (<href> + (eval (cadr L) E) + (urlMT *Url (x| M *Menu) *Tab *ID) ) ) + (setq M (>> -1 M)) + (recurse (cddr L) (inc N) (inc E)) ) ) ) ) ) ) ) ) + +# Update link +(de updLink () + (<tip> ,"Update" + (<span> 'step (<href> "@" (urlMT *Url *Menu *Tab *ID))) ) ) + +# Tabs +(de <tab> Lst + (<table> 'tab NIL NIL + (for (N . L) Lst + (if (= N *Tab) + (<td> 'top (ht:Prin (eval (car L) 1))) + (<td> 'sub + (<href> (eval (car L) 1) (urlMT *Url *Menu N *ID)) ) ) ) ) + (htPrin (get Lst *Tab -1) 2) ) + + +### DB Linkage ### +(de mkUrl (Lst) + (pack (pop 'Lst) '? + (make + (while Lst + (and + (sym? (car Lst)) + (= `(char '*) (char (car Lst))) + (link (pop 'Lst) '=) ) + (link (ht:Fmt (pop 'Lst))) + (and Lst (link '&)) ) ) ) ) + +(de <$> (Str Obj Msg Tab) + (cond + ((not Obj) (ht:Prin Str)) + ((=T Obj) (<href> Str (pack Msg Str))) + ((send (or Msg 'url>) Obj (or Tab 1)) + (<href> Str (mkUrl @)) ) + (T (ht:Prin Str)) ) ) + +# Links to previous and next object +(de stepBtn (Var Cls Hook Msg) + (default Msg 'url>) + (<span> 'step + (use (Rel S1 S2) + (if (isa '+Joint (setq Rel (meta *ID Var))) + (let Lst (get *ID Var (; Rel slot)) + (setq + S2 (lit (cadr (memq *ID Lst))) + S1 (lit (car (seek '((L) (== *ID (cadr L))) Lst))) ) ) + (let + (K + (cond + ((isa '+Key Rel) + (get *ID Var) ) + ((isa '+Fold Rel) + (cons (fold (get *ID Var)) *ID) ) + (T + (cons + (get *ID Var) + (conc + (mapcar '((S) (get *ID S)) (; Rel aux)) + *ID ) ) ) ) + Q1 (init (tree Var Cls Hook) K NIL) + Q2 (init (tree Var Cls Hook) K T) ) + (unless (get *ID T) + (step Q1 T) + (step Q2 T) ) + (setq + S1 (list 'step (lit Q1) T) + S2 (list 'step (lit Q2) T) ) ) ) + (if (and (eval S1) (send Msg @ *Tab)) + (<tip> ,"Next object of the same type" + (<href> "<<<" (mkUrl @)) ) + (prin "&lt;&lt;&lt;") ) + (prin "&nbsp;--&nbsp;") + (if (and (eval S2) (send Msg @ *Tab)) + (<tip> ,"Next object of the same type" + (<href> ">>>" (mkUrl @)) ) + (prin "&gt;&gt;&gt;") ) ) ) ) + +# Character Separated Values +(off "*CSV") + +(de csv ("Nm" . "Prg") + (call 'rm "-f" (tmp "Nm" ".csv")) + (let "*CSV" (pack "+" (tmp "Nm" ".csv")) + (run "Prg") ) + (<href> "CSV" (tmp "Nm" ".csv")) ) + +(de <0> @ + (when "*CSV" + (out @ + (prin (next)) + (while (args) + (prin "^I" (next)) ) + (prinl "^M") ) ) ) + +(de <%> @ + (prog1 (pass pack) + (ht:Prin @) + (prinl "<br/>") + (<0> @) ) ) + +(de <!> ("Lst") + (when "*CSV" + (out @ + (prin (eval (cadar "Lst"))) + (for "S" (cdr "Lst") + (prin "^I" (eval (cadr "S"))) ) + (prinl "^M") ) ) + "Lst" ) + +(de <+> (Str Obj Msg Tab) + (<$> Str Obj Msg Tab) + (and "*CSV" (out @ (prin Str "^I"))) ) + +(de <-> (Str Obj Msg Tab) + (<$> Str Obj Msg Tab) + (<0> Str) ) + + +# Interactive tree +(de <tree> ("Url" "Path" "Tree" "Able?" "Excl?" "Expand" "Print") + (default "Print" 'ht:Prin) + (let ("Pos" "Tree" "F" (pop '"Path") "A" 0) + (when "Path" + (loop + (and "F" + (not (cdr "Path")) + (map + '((L) + (when (pair (car L)) (set L (caar L))) ) + "Pos" ) ) + (T (atom (car (setq "Pos" (nth "Pos" (abs (pop '"Path"))))))) + (NIL "Path") + (setq "Pos" (cdar "Pos")) ) + (set "Pos" + (if (atom (car "Pos")) + (cons (car "Pos") ("Expand" (car "Pos"))) + (caar "Pos") ) ) ) + (setq "Pos" (car "Pos")) + ("tree" "Tree") + "Tree" ) ) + +(de "tree" ("Tree" "Lst") + (prinl "<ul>") + (for ("N" . "X") "Tree" + (prin "<li><a id=\"T" (inc '"A") "\"></a>") + (cond + ((pair "X") + (let "L" (append "Lst" (cons "N")) + (<href> (if (== "X" "Pos") "<+>" "[+]") + (pack "Url" + '? (ht:Fmt (cons NIL "L")) + "#T" (max 1 (- "A" 12)) ) ) + (space) + ("Print" (car "X")) + (and (cdr "X") ("tree" @ "L")) ) ) + (("Able?" "X") + (let "L" (append "Lst" (cons (- "N"))) + (<href> (if (== "X" "Pos") "< >" "[ ]") + (pack "Url" + "?" (ht:Fmt (cons ("Excl?" "X") "L")) + "#T" (max 1 (- "A" 12)) ) ) + (space) + ("Print" "X") ) ) + (T ("Print" "X")) ) + (prin "</li>") ) + (prinl "</ul>") ) + + +### HTML form ### +(de <post> (Attr Url . Prg) + (prin + "<form enctype=\"multipart/form-data\" action=\"" + (sesId Url) + (and *JS "\" onkeypress=\"formKey(event)\" onsubmit=\"return doPost(this)") + "\" method=\"post\">" ) + (tag 'fieldset Attr 2 Prg) + (prinl "</form>") ) + +(de htmlVar ("Var") + (prin "name=\"") + (if (pair "Var") + (prin (car "Var") ":" (cdr "Var") ":") + (prin "Var") ) + (prin "\"") ) + +(de htmlVal ("Var") + (if (pair "Var") + (cdr (assoc (cdr "Var") (val (car "Var")))) + (val "Var") ) ) + +(de <label> (Attr . Prg) + (tag 'label Attr 2 Prg) ) + +(de <field> (N "Var" Max Flg) + (prin "<input type=\"text\" ") + (htmlVar "Var") + (prin " value=\"") + (ht:Prin (htmlVal "Var")) + (prin "\" size=\"") + (if (lt0 N) + (prin (- N) "\" style=\"text-align: right;\"") + (prin N "\"") ) + (and Max (prin " maxlength=\"" Max "\"")) + (and *JS (prin " onchange=\"return fldChg(this)\"")) + (dfltCss "field") + (and Flg (prin " disabled=\"disabled\"")) + (prinl "/>") ) + +(de <hidden> ("Var" Val) + (prin "<input type=\"hidden\" ") + (htmlVar "Var") + (prin " value=\"") + (ht:Prin Val) + (prinl "\"/>") ) + +(de <passwd> (N "Var" Max Flg) + (prin "<input type=\"password\" ") + (htmlVar "Var") + (prin " value=\"") + (ht:Prin (htmlVal "Var")) + (prin "\" size=\"" N "\"") + (and Max (prin " maxlength=\"" Max "\"")) + (and *JS (prin " onchange=\"return fldChg(this)\"")) + (dfltCss "passwd") + (and Flg (prin " disabled=\"disabled\"")) + (prinl "/>") ) + +(de <upload> (N "Var" Flg) + (prin "<input type=\"file\" ") + (htmlVar "Var") + (prin " value=\"") + (ht:Prin (htmlVal "Var")) + (prin "\" size=\"" N "\"") + (and *JS (prin " onchange=\"return fldChg(this)\"")) + (dfltCss "upload") + (and Flg (prin " disabled=\"disabled\"")) + (prinl "/>") ) + +(de <area> (Cols Rows "Var" Flg) + (prin "<textarea ") + (htmlVar "Var") + (prin " cols=\"" Cols "\" rows=\"" Rows "\" wrap=\"off\"") + (and *JS (prin " onchange=\"return fldChg(this)\"")) + (dfltCss "area") + (and Flg (prin " disabled=\"disabled\"")) + (prin '>) + (ht:Prin (htmlVal "Var")) + (prinl "</textarea>") ) + +(de <select> (Lst "Var" Flg) + (prin "<select ") + (htmlVar "Var") + (and *JS (prin " onchange=\"return fldChg(this)\"")) + (dfltCss "select") + (prin '>) + (for "X" Lst + (let "V" (if (atom "X") "X" (car "X")) + (prin + "<option" + (and (pair "X") (pack " title=\"" (cdr "X") "\"")) + (cond + ((= "V" (htmlVal "Var")) " selected=\"selected\"") + (Flg " disabled=\"disabled\"") ) + '> ) + (ht:Prin "V") ) + (prin "</option>") ) + (prinl "</select>") ) + +(de <check> ("Var" Flg) + (let Val (htmlVal "Var") + (prin "<input type=\"hidden\" ") + (htmlVar "Var") + (prin " value=\"" (and Flg Val T) "\">") + (prin "<input type=\"checkbox\" ") + (htmlVar "Var") + (prin " value=\"T\"" (and Val " checked=\"checked\"")) + (and *JS (prin " onchange=\"return fldChg(this)\"")) + (dfltCss "check") + (and Flg (prin " disabled=\"disabled\"")) + (prinl "/>") ) ) + +(de <radio> ("Var" Val Flg) + (prin "<input type=\"radio\" ") + (htmlVar "Var") + (prin " value=\"") + (ht:Prin Val) + (prin "\"" (and (= Val (htmlVal "Var")) " checked=\"checked\"")) + (and *JS (prin " onchange=\"return fldChg(this)\"")) + (dfltCss "radio") + (and Flg (prin " disabled=\"disabled\"")) + (prinl "/>") ) + +(de <submit> (S "Var" Flg JS) + (prin "<input type=\"submit\"") + (and "Var" (space) (htmlVar "Var")) + (prin " value=\"") + (ht:Prin S) + (prin "\"") + (when *JS + (prin " onmousedown=\"inBtn(1)\" onblur=\"inBtn(0)\"") + (and JS (prin " onclick=\"return doBtn(this)\"")) ) + (dfltCss "submit") + (and Flg (prin " disabled=\"disabled\"")) + (prinl "/>") ) + +(de <image> (Src "Var" Flg JS) + (prin "<input type=\"image\"") + (and "Var" (space) (htmlVar "Var")) + (prin " src=\"" (sesId Src) "\"") + (when *JS + (prin " onmousedown=\"inBtn(1)\" onblur=\"inBtn(0)\"") + (and JS (prin " onclick=\"return doBtn(this)\"")) ) + (dfltCss "image") + (and Flg (prin " disabled=\"disabled\"")) + (prinl "/>") ) + +(de <reset> (S Flg) + (prin "<input type=\"reset\" value=\"") + (ht:Prin S) + (prin "\"") + (dfltCss "reset") + (and Flg (prin " disabled=\"disabled\"")) + (prinl "/>") ) + +# vi:et:ts=3:sw=3 diff --git a/lib/xm.l b/lib/xm.l @@ -0,0 +1,115 @@ +# 02jan09abu +# (c) Software Lab. Alexander Burger + +# Check or write header +(de xml? (Flg) + (if Flg + (prinl "<?xml version=\"1.0\" encoding=\"utf-8\"?>") + (skip) + (prog1 + (head '("<" "?" "x" "m" "l") (till ">")) + (char) ) ) ) + +# Generate/Parse XML data +(de xml (Lst N) + (if Lst + (let Tag (pop 'Lst) + (space (default N 0)) + (prin "<" Tag) + (for X (pop 'Lst) + (prin " " (car X) "=\"") + (escXml (cdr X)) + (prin "\"") ) + (nond + (Lst (prinl "/>")) + ((or (cdr Lst) (pair (car Lst))) + (prin ">") + (escXml (car Lst)) + (prinl "</" Tag ">") ) + (NIL + (prinl ">") + (for X Lst + (if (pair X) + (xml X (+ 3 N)) + (space (+ 3 N)) + (escXml X) + (prinl) ) ) + (space N) + (prinl "</" Tag ">") ) ) ) + (skip) + (unless (= "<" (char)) + (quit "Bad XML") ) + (_xml (till " /<>" T)) ) ) + +(de _xml (Tok) + (use X + (make + (link (intern Tok)) + (let L + (make + (loop + (NIL (skip) (quit "XML parse error")) + (T (member @ '`(chop "/>"))) + (NIL (setq X (intern (till "=" T)))) + (char) + (unless (= "\"" (char)) + (quit "XML parse error" X) ) + (link (cons X (pack (xmlEsc (till "\""))))) + (char) ) ) + (if (= "/" (char)) + (prog (char) (and L (link L))) + (link L) + (loop + (NIL (skip) (quit "XML parse error" Tok)) + (T (and (= "<" (setq X (char))) (= "/" (peek))) + (char) + (unless (= Tok (till " /<>" T)) + (quit "Unbalanced XML" Tok) ) + (char) ) + (if (= "<" X) + (and (_xml (till " /<>" T)) (link @)) + (link + (pack (xmlEsc (trim (cons X (till "^J<"))))) ) ) ) ) ) ) ) ) + +(de xmlEsc (L) + (use (@A @X @Z) + (make + (while L + (ifn (match '("&" @X ";" @Z) L) + (link (pop 'L)) + (link + (cond + ((= @X '`(chop "quot")) "\"") + ((= @X '`(chop "amp")) "&") + ((= @X '`(chop "lt")) "<") + ((= @X '`(chop "gt")) ">") + ((= @X '`(chop "apos")) "'") + ((= "#" (car @X)) + (char + (if (= "x" (cadr @X)) + (hex (cddr @X)) + (format (pack (cdr @X))) ) ) ) + (T @X) ) ) + (setq L @Z) ) ) ) ) ) + +(de escXml (X) + (for C (chop X) + (if (member C '`(chop "\"&<")) + (prin "&#" (char C) ";") + (prin C) ) ) ) + + +# Access functions +(de body (Lst . @) + (while (and (setq Lst (cddr Lst)) (args)) + (setq Lst (assoc (next) Lst)) ) + Lst ) + +(de attr (Lst Key . @) + (while (args) + (setq + Lst (assoc Key (cddr Lst)) + Key (next) ) ) + (cdr (assoc Key (cadr Lst))) ) + +# vi:et:ts=3:sw=3 diff --git a/lib/xml.l b/lib/xml.l @@ -0,0 +1,286 @@ +# 03jan09abu +# 21jan09 Tomas Hlavaty <kvietaag@seznam.cz> + +# Check or write header +(de xml? (Flg) + (if Flg + (prinl "<?xml version=\"1.0\" encoding=\"utf-8\"?>") + (skip) + (prog1 + (head '("<" "?" "x" "m" "l") (till ">")) + (char) ) ) ) + +# Generate/Parse XML data +# expects well formed XML +# encoding by picolisp (utf8 "only", no utf16 etc.) +# trim whitespace except in cdata +# ignore <? <!-- <!DOCTYPE +# non-builtin entities as normal text: &ent; => ent +(de xml (Lst N) + (if Lst + (let (Nn NIL Nl NIL Pre NIL) + (when N + (do (abs N) + (push 'Nn (if (lt0 N) "^I" " ")) ) ) + (_xml_ Lst) ) + (_xml) ) ) + +(de _xml_ (Lst) + (let Tag (pop 'Lst) + (when Nl + (prinl) + (when Pre + (prin Pre) ) ) + (prin "<" Tag) + (for X (pop 'Lst) + (prin " " (car X) "=\"") + (escXml (cdr X)) + (prin "\"") ) + (ifn Lst + (prin "/>") + (prin ">") + (use Nlx + (let (Nl N + Pre (cons Pre Nn) ) + (for X Lst + (if (pair X) + (_xml_ X) + (off Nl) + (escXml X) ) ) + (setq Nlx Nl) ) + (when Nlx + (prinl) + (when Pre + (prin Pre) ) ) ) + (prin "</" Tag ">") ) ) ) + +(de _xml (In Char) + (unless Char + (skip) + (unless (= "<" (char)) + (quit "Bad XML") ) ) + (case (peek) + ("?" + (from "?>") + (unless In (_xml In)) ) + ("!" + (char) + (case (peek) + ("-" + (ifn (= "-" (char) (char)) + (quit "XML comment expected") + (from "-->") + (unless In (_xml In)) ) ) + ("D" + (if (find '((C) (<> C (char))) '`(chop "DOCTYPE")) + (quit "XML DOCTYPE expected") + (when (= "[" (from "[" ">")) + (use X + (loop + (T (= "]" (setq X (from "]" "\"" "'" "<!--")))) + (case X + ("\"" (from "\"")) + ("'" (from "'")) + ("<!--" (from "-->")) + (NIL (quit "Unbalanced XML DOCTYPE")) ) ) ) + (from ">") ) + (unless In (_xml In)) ) ) + ("[" + (if (find '((C) (<> C (char))) '`(chop "[CDATA[")) + (quit "XML CDATA expected") + (pack + (head -3 + (make + (loop + (NIL (link (char)) (quit "Unbalanced XML CDATA")) + (T (= '`(chop "]]>") (tail 3 (made)))) ) ) ) ) ) ) + (T (quit "Unhandled XML tag")) ) ) + (T + (let Tok (till " ^I^M^J/>" T) + (use X + (make + (link (intern (pack Tok))) + (let L + (make + (loop + (NIL (skip) (quit "Unexpected end of XML" Tok)) + (T (member @ '("/" ">"))) + (NIL (setq X (intern (pack (trim (till "=")))))) + (char) + (skip) + (let C (char) + (unless (member C '("\"" "'")) + (quit "XML attribute quote expected" X) ) + (link (cons X (pack (xmlEsc (till C))))) ) + (char) ) ) + (if (= "/" (char)) + (prog (char) (and L (link L))) + (link L) + (loop + (NIL (skip) (quit "Unexpected end of XML" Tok)) + (T (and (= "<" (setq X (char))) (= "/" (peek))) + (char) + (unless (= Tok (till " ^I^M^J/>" T)) + (quit "Unbalanced XML" Tok) ) + (skip) + (char) ) + (if (= "<" X) + (when (_xml T "<") + (link @) ) + (link + (pack (xmlEsc (trim (cons X (till "^M^J<"))))) ) ) ) ) ) ) ) ) ) ) ) + +(de xmlEsc (L) + (use (@X @Z) + (make + (while L + (ifn (match '("&" @X ";" @Z) L) + (link (pop 'L)) + (link + (cond + ((= @X '`(chop "quot")) "\"") + ((= @X '`(chop "amp")) "&") + ((= @X '`(chop "lt")) "<") + ((= @X '`(chop "gt")) ">") + ((= @X '`(chop "apos")) "'") + ((= "#" (car @X)) + (char + (if (= "x" (cadr @X)) + (hex (cddr @X)) + (format (pack (cdr @X))) ) ) ) + (T @X) ) ) + (setq L @Z) ) ) ) ) ) + +(de escXml (X) + (for C (chop X) + (prin (case C + ("\"" "&quot;") + ("&" "&amp;") + ("<" "&lt;") + (">" "&gt;") + (T C) ) ) ) ) + + +# Simple XML string +(de xml$ (Lst) + (pack + (make + (recur (Lst) + (let Tag (pop 'Lst) + (link "<" Tag) + (for X (pop 'Lst) + (link " " (car X) "=\"" (cdr X) "\"") ) + (ifn Lst + (link "/>") + (link ">") + (for X Lst + (if (pair X) + (recurse X (+ 3 N)) + (link X) ) ) + (link "</" Tag ">") ) ) ) ) ) ) + + +# Access functions +(de body (Lst . @) + (while (and (setq Lst (cddr Lst)) (args)) + (setq Lst (assoc (next) Lst)) ) + Lst ) + +(de attr (Lst Key . @) + (while (args) + (setq + Lst (assoc Key (cddr Lst)) + Key (next) ) ) + (cdr (assoc Key (cadr Lst))) ) + +# <xml> output +(de "xmlL" Lst + (push '"Xml" + (make + (link (pop 'Lst)) + (let Att (make + (while (and Lst (car Lst) (atom (car Lst))) + (let K (pop 'Lst) + (if (=T K) + (for X (eval (pop 'Lst) 1) + (if (=T (car X)) + (link (cons (cdr X) NIL)) + (when (cdr X) + (link X) ) ) ) + (when (eval (pop 'Lst) 1) + (link (cons K @)) ) ) ) ) ) + (let "Xml" NIL + (xrun Lst) + (ifn "Xml" + (when Att + (link Att) ) + (link Att) + (chain (flip "Xml")) ) ) ) ) ) ) + +(de "xmlO" Lst + (let Tag (pop 'Lst) + (when "Nl" + (prinl) + (when "Pre" + (prin "Pre") ) ) + (prin "<" Tag) + (while (and Lst (car Lst) (atom (car Lst))) + (let K (pop 'Lst) + (if (=T K) + (for X (eval (pop 'Lst) 1) + (if (=T (car X)) + (prin " " (cdr X) "=\"\"") + (when (cdr X) + (prin " " (car X) "=\"") + (escXml (cdr X)) + (prin "\"") ) ) ) + (when (eval (pop 'Lst) 1) + (prin " " K "=\"") + (escXml @) + (prin "\"") ) ) ) ) + (ifn Lst + (prin "/>") + (prin ">") + (use Nl + (let ("Nl" "N" + "Pre" (cons "Pre" "Nn") ) + (xrun Lst) + (setq Nl "Nl") ) + (when Nl + (prinl) + (when "Pre" + (prin "Pre") ) ) ) + (prin "</" Tag ">") ) ) ) + +(de <xml> ("N" . Lst) + (if (=T "N") + (let (<xml> "xmlL" + xprin '(@ (push '"Xml" (pass pack))) + xrun '((Lst Ofs) + (default Ofs 2) + (for X Lst + (if (pair X) + (eval X Ofs '("Xml")) + (when (eval X Ofs '("Xml")) + (xprin @) ) ) ) ) + "Xml" NIL ) + (run Lst 1 '(<xml> xprin xrun "Xml")) + (car (flip "Xml")) ) + (let (<xml> "xmlO" + xprin '(@ (off "Nl") (mapc escXml (rest))) + xrun '((Lst Ofs) + (default Ofs 2) + (for X Lst + (if (pair X) + (eval X Ofs '("Nl" "Pre")) + (when (eval X Ofs '("Nl" "Pre")) + (xprin @) ) ) ) ) + "Nn" NIL + "Nl" NIL + "Pre" NIL ) + (when "N" + (do (abs "N") + (push '"Nn" (if (lt0 "N") "^I" " ")) ) ) + (run Lst 1 '(<xml> xprin xrun "N" "Nn" "Nl" "Pre")) ) ) ) + +# vi:et:ts=3:sw=3 diff --git a/lib/xmlrpc.l b/lib/xmlrpc.l @@ -0,0 +1,63 @@ +# 02jan09abu +# (c) Software Lab. Alexander Burger + +# (xmlrpc "localhost" 8080 "foo.bar" 'int 41 'string "abc" ..) +(de xmlrpc (Host Port Meth . @) + (let? Sock (connect Host Port) + (let Xml (tmp 'xmlrpc) + (out Xml + (xml? T) + (xml + (list 'methodCall NIL + (list 'methodName NIL Meth) + (make + (link 'params NIL) + (while (args) + (link + (list 'param NIL + (list 'value NIL (list (next) NIL (next))) ) ) ) ) ) ) ) + (prog1 + (out Sock + (prinl "POST /RPC2 HTTP/1.0^M") + (prinl "Host: " Host "^M") + (prinl "User-Agent: PicoLisp^M") + (prinl "Content-Type: text/xml^M") + (prinl "Accept-Charset: utf-8^M") + (prinl "Content-Length: " (car (info Xml)) "^M") + (prinl "^M") + (in Xml (echo)) + (flush) + (in Sock + (while (line)) + (let? L (and (xml?) (xml)) + (when (== 'methodResponse (car L)) + (xmlrpcValue + (car (body L 'params 'param 'value)) ) ) ) ) ) + (close Sock) ) ) ) ) + +(de xmlrpcKey (Str) + (or (format Str) (intern Str)) ) + +(de xmlrpcValue (Lst) + (let X (caddr Lst) + (case (car Lst) + (string X) + ((i4 int) (format X)) + (boolean (= "1" X)) + (double (format X *Scl)) + (array + (when (== 'data (car X)) + (mapcar + '((L) + (and (== 'value (car L)) (xmlrpcValue (caddr L))) ) + (cddr X) ) ) ) + (struct + (extract + '((L) + (when (== 'member (car L)) + (cons + (xmlrpcKey (caddr (assoc 'name L))) + (xmlrpcValue (caddr (assoc 'value L))) ) ) ) + (cddr Lst) ) ) ) ) ) + +# vi:et:ts=3:sw=3 diff --git a/loc/AR.l b/loc/AR.l @@ -0,0 +1,7 @@ +(setq + *Sep0 "," + *Sep3 "." + *CtryCode 54 + *DateFmt '(@D "-" @M "-" @Y) + *DayFmt '("Lunes" "Martes" "Miércoles" "Jueves" "Viernes" "Sábado" "Domingo") + *MonFmt '("Enero" "Febrero" "Marzo" "Abril" "Mayo" "Junio" "Julio" "Agosto" "Septiembre" "Octubre" "Noviembre" "Diciembre") ) diff --git a/loc/CH.l b/loc/CH.l @@ -0,0 +1,7 @@ +(setq + *Sep0 "." + *Sep3 "'" + *CtryCode 41 + *DateFmt '(@D "." @M "." @Y) + *DayFmt '("Montag" "Dienstag" "Mittwoch" "Donnerstag" "Freitag" "Samstag" "Sonntag") + *MonFmt '("Januar" "Februar" "März" "April" "Mai" "Juni" "Juli" "August" "September" "Oktober" "November" "Dezember") ) diff --git a/loc/DE.l b/loc/DE.l @@ -0,0 +1,7 @@ +(setq + *Sep0 "," + *Sep3 "." + *CtryCode 49 + *DateFmt '(@D "." @M "." @Y) + *DayFmt '("Montag" "Dienstag" "Mittwoch" "Donnerstag" "Freitag" "Samstag" "Sonntag") + *MonFmt '("Januar" "Februar" "März" "April" "Mai" "Juni" "Juli" "August" "September" "Oktober" "November" "Dezember") ) diff --git a/loc/ES.l b/loc/ES.l @@ -0,0 +1,7 @@ +(setq + *Sep0 "," + *Sep3 "." + *CtryCode 34 + *DateFmt '(@D "/" @M "/" @Y) + *DayFmt '("Lunes" "Martes" "Miércoles" "Jueves" "Viernes" "Sábado" "Domingo") + *MonFmt '("Enero" "Febrero" "Marzo" "Abril" "Mayo" "Junio" "Julio" "Agosto" "Setiembre" "Octubre" "Noviembre" "Diciembre") ) diff --git a/loc/JP.l b/loc/JP.l @@ -0,0 +1,7 @@ +(setq + *Sep0 "." + *Sep3 "," + *CtryCode 81 + *DateFmt '(@Y "/" @M "/" @D) + *DayFmt '("月曜日" "火曜日" "水曜日" "木曜日" "金曜日" "土曜日" "日曜日") + *MonFmt '("一月" "二月" "三月" "四月" "五月" "六月" "七月" "八月" "九月" "十月" "十一月" "十二月") ) diff --git a/loc/NIL.l b/loc/NIL.l @@ -0,0 +1,7 @@ +(setq # Default locale + *Sep0 "." + *Sep3 "," + *CtryCode NIL + *DateFmt '(@Y "-" @M "-" @D) + *DayFmt '("Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday" "Sunday") + *MonFmt '("January" "February" "March" "April" "May" "June" "July" "August" "September" "October" "November" "December") ) diff --git a/loc/NO.l b/loc/NO.l @@ -0,0 +1,7 @@ +(setq + *Sep0 "," + *Sep3 "." + *CtryCode 47 + *DateFmt '(@D "." @M "." @Y) + *DayFmt '("mandag" "tirsdag" "onsdag" "torsdag" "fredag" "lørdag" "søndag") + *MonFmt '("januar" "februar" "mars" "april" "mai" "juni" "juli" "august" "september" "oktober" "november" "desember") ) diff --git a/loc/RU.l b/loc/RU.l @@ -0,0 +1,7 @@ +(setq + *Sep0 "," + *Sep3 " " + *CtryCode 7 + *DateFmt '(@D "." @M "." @Y) + *DayFmt '("Понедельник" "Вторник" "Среда" "Четверг" "Пятница" "Суббота" "Воскресенье") + *MonFmt '("Январь" "Февраль" "Март" "Апрель" "Май" "Июнь" "Июль" "Август" "Сентябрь" "Октябрь" "Ноябрь" "Декабрь") ) diff --git a/loc/UK.l b/loc/UK.l @@ -0,0 +1,7 @@ +(setq + *Sep0 "." + *Sep3 "," + *CtryCode 44 + *DateFmt '(@D "/" @M "/" @Y) + *DayFmt '("Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday" "Sunday") + *MonFmt '("January" "February" "March" "April" "May" "June" "July" "August" "September" "October" "November" "December") ) diff --git a/loc/US.l b/loc/US.l @@ -0,0 +1,7 @@ +(setq + *Sep0 "." + *Sep3 "," + *CtryCode 1 + *DateFmt '(@M "/" @D "/" @Y) + *DayFmt '("Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday" "Sunday") + *MonFmt '("January" "February" "March" "April" "May" "June" "July" "August" "September" "October" "November" "December") ) diff --git a/loc/ar b/loc/ar @@ -0,0 +1 @@ +T "@loc/es" diff --git a/loc/ch b/loc/ch @@ -0,0 +1,4 @@ +# 10may08abu +# (c) Software Lab. Alexander Burger + +T "@loc/de" diff --git a/loc/de b/loc/de @@ -0,0 +1,77 @@ +# 22dec08abu +# (c) Software Lab. Alexander Burger + +"Language" "Sprache" + +# lib/db.l +"Boolean input expected" "Boolean-Type erwartet" +"Numeric input expected" "Zahleneingabe erforderlich" +"Symbolic type expected" "Symbol-Type erwartet" +"String type expected" "String-Type erwartet" +"Type error" "Typ-Fehler" +"Not unique" "Nicht eindeutig" +"Input required" "Eingabe erforderlich" + +# lib/form.l +"Cancel" "Abbruch" +"Yes" "Ja" +"No" "Nein" +"Select" "Auswahl" +"Delete row?" "Zeile löschen?" +"Show" "Anzeigen" +"Bad date format" "Falsches Datums-Format" +"Bad time format" "Falsches Uhrzeit-Format" +"Bad phone number format" "Falsches Telefonnummern-Format" +"male" "männlich" +"female" "weiblich" +"New" "Neu" +"Edit" "Bearbeiten" +"Save" "Speichern" +"Done" "Fertig" +"Currently edited by '@2' (@1)" "Zur Zeit von '@2' (@1) bearbeitet" +"Search" "Suchen" +"Reset" "Zurücksetzen" +"New/Copy" "Neu/Muster" +"Restore" "Wiederherstellen" +"Restore @1?" "@1 wiederherstellen?" +"Delete" "Löschen" +"Delete @1?" "@1 löschen?" +"Data not found" "Datensatz nicht gefunden" + +# General +"login" "anmelden" +"logout" "abmelden" +"' logged in" "' ist angemeldet" +"Name" "Name" +"Password" "Passwort" +"Permission denied" "Keine Berechtigung" +"Permissions" "Berechtigungen" +"Role" "Rolle" +"Roles" "Rollen" +"User" "Benutzer" +"Users" "Benutzer" + +# Tooltips +"Open submenu" "Untermenü öffnen" +"Close submenu" "Untermenü schließen" +"Next object of the same type" "Nächstes Objekt vom gleichen Typ" +"Find or create an object of the same type" "Ein Objekt vom gleichen Typ suchen oder neu anlegen" +"Choose a suitable value" "Einen passenden Wert auswählen" +"Adopt this value" "Diesen Wert übernehmen" +"Go to first line" "Zur ersten Zeile gehen" +"Scroll up one page" "Eine Seite nach oben scrollen" +"Scroll up one line" "Eine Zeile nach oben scrollen" +"Scroll down one line" "Eine Zeile nach unten scrollen" +"Scroll down one page" "Eine Seite nach unten scrollen" +"Go to last line" "Zur letzten Zeile gehen" +"Delete row" "Zeile löschen" +"Shift row up" "Zeile nach oben schieben" +"Clear all input fields" "Alle Eingabefelder löschen" +"Release exclusive write access for this object" "Exklusiven Schreibzugriff auf dieses Objekt freigeben" +"Gain exclusive write access for this object" "Exklusiven Schreibzugriff auf dieses Objekt erhalten" +"Start search" "Suche starten" +"Create new object" "Neues Objekt anlegen" +"Create a new copy of this object" "Eine neue Kopie dieses Objektes anlegen" +"Mark this object as \"not deleted\"" "Dieses Objekt als \"nicht gelöscht\" markieren" +"Mark this object as \"deleted\"" "Dieses Objekt als \"gelöscht\" markieren" +"Update" "Aktualisieren" diff --git a/loc/es b/loc/es @@ -0,0 +1,52 @@ +# 26aug09art +# Armadillo <tc.rucho@gmail.com> + +"Language" "Idioma" + +# lib/db.l +"Boolean input expected" "Se espera el ingreso de datos tipo buliano" +"Numeric input expected" "Se espera el ingreso de datos tipo numérico" +"Symbolic type expected" "Se esperan datos del tipo simbólico" +"String type expected" "Se esperan datos del tipo String" +"Type error" "Error de tipado" +"Not unique" "No único" +"Input required" "Se require ingreso de datos" + +# lib/form.l +"Cancel" "Cancelar" +"Yes" "Sí" +"No" "No" +"Select" "Seleccionar" +"Delete row?" "¿Borrar fila?" +"Show" "Mostrar" +"Bad date format" "El formato de la fecha no es válido" +"Bad time format" "El formato de la hora no es válido" +"Bad phone number format" "El formato del número telefónico no es válido" +"male" "hombre" +"female" "mujer" +"New" "Nuevo" +"Edit" "Editar" +"Save" "Guardar" +"Done" "Terminar" +"Currently edited by '@2' (@1)" "Actualmente editado por '@2' (@1)" +"Search" "Buscar" +"Reset" "Vaciar/Limpiar" +"New/Copy" "Nuevo/Copiar" +"Restore" "Restaurar" +"Restore @1?" "¿Restaurar @1?" +"Delete" "Borrar" +"Delete @1?" "¿Borrar @1?" +"Data not found" "No se encontraron datos" + +# General +"login" "Ingresar al Sistema" +"logout" "Salir del Sistema" +"' logged in" "' ingresó al sistema" +"Name" "Nombre" +"Password" "Contraseña" +"Permission denied" "Permiso denegado" +"Permissions" "Permisos" +"Role" "Rol" +"Roles" "Roles" +"User" "Usuario" +"Users" "Usuarios" diff --git a/loc/jp b/loc/jp @@ -0,0 +1,77 @@ +# 22dec08abu +# (c) Software Lab. Alexander Burger + +"Language" "言語" + +# lib/db.l +"Boolean input expected" "Booleanタイプが必要" +"Numeric input expected" "数値入力が必要" +"Symbolic type expected" "Symbolicタイプが必要" +"String type expected" "Stringタイプが必要" +"Type error" "タイプエラー" +"Not unique" "重複" +"Input required" "入力が必要" + +# lib/form.l +"Cancel" "キャンセル" +"Yes" "はい" +"No" "いいえ" +"Select" "選択" +"Delete row?" "行を消しますか?" +"Show" "表示" +"Bad date format" "日付が違います" +"Bad time format" "時刻が違います" +"Bad phone number format" "電話番号が違います" +"male" "男性" +"female" "女性" +"New" "作成" +"Edit" "編集" +"Save" "保存" +"Done" "終了" +"Currently edited by '@2' (@1)" "現在'@2'(@1)が編集中です" +"Search" "検索" +"Reset" "リセット" +"New/Copy" "作成/コピー" +"Restore" "もとへ戻す" +"Restore @1?" "@1もとへ戻しますか?" +"Delete" "消去" +"Delete @1?" "@1を消しますか?" +"Data not found" "データが見つかりません" + +# General +"login" "ログイン" +"logout" "ログアウト" +"' logged in" "' ログインしました" +"Name" "名前" +"Password" "パスワード" +"Permission denied" "認証できません" +"Permissions" "許可" +"Role" "役割" +"Roles" "役割" +"User" "ユーザー" +"Users" "ユーザー" + +# Tooltips +"Open submenu" "サブメニューを開く" +"Close submenu" "サブメニューを閉じる" +"Next object of the same type" "次の同じタイプへ" +"Find or create an object of the same type" "同じタイプを探す/新規" +"Choose a suitable value" "適したバリューを選ぶ" +"Adopt this value" "このバリューを採用する" +"Go to first line" "最初の列にいく" +"Scroll up one page" "一ページ上へスクロール" +"Scroll up one line" "一行上へスクロール" +"Scroll down one line" "一行下へスクロール" +"Scroll down one page" "一ページ下へスクロール" +"Go to last line" "最後の列にいく" +"Delete row" "行を消す" +"Shift row up" "行を上へ移す" +"Clear all input fields" "全ての入力フィールドを消す" +"Release exclusive write access for this object" "Release exclusive write access for this object" +"Gain exclusive write access for this object" "Gain exclusive write access for this object" +"Start search" "検索スタート" +"Create new object" "オブジェクトを新規" +"Create a new copy of this object" "このオブジェクトを新しくコピーする" +"Mark this object as \"not deleted\"" "このオブジェクトを消さない状態にする" +"Mark this object as \"deleted\"" "このオブジェクトを消された状態にする" +"Update" "更新" diff --git a/loc/no b/loc/no @@ -0,0 +1,77 @@ +# 13jan10jk +# Jon Kleiser, jon.kleiser@usit.uio.no + +"Language" "Språk" + +# lib/db.l +"Boolean input expected" "Boolsk verdi forventet" +"Numeric input expected" "Numerisk verdi forventet" +"Symbolic type expected" "Symbol-type forventet" +"String type expected" "Tekststreng forventet" +"Type error" "Type-feil" +"Not unique" "Ikke unik" +"Input required" "Input-data påkrevet" + +# lib/form.l +"Cancel" "Avbryt" +"Yes" "Ja" +"No" "Nei" +"Select" "Velg" +"Delete row?" "Slett rad?" +"Show" "Vis" +"Bad date format" "Ugyldig datoformat" +"Bad time format" "Ugyldig tidsformat" +"Bad phone number format" "Ugyldig telefonnummer-format" +"male" "mannlig" +"female" "kvinnelig" +"New" "Ny" +"Edit" "Rediger" +"Save" "Lagre" +"Done" "Ferdig" +"Currently edited by '@2' (@1)" "Redigeres nå av '@2' (@1)" +"Search" "Søk" +"Reset" "Tilbakestill" +"New/Copy" "Ny/Kopi" +"Restore" "Gjenopprett" +"Restore @1?" "Gjenopprette @1?" +"Delete" "Slett" +"Delete @1?" "Slett @1?" +"Data not found" "Data ble ikke funnet" + +# General +"login" "logg inn" +"logout" "logg ut" +"' logged in" "' er innlogget" +"Name" "Navn" +"Password" "Passord" +"Permission denied" "Ingen adgangsrett" +"Permissions" "Adgangsrettigheter" +"Role" "Rolle" +"Roles" "Roller" +"User" "Bruker" +"Users" "Brukere" + +# Tooltips +"Open submenu" "Åpne undermeny" +"Close submenu" "Lukk undermeny" +"Next object of the same type" "Neste objekt av samme type" +"Find or create an object of the same type" "Finn eller opprett et objekt av samme type" +"Choose a suitable value" "Velg en passende verdi" +"Adopt this value" "Overta denne verdien" +"Go to first line" "Gå til første linje" +"Scroll up one page" "Scroll opp en side" +"Scroll up one line" "Scroll opp en linje" +"Scroll down one line" "Scroll ned en linje" +"Scroll down one page" "Scroll ned en side" +"Go to last line" "Gå til siste linje" +"Delete row" "Slett rad" +"Shift row up" "Forskyv en rad opp" +"Clear all input fields" "Slett alle input-felter" +"Release exclusive write access for this object" "Frigi eksklusiv skrivetilgang til dette objektet" +"Gain exclusive write access for this object" "Innhent eksklusiv skrivetilgang til dette objektet" +"Start search" "Start søk" +"Create new object" "Opprett nytt objekt" +"Create a new copy of this object" "Opprett ny kopi av dette objektet" +"Mark this object as \"not deleted\"" "Merk dette objektet som \"ikke slettet\"" +"Mark this object as \"deleted\"" "Merk dette objektet som \"slettet\"" +"Update" "Oppdater" diff --git a/loc/ru b/loc/ru @@ -0,0 +1,77 @@ +# 11aug08 +# Mansur Mamkin <mmamkin@mail.ru> + +"Language" "Язык" + +# lib/db.l +"Boolean input expected" "Ожидается тип Boolean" +"Numeric input expected" "Ожидается числовой тип" +"Symbolic type expected" "Ожидается тип Symbol" +"String type expected" "Ожидается тип String" +"Type error" "Ошибка типа" +"Not unique" "Не уникальный" +"Input required" "Требуется ввод" + +# lib/form.l +"Cancel" "Отмена" +"Yes" "Да" +"No" "Нет" +"Select" "Выбрать" +"Delete row?" "Удалить строку?" +"Show" "Показать" +"Bad date format" "Неверный формат даты" +"Bad time format" "Неверный формат времени" +"Bad phone number format" "Неверный формат телефонного номера" +"male" "муж." +"female" "жен." +"New" "Новый" +"Edit" "Редактировать" +"Save" "Сохранить" +"Done" "Готово" +"Currently edited by '@2' (@1)" "Редактируется '@2' (@1)" +"Search" "Искать" +"Reset" "Сброс" +"New/Copy" "Новый/Копировать" +"Restore" "Восстановить" +"Restore @1?" "Восстановить @1?" +"Delete" "Удалить" +"Delete @1?" "Удалить @1?" +"Data not found" "Данные не найдены" + +# General +"login" "Войти" +"logout" "Выйти" +"' logged in" "' вошел" +"Name" "Имя" +"Password" "Пароль" +"Permission denied" "Доступ запрещен" +"Permissions" "Разрешения" +"Role" "Роль" +"Roles" "Роли" +"User" "Пользователь" +"Users" "Пользователи" + +# Tooltips +"Open submenu" "Открыть подменю" +"Close submenu" "Закрыть подменю" +"Next object of the same type" "Следующий объект такого же типа" +"Find or create an object of the same type" "Найти или создать объект такого же типа" +"Choose a suitable value" "Выберите подходящее значение" +"Adopt this value" "Принять это значение" +"Go to first line" "Перейти к первой строке" +"Scroll up one page" "Прокрутить вверх на одну страницу" +"Scroll up one line" "Прокрутить вверх на одну строку" +"Scroll down one line" "Прокрутить вниз на одну строку" +"Scroll down one page" "Прокрутить вниз на одну страницу" +"Go to last line" "Перейти к последней строке" +"Delete row" "Удалить строку" +"Shift row up" "Переместить строку вверх" +"Clear all input fields" "Очистить все поля ввода" +"Release exclusive write access for this object" "Закрыть эксклюзивный доступ для записи этого объекта" +"Gain exclusive write access for this object" "Получить эксклюзивный доступ для записи этого объекта" +"Start search" "Начать поиск" +"Create new object" "Создать новый объект" +"Create a new copy of this object" "Создать новую копию этого объекта" +"Mark this object as \"not deleted\"" "Отметить этот объект как \"не удалённый\"" +"Mark this object as \"deleted\"" "Отметить этот объект как \"удалённый\"" +"Update" "Обновить" diff --git a/misc/bigtest b/misc/bigtest @@ -0,0 +1,103 @@ +#!bin/picolisp lib.l +# 23jan10abu +# misc/bigtest <seed> + +(load "lib/misc.l") + +(seed (car (argv))) + +# Random patterns: +# cnt +# xxx0000000000000000000000000xxxx0000000000000000000000000xxx +# (| 7 (>> -28 15) (>> -57 7)) +# +# xxx1111111111111111111111111xxxx1111111111111111111111111xxx +# 1FFFFFF0FFFFFF8 +# +# +# dig +# xxx000000000000000000000000000xxxx000000000000000000000000000xxx +# (| 7 (>> -30 15) (>> -61 7)) +# +# xxx111111111111111111111111111xxxx111111111111111111111111111xxx +# 1FFFFFFC3FFFFFF8 + +(de rnd () + (let (Big (| (rand 0 7) (>> -28 (rand 0 15)) (>> -57 (rand 0 7))) N -60) + (when (rand T) + (setq Big (| Big `(hex "1FFFFFF0FFFFFF8"))) ) + (do (rand 0 2) + (let Dig (| (rand 0 7) (>> -30 (rand 0 15)) (>> -61 (rand 0 7))) + (when (rand T) + (setq Dig (| Dig `(hex "1FFFFFFC3FFFFFF8"))) ) + (setq Big (| Big (>> N Dig))) + (dec 'N 64) ) ) + (if (rand T) Big (- Big)) ) ) + + +(de test1 (S N1) + (let (N (read) X (eval (list S N1))) + (unless (= N X) + (prinl "^J" N ": (" S " " N1 ") -> " X) + (bye) ) ) ) + +(de test2 (S N1 N2) + (let (N (read) X (eval (list S N1 N2))) + (unless (= N X) + (prinl "^J" N ": (" S " " N1 " " N2 ") -> " X) + (bye) ) ) ) + +(de cmp2 (S N1 N2) + (let (N (n0 (read)) X (eval (list S N1 N2))) + (unless (== N X) + (prinl "^J" N ": (" S " " N1 " " N2 ") -> " X) + (bye) ) ) ) + + +(sys "BC_LINE_LENGTH" "200") + +(pipe + (out '("/usr/bin/bc") + (do 10000000 + (setq N1 (rnd)) + (while (=0 (setq N2 (rnd)))) + (prinl N1) + (prinl N2) + (prinl N1 " + " N2) + (prinl N1 " + 1") + (prinl N1 " + 1") + (prinl N1 " - " N2) + (prinl N1 " - 1") + (prinl N1 " - 1") + (prinl N1 " * " N2) + (prinl N1 " * 2") + (prinl N1 " % " N2) + (prinl N1 " / " N2) + (prinl N1 " / 2") + (prinl N1 " >= " N2) + (prinl N1 " > " N2) + (prinl "sqrt(" (abs N1) ")") ) ) + (do 100 + (do 100000 + (setq + N1 (read) + N2 (read) ) + (test2 '+ N1 N2) + (test2 '+ N1 1) + (test1 'inc N1) + (test2 '- N1 N2) + (test2 '- N1 1) + (test1 'dec N1) + (test2 '* N1 N2) + (test2 '* N1 2) + (test2 '% N1 N2) + (test2 '/ N1 N2) + (test2 '/ N1 2) + (cmp2 '>= N1 N2) + (cmp2 '> N1 N2) + (test1 'sqrt (abs N1)) ) + (prin ".") + (flush) ) + (prinl) ) + +(bye) diff --git a/misc/calc b/misc/calc @@ -0,0 +1,12 @@ +#!bin/picolisp lib.l +# 21jan07abu +# (c) Software Lab. Alexander Burger + +(load "@lib/misc.l" "@misc/calc.l") + +# Initialize +(main) + +# Start server +(go) +(wait) diff --git a/misc/calc.l b/misc/calc.l @@ -0,0 +1,73 @@ +# 17apr08abu +# (c) Software Lab. Alexander Burger + +# *Init *Accu *Stack + +(allowed NIL "@calculator" "favicon.ico" "lib.css") +(load "lib/http.l" "lib/xhtml.l" "lib/form.l") + +# Calculator logic +(de digit (N) + (when *Init (zero *Accu) (off *Init)) + (setq *Accu (+ N (* 10 *Accu))) ) + +(de calc () + (let (Fun (caar *Stack) Val (cddr (pop '*Stack))) + (setq *Accu + (if (and (== '/ Fun) (=0 *Accu)) + (alert "Div / 0") + (Fun Val *Accu) ) ) ) ) + +(de operand (Fun Prio) + (when (>= (cadar *Stack) Prio) (calc)) + (push '*Stack (cons Fun Prio *Accu)) + (on *Init) ) + +(de finish () + (while *Stack (calc)) + (on *Init) ) + +# Calculator GUI +(de calculator () + (app) + (action + (html 0 "Bignum Calculator" "lib.css" NIL + (<h2> NIL "Bignum Calculator") + (form NIL + (<br> (gui '(+Var +NumField) '*Accu 60)) + (<grid> 4 + (gui '(+JS +Button) "±" '(setq *Accu (- *Accu))) + (gui '(+Able +JS +Button) '(ge0 *Accu) (char 8730) + '(setq *Accu (sqrt *Accu)) ) + (gui '(+JS +Button) "\^" '(operand '** 3)) + (gui '(+JS +Button) "/" '(operand '/ 2)) + + (gui '(+JS +Button) "7" '(digit 7)) + (gui '(+JS +Button) "8" '(digit 8)) + (gui '(+JS +Button) "9" '(digit 9)) + (gui '(+JS +Button) "*" '(operand '* 2)) + + (gui '(+JS +Button) "4" '(digit 4)) + (gui '(+JS +Button) "5" '(digit 5)) + (gui '(+JS +Button) "6" '(digit 6)) + (gui '(+JS +Button) "-" '(operand '- 1)) + + (gui '(+JS +Button) "1" '(digit 1)) + (gui '(+JS +Button) "2" '(digit 2)) + (gui '(+JS +Button) "3" '(digit 3)) + (gui '(+JS +Button) "+" '(operand '+ 1)) + + (gui '(+JS +Button) "0" '(digit 0)) + (gui '(+JS +Button) "C" '(zero *Accu)) + (gui '(+JS +Button) "A" '(main)) + (gui '(+JS +Button) "=" '(finish)) ) ) ) ) ) + +# Initialize +(de main () + (on *Init) + (zero *Accu) + (off *Stack) ) + +# Start server +(de go () + (server 8080 "@calculator") ) diff --git a/misc/chat b/misc/chat @@ -0,0 +1,32 @@ +#!bin/picolisp lib.l +# 21dec05abu + +# *Port *Sock *Name + +(de chat Lst + (out *Sock + (mapc prin Lst) + (prinl) ) ) + + +(setq *Port (port 4004)) + +(loop + (setq *Sock (listen *Port)) + (NIL (fork) (close *Port)) + (close *Sock) ) + +(out *Sock + (prin "Please enter your name: ") + (flush) ) +(in *Sock (setq *Name (line T))) + +(tell 'chat "+++ " *Name " arrived +++") + +(task *Sock + (in @ + (ifn (eof) + (tell 'chat *Name "> " (line T)) + (tell 'chat "--- " *Name " left ---") + (bye) ) ) ) +(wait) diff --git a/misc/crc.l b/misc/crc.l @@ -0,0 +1,23 @@ +# 04sep06abu +# (c) Software Lab. Alexander Burger + +(load "lib/gcc.l") + +(gcc "crc" NIL 'crc) + +any crc(any ex) { + any x = EVAL(cadr(ex)); + int c, crc, i; + + NeedLst(ex,x); + for (crc = 0; isCell(x); x = cdr(x)) { + c = (int)xCnt(ex,car(x)); + for (i = 0; i < 8; ++i) { + if ((c ^ crc) & 1) + crc ^= 0x14002; /* Polynom x**16 + x**15 + x**2 + 1 */ + c >>= 1, crc >>= 1; + } + } + return boxCnt(crc); +} +/**/ diff --git a/misc/dining.l b/misc/dining.l @@ -0,0 +1,42 @@ +# 18mar10abu +# (c) Software Lab. Alexander Burger +# Dining Philosophers + +(de dining (Name State) + (loop + (prinl Name ": " State) + (state 'State # Dispatch according to state + (thinking 'hungry) # If thinking, get hungry + (hungry # If hungry, grab random fork + (if (rand T) + (and (acquire leftFork) 'leftFork) + (and (acquire rightFork) 'rightFork) ) ) + (hungry 'hungry # Failed, stay hungry for a while + (wait (rand 1000 3000)) ) + (leftFork # If holding left fork, try right one + (and (acquire rightFork) 'eating) + (wait 2000) ) # then eat for 2 seconds + (rightFork # If holding right fork, try left one + (and (acquire leftFork) 'eating) + (wait 2000) ) # then eat for 2 seconds + ((leftFork rightFork) 'hungry # Otherwise, go back to hungry, + (release (val State)) # release left or right fork + (wait (rand 1000 3000)) ) # and stay hungry + (eating 'thinking # After eating, resume thinking + (release leftFork) + (release rightFork) + (wait 6000) ) ) ) ) # for 6 seconds + +(setq *Philosophers + (maplist + '((Phils Forks) + (let (leftFork (tmp (car Forks)) rightFork (tmp (cadr Forks))) + (or + (fork) # Parent: Collect child process IDs + (dining (car Phils) 'hungry) ) ) ) # Initially hungry + '("Aristotle" "Kant" "Spinoza" "Marx" "Russell") + '("ForkA" "ForkB" "ForkC" "ForkD" "ForkE" .) ) ) + +(push '*Bye '(mapc kill *Philosophers)) # Terminate all upon exit + +# vi:et:ts=3:sw=3 diff --git a/misc/dirTree.l b/misc/dirTree.l @@ -0,0 +1,19 @@ +# 10jul08abu +# (c) Software Lab. Alexander Burger + +(load "lib/http.l" "lib/xhtml.l") + +(de subDirs (Dir) + (cache '*DirCache (or (pack (flip (chop Dir))) ".") + (extract + '((F) + (when (=T (car (info (setq F (pack Dir F))))) + (pack F '/) ) ) + (dir Dir) ) ) ) + +(de dir.html (Path) + (and (app) (setq *DirTree (subDirs))) + (html NIL "Test" NIL NIL + (<tree> "@dir.html" Path *DirTree subDirs nil subDirs) ) ) + +(server 8080 "@dir.html") diff --git a/misc/fannkuch.l b/misc/fannkuch.l @@ -0,0 +1,38 @@ +# 07nov09abu +# (c) Software Lab. Alexander Burger +# Fannkuch benchmark (http://shootout.alioth.debian.org) + +(de fannkuch (N) + (let (Lst (range 1 N) L Lst Max) + (recur (L) # Permute + (if (cdr L) + (do (length L) + (recurse (cdr L)) + (rot L) ) + (zero N) # For each permutation + (for (P (copy Lst) (> (car P) 1) (flip P (car P))) + (inc 'N) ) + (setq Max (max N Max)) ) ) + Max ) ) + +# Parallelized version +(de fannkuch+ (N) + (let (Res (need N) Lst (range 1 N) L Lst Max) + (for (R Res R (cdr R)) + (later R + (let L (cdr Lst) + (recur (L) # Permute + (if (cdr L) + (do (length L) + (recurse (cdr L)) + (rot L) ) + (zero N) # For each permutation + (for (P (copy Lst) (> (car P) 1) (flip P (car P))) + (inc 'N) ) + (setq Max (max N Max)) ) ) + Max ) ) + (rot Lst) ) + (wait NIL (full Res)) + (apply max Res) ) ) + +# vi:et:ts=3:sw=3 diff --git a/misc/fibo.l b/misc/fibo.l @@ -0,0 +1,50 @@ +# 08mar10abu +# (c) Software Lab. Alexander Burger + +# Standard version +(de fibo (N) + (if (> 2 N) + 1 + (+ (fibo (dec N)) (fibo (- N 2))) ) ) + + +# Parallelized version +(de fibo+ (D N) # Uses 2**D processes + (cond + ((> 1 (dec 'N)) 1) + ((ge0 (dec 'D)) + (let (A NIL B NIL) + (later 'A (fibo+ D N)) + (later 'B (fibo+ D (dec N))) + (wait NIL (and A B)) + (+ A B) ) ) + (T + (+ + (fibo+ D N) + (fibo+ D (dec N)) ) ) ) ) + + +# Using a cache (fastest) +(de cachedFibo (N) + (cache '*Fibo (format (seed N)) + (if (> 2 N) + 1 + (+ (cachedFibo (dec N)) (cachedFibo (- N 2))) ) ) ) + + +# Coded in 'C' +`(== 64 64) # Only in the 64-bit version + +(load "lib/native.l") + +(gcc "fibo" NIL + (cFibo (N) "Fibo" 'I N) ) + +int Fibo(int n) { + if (n < 2) + return 1; + return Fibo(n-1) + Fibo(n-2); +} +/**/ + +# vi:et:ts=3:sw=3 diff --git a/misc/hanoi.l b/misc/hanoi.l @@ -0,0 +1,24 @@ +# 10nov04abu +# (c) Software Lab. Alexander Burger + +# Lisp +(de hanoi (N) + (move N 'left 'center 'right) ) + +(de move (N A B C) + (unless (=0 N) + (move (dec N) A C B) + (println 'Move 'disk 'from 'the A 'to 'the B 'pole) + (move (dec N) C B A) ) ) + +# Pilog +(be hanoi (@N) + (move @N left center right) ) + +(be move (0 @ @ @) T) + +(be move (@N @A @B @C) + (@M - (-> @N) 1) + (move @M @A @C @B) + (@ println 'Move 'disk 'from 'the (-> @A) 'to 'the (-> @B) 'pole) + (move @M @C @B @A) ) diff --git a/misc/life.l b/misc/life.l @@ -0,0 +1,54 @@ +# 15mar10abu +# (c) Software Lab. Alexander Burger + +(load "@lib/simul.l") + +(de life (DX DY . Init) + (let Grid (grid DX DY) + (for This Init + (=: life T) ) + (loop + (disp Grid NIL + '((This) (if (: life) "X " " ")) ) + (wait 1000) + (for Col Grid + (for This Col + (let N # Count neighbors + (cnt + '((Dir) (get (Dir This) 'life)) + (quote + west east south north + ((X) (south (west X))) + ((X) (north (west X))) + ((X) (south (east X))) + ((X) (north (east X))) ) ) + (=: next # Next generation + (if (: life) + (>= 3 N 2) + (= N 3) ) ) ) ) ) + (for Col Grid # Update + (for This Col + (=: life (: next)) ) ) ) ) ) + +# Blinker (period 2) +'(life 5 5 b3 c3 d3) + +# Glider +'(life 9 9 a7 b7 b9 c7 c8) + +# Pulsar (period 3) +(life 17 17 + b6 b12 + c6 c12 + d6 d7 d11 d12 + f2 f3 f4 f7 f8 f10 f11 f14 f15 f16 + g4 g6 g8 g10 g12 g14 + h6 h7 h11 h12 + j6 j7 j11 j12 + k4 k6 k8 k10 k12 k14 + l2 l3 l4 l7 l8 l10 l11 l14 l15 l16 + n6 n7 n11 n12 + o6 o12 + p6 p12 ) + +# vi:et:ts=3:sw=3 diff --git a/misc/mailing b/misc/mailing @@ -0,0 +1,93 @@ +#!bin/picolisp lib.l +# 05sep08abu +# (c) Software Lab. Alexander Burger + +# Configuration +(setq + *MailingList "picolisp@software-lab.de" + *SpoolFile "/var/mail/picolisp" + *MailingDomain "software-lab.de" + *Mailings (make (in "Mailings" (while (line T) (link @)))) + *SmtpHost "localhost" + *SmtpPort 25 ) + +# Process mails +(loop + (when (gt0 (car (info *SpoolFile))) + (protect + (in *SpoolFile + (unless (= "From" (till " " T)) + (quit "Bad mbox file") ) + (char) + (while (setq *From (lowc (till " " T))) + (off + *Name *Subject *Date *MessageID *InReplyTo *MimeVersion + *ContentType *ContentDisposition *UserAgent ) + (while (split (line) " ") + (setq *Line (glue " " (cdr @))) + (case (pack (car @)) + ("From:" (setq *Name *Line)) + ("Subject:" (setq *Subject *Line)) + ("Date:" (setq *Date *Line)) + ("Message-ID:" (setq *MessageID *Line)) + ("In-Reply-To:" (setq *InReplyTo *Line)) + ("MIME-Version:" (setq *MimeVersion *Line)) + ("Content-Type:" (setq *ContentType *Line)) + ("Content-Disposition:" (setq *ContentDisposition *Line)) + ("User-Agent:" (setq *UserAgent *Line)) ) ) + (if (nor (member *From *Mailings) (= "subscribe" (lowc *Subject))) + (out "/dev/null" (echo "^JFrom ") (msg *From " discarded")) + (unless (setq *Sock (connect *SmtpHost *SmtpPort)) + (quit "Can't connect to SMTP server") ) + (unless + (and + (pre? "220 " (in *Sock (line T))) + (out *Sock (prinl "HELO " *MailingDomain "^M")) + (pre? "250 " (in *Sock (line T))) + (out *Sock (prinl "MAIL FROM:" *MailingList "^M")) + (pre? "250 " (in *Sock (line T))) ) + (quit "Can't HELO") ) + (when (= "subscribe" (lowc *Subject)) + (push1 '*Mailings *From) + (out "Mailings" (mapc prinl *Mailings)) ) + (for To *Mailings + (out *Sock (prinl "RCPT TO:" To "^M")) + (unless (pre? "250 " (in *Sock (line T))) + (msg T " can't mail") ) ) + (when (and (out *Sock (prinl "DATA^M")) (pre? "354 " (in *Sock (line T)))) + (out *Sock + (prinl "From: " (or *Name *From) "^M") + (prinl "Sender: " *MailingList "^M") + (prinl "Reply-To: " *MailingList "^M") + (prinl "To: " *MailingList "^M") + (prinl "Subject: " *Subject "^M") + (and *Date (prinl "Date: " @ "^M")) + (and *MessageID (prinl "Message-ID: " @ "^M")) + (and *InReplyTo (prinl "In-Reply-To: " @ "^M")) + (and *MimeVersion (prinl "MIME-Version: " @ "^M")) + (and *ContentType (prinl "Content-Type: " @ "^M")) + (and *ContentDisposition (prinl "Content-Disposition: " @ "^M")) + (and *UserAgent (prinl "User-Agent: " @ "^M")) + (prinl "^M") + (cond + ((= "subscribe" (lowc *Subject)) + (prinl "Hello " (or *Name *From) " :-)^M") + (prinl "You are now subscribed^M") + (prinl "****^M^J^M") ) + ((= "unsubscribe" (lowc *Subject)) + (out "Mailings" + (mapc prinl (del *From '*Mailings)) ) + (prinl "Good bye " (or *Name *From) " :-(^M") + (prinl "You are now unsubscribed^M") + (prinl "****^M^J^M") ) ) + (echo "^JFrom ") + (prinl "-- ^M") + (prinl "UNSUBSCRIBE: mailto:" *MailingList "?subject=Unsubscribe^M") + (prinl ".^M") + (prinl "QUIT^M") ) ) + (close *Sock) ) ) ) + (out *SpoolFile (rewind)) ) ) + (call "fetchmail" "-as") + (wait `(* 5 60 1000)) ) + +# vi:et:ts=3:sw=3 diff --git a/misc/maze.l b/misc/maze.l @@ -0,0 +1,33 @@ +# 31jan10abu +# (c) Software Lab. Alexander Burger + +# ./dbg misc/maze.l -"setq M (maze 16 10)" -"display M" + +(load "lib/simul.l") + +(de maze (DX DY) + (let Maze (grid DX DY) + (let Fld (get Maze (rand 1 DX) (rand 1 DY)) + (recur (Fld) + (for Dir (shuffle '((west . east) (east . west) (south . north) (north . south))) + (with ((car Dir) Fld) + (unless (or (: west) (: east) (: south) (: north)) + (put Fld (car Dir) This) + (put This (cdr Dir) Fld) + (recurse This) ) ) ) ) ) + (for Col Maze + (for This Col + (set This + (cons + (cons (: west) (: east)) + (cons (: south) (: north)) ) ) + (=: west) + (=: east) + (=: south) + (=: north) ) ) + Maze ) ) + +(de display (Maze) + (disp Maze 0 '((This) " ")) ) + +# vi:et:ts=3:sw=3 diff --git a/misc/pi.l b/misc/pi.l @@ -0,0 +1,23 @@ +# 14aug05abu +# (c) Software Lab. Alexander Burger + +############################## +# Iterative calculation of PI: +# S = 0 +# P = 2 +# Loop +# S = sqrt(S+2) +# P = 2*P/S +############################## + +(de pi (N Eps) + (default Eps 100) + (let (Scl (** 10 N) S 0 N2 (* 2 Scl) P N2 P2 0) + (while (> (- P P2) Eps) + (setq + P2 P + S (sqrt (* Scl (+ S N2))) + P (*/ N2 P S) ) ) ) ) + +(test 3141592653589793238462643383279502884197169399375105820975043 + (pi 60) ) diff --git a/misc/pilog.l b/misc/pilog.l @@ -0,0 +1,125 @@ +# 25dec09abu +# (c) Software Lab. Alexander Burger + +(be sister (@X @Y) (parents @X @M @F) (parents @Y @M @F) (different @X @Y)) + +(be parents (@C @M @F) (mother @C @M) (father @C @F)) + +(be mother (Mia Masako)) +(be mother (Laila Masako)) +(be mother (Mona Masako)) + +(be father (Mia Alex)) +(be father (Laila Alex)) +(be father (Mona Alex)) + +(be factorial (0 1) T) +(be factorial (@N @X) + (@A - (-> @N) 1) + (factorial @A @B) + (@X * (-> @N) (-> @B)) ) + +(be fibo (0 1) T) +(be fibo (1 1) T) +(be fibo (@N @X) + (@Y - (-> @N) 1) + (@Z - (-> @N) 2) + (fibo @Y @A) + (fibo @Z @B) + (@X + (-> @A) (-> @B)) + (asserta (fibo (@N @X) T)) ) + + +(be int (@N) + (@ zero *N) + (repeat) + (@N inc '*N) ) + +(be prnum () + (@ zero *N) + (repeat) + (@ println (inc '*N)) + (@ >= *N 4) ) + +(be gennum (@N) + (@C box 0) + (_gennum @N @C) ) + +(be _gennum (@N @C) (@ >= (val (-> @C)) 4) T (fail)) +(be _gennum (@N @C) (@N inc (-> @C))) +(repeat) + +(be genlst (@X) + (@C box (1 2 3 4)) + (_genlst @X @C) ) + +(be _genlst (@X @C) (@ not (val (-> @C))) T (fail)) +(be _genlst (@X @C) (@X pop (-> @C))) +(repeat) + +(be tree (@K (@K @V @L @R) @V) + T ) + +(be tree (@K (@K1 @V1 @L @R) @V) + (@ < (-> @K) (-> @K1)) + (tree @K @L @V) ) + +(be tree (@K (@K1 @V1 @L @R) @V) + (@ >= (-> @K) (-> @K1)) + (tree @K @R @V) ) + + +(be change (you I)) +(be change (are (am not))) +(be change (french german)) +(be change (@X @X)) + + +### Test ### +(test NIL (solve '((equal A B)))) +(test '(T) (solve '((equal A A)))) + +(test NIL (solve '((not (equal A A))))) +(test '(T) (solve '((not (equal A B))))) + +(test NIL (solve '((different A A)))) +(test '(T) (solve '((different A B)))) + +(test + '(((@X . 3)) ((@X . 4))) + (solve '((or ((equal 3 @X)) ((equal 4 @X))))) ) + +(test '(T) (solve '((append (a b) (c d) (a b c d))))) +(test + '(((@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)))) ) + +(test '(T) (solve '((member b (a b c))))) +(test + '(((@X . a)) ((@X . b)) ((@X . c))) + (solve '((member @X (a b c)))) ) + +(test '(T) (solve '((clause append ((NIL @X @X)))))) + +(test + '(a b c d) + (solve '((@B box) (lst @X (a b c b c d)) (uniq @B @X)) @X) ) + + +(test + '(((@B . Mia)) ((@B . Mona))) + (solve '((sister Laila @B))) ) + +(test + '(((@X . 1)) ((@X . 2)) ((@X . 3)) ((@X . 4))) + (solve '((gennum @X))) ) + +(test + '(((@X . 1)) ((@X . 2)) ((@X . 3)) ((@X . 4))) + (solve '((genlst @X))) ) + +(test + '(((@Z I (am not) a computer))) + (solve '((mapcar change (you are a computer) @Z) T)) ) + +# vi:et:ts=3:sw=3 diff --git a/misc/reverse.l b/misc/reverse.l @@ -0,0 +1,16 @@ +# 19dec05abu +# (c) Software Lab. Alexander Burger + +(setq *Port (port 6789)) + +(loop + (setq *Sock (listen *Port)) + (NIL (fork) (close *Port)) + (close *Sock) ) + +(in *Sock + (until (eof) + (out *Sock + (prinl (flip (line))) ) ) ) + +(bye) diff --git a/misc/setf.l b/misc/setf.l @@ -0,0 +1,49 @@ +# 31jan08abu +# (c) Software Lab. Alexander Burger + +# 'setf' is the most perverse concept ever introduced into Lisp +(de setf "Args" + (let "P" (car "Args") + (set + (if (atom "P") + "P" + (let (: :: get prop car prog cadr cdr caddr cadr cadddr caddr) + (eval "P") ) ) + (eval (cadr "Args")) ) ) ) + +### Test ### +(test 7 + (use A + (setf A 7) + A ) ) + +(test (7 2 3) + (let L (1 2 3) + (setf (car L) 7) + L ) ) + +(test (1 7 3) + (let L (1 2 3) + (setf (cadr L) 7) + L ) ) + +(test 7 + (put 'A 'a 1) + (setf (get 'A 'a) 7) + (get 'A 'a) ) + +(test 7 + (put 'A 'a 1) + (with 'A + (setf (: a) 7) + (: a) ) ) + +# But also: +(undef 'foo) +(de foo (X) + (cadr X) ) + +(test (1 7 3) + (let L (1 2 3) (setf (foo L) 7) L) ) + +# vi:et:ts=3:sw=3 diff --git a/misc/sieve.l b/misc/sieve.l @@ -0,0 +1,14 @@ +# 25feb10abu +# (c) Software Lab. Alexander Burger + +# Sieve of Eratosthenes +(de sieve (N) + (let Sieve (range 1 N) + (set Sieve) + (for I (cdr Sieve) + (when I + (for (S (nth Sieve (* I I)) S (nth (cdr S) I)) + (set S) ) ) ) + (filter bool Sieve) ) ) + +# vi:et:ts=3:sw=3 diff --git a/misc/stress.l b/misc/stress.l @@ -0,0 +1,68 @@ +# 22mar10abu +# (c) Software Lab. Alexander Burger +# Use: nice ./p misc/stress.l -main -go -bye; rm db/test jnl db/test2 + +(load "lib/too.l") + +(class +A +Entity) +(rel key (+Key +Number)) # Key 1 .. 999 +(rel dat (+Ref +Number)) # Data 1 .. 999 + +(de rnd () + (rand 1 999) ) + +(de modify (N) + (do N + (do (rand 10 40) + (let K (rnd) + (with (db 'key '+A K) + (unless (= K (: key)) + (print '!) + (flush) ) ) ) ) + (dbSync) + (let (D (rnd) X (db 'key '+A (rnd))) + (inc *DB (- D (get X 'dat))) + (put> X 'dat D) ) + (commit 'upd) ) ) + +(de verify () + (dbCheck) + (let N 0 + (scan (tree 'dat '+A) + '((K V) + (unless (= (car K) (get V 'dat)) + (quit "dat mismatch" K) ) + (inc 'N (car K)) ) ) + (or + (= N (val *DB)) + (quit "val mismatch" (- N (val *DB))) ) ) ) + +(de main () + (seed (in "/dev/urandom" (rd 8))) + (call 'mkdir "-p" "db") + (call 'rm "-f" "db/test" "jnl" "db/test2") + (pool "db/test" NIL "jnl") + (set *DB 0) + (for K 999 + (let D (rnd) + (new T '(+A) 'key K 'dat D) + (inc *DB D) ) ) + (commit) ) + +(de go () + (do 10 + (let Pids + (make + (do 40 + (rand) + (if (fork) + (link @) + (modify 999) + (bye) ) ) ) + (while (find '((P) (kill P 0)) Pids) + (wait 1000) ) + (rollback) ) ) + (verify) + (pool "db/test2") + (journal "jnl") + (call 'cmp "db/test" "db/test2") ) diff --git a/misc/travel.l b/misc/travel.l @@ -0,0 +1,51 @@ +# 22oct03abu +# (c) Software Lab. Alexander Burger + +(de travel (A B) + (mini car + (solve + (quote + @A A + @B B + (path @A @B @P @N) ) + (cons @N @P) ) ) ) + + +(be path (@A @B @P @N) (path1 @A @B (@A) @P @N)) + +(be path1 (@A @A @L (@A) 0)) +(be path1 (@A @B @L (@A . @P) @N) + (edge @A @Z @X) + (not (member @Z @L)) + (path1 @Z @B (@Z . @L) @P @Y) + (@N + (-> @X) (-> @Y)) ) + +(be edge (@A @B @N) (vect @A @B @N)) +(be edge (@A @B @N) (vect @B @A @N)) + +(be vect (Rheine Muenster 39)) +(be vect (Rheine Osnabrueck 42)) +(be vect (Muenster Osnabrueck 51)) +(be vect (Warendorf Muenster 28)) +(be vect (Warendorf Osnabrueck 43)) +(be vect (Warendorf Rheda 24)) +(be vect (Warendorf Guetersloh 27)) +(be vect (Osnabrueck Bielefeld 48)) +(be vect (Rheda Guetersloh 10)) +(be vect (Bielefeld Guetersloh 16)) +(be vect (Bielefeld Paderborn 39)) +(be vect (Paderborn Guetersloh 31)) +(be vect (Paderborn Rheda 32)) +(be vect (Paderborn Soest 41)) +(be vect (Soest Rheda 38)) +(be vect (Soest Beckum 26)) +(be vect (Beckum Rheda 24)) +(be vect (Beckum Warendorf 27)) +(be vect (Ahlen Warendorf 27)) +(be vect (Ahlen Muenster 46)) +(be vect (Ahlen Beckum 11)) +(be vect (Ahlen Soest 27)) + +(test + '(123 Rheine Muenster Warendorf Rheda Paderborn) + (travel 'Rheine 'Paderborn) ) diff --git a/misc/trip.l b/misc/trip.l @@ -0,0 +1,84 @@ +# 11mar10abu +# (c) Software Lab. Alexander Burger + +(load "lib/simul.l") + +# Set up distance properties +# See "misc/travel.l" and "doc/travel" +(mapc + '((L) + (put (car L) (cadr L) (caddr L)) + (put (cadr L) (car L) (caddr L)) ) + (quote + (Rheine Muenster 39) + (Rheine Osnabrueck 42) + (Muenster Osnabrueck 51) + (Warendorf Muenster 28) + (Warendorf Osnabrueck 43) + (Warendorf Rheda 24) + (Warendorf Guetersloh 27) + (Osnabrueck Bielefeld 48) + (Rheda Guetersloh 10) + (Bielefeld Guetersloh 16) + (Bielefeld Paderborn 39) + (Paderborn Guetersloh 31) + (Paderborn Rheda 32) + (Paderborn Soest 41) + (Soest Rheda 38) + (Soest Beckum 26) + (Beckum Rheda 24) + (Beckum Warendorf 27) + (Ahlen Warendorf 27) + (Ahlen Muenster 46) + (Ahlen Beckum 11) + (Ahlen Soest 27) ) ) + +# Find a route from 'A' to 'B' +(de route (A B Lst) + (if (get A B) + (list A B) + (and + (pick + '((X) + (and + (not (memq X Lst)) + (route X B (cons A Lst)) ) ) + (shuffle (mapcar cdr (getl A))) ) + (cons A @) ) ) ) + +# Minimize trip from 'A' to 'B' +(de trip (Pop Gen A B) + (gen + (make (do Pop (link (route A B)))) # Population + '((Pop) (lt0 (dec 'Gen))) # Condition + '((X Y) # Recombination + (make + (while (prog (link (pop 'X)) X) + (when (member (car X) (cdr Y)) + (setq Y @) + (xchg 'X 'Y) ) ) ) ) + '((L) # Mutation + (let (N (length L) H (>> 1 N) N1 (rand 1 H) N2 (rand (inc H) N)) + (if (route (get L N1) (get L N2)) + (append + (head (dec N1) L) + @ + (nth L (inc N2)) ) + L ) ) ) + '((L) # Selection + (let A (pop 'L) + (- + (sum + '((X) (get A (setq A X))) + L ) ) ) ) ) ) + +# Optimum hit percentage, e.g. (tst 12 8) +(de tst (Pop Gen) + (let OK 0 + (do 100 + (when + (= + (trip Pop Gen 'Rheine 'Paderborn) + '(Rheine Muenster Warendorf Rheda Paderborn) ) + (inc 'OK) ) ) + OK ) ) diff --git a/opt/pilog.l b/opt/pilog.l @@ -0,0 +1,15 @@ +# 25dec09abu +# (c) Software Lab. Alexander Burger + +(be mapcar (@ NIL NIL)) +(be mapcar (@P (@X . @L) (@Y . @M)) + (call @P @X @Y) + (mapcar @P @L @M) ) + +# Contributed by Clemens Hinze <cle-picolisp@qiao.in-berlin.de> +(be findall (@Pat @P @Res) + (@Res solve + (-> @P) + (or @Pat (fill (-> @Pat))) ) ) + +# vi:et:ts=3:sw=3 diff --git a/p b/p @@ -0,0 +1,2 @@ +#!/bin/sh +exec ${0%/*}/bin/picolisp ${0%/*}/lib.l @ext.l "$@" diff --git a/plmod b/plmod @@ -0,0 +1,2 @@ +#!/bin/sh +exec ${0%/*}/bin/picolisp -"on *Dbg" ${0%/*}/lib.l @ext.l @plmod.l "$@" diff --git a/plmod.l b/plmod.l @@ -0,0 +1,10 @@ +# 16feb10abu +# (c) Software Lab. Alexander Burger + +(on *Dbg) +(off *Tsm) +(load "@lib/debug.l" "@lib/edit.l" "@lib/lint.l" "@lib/sq.l") + +(noLint 'later (loc "@Prg" later)) + +# vi:et:ts=3:sw=3 diff --git a/rcsim/README b/rcsim/README @@ -0,0 +1,125 @@ +12nov09abu +(c) Software Lab. Alexander Burger + + + RC Flight Simulator + =================== + +The PicoLisp RC Flight Simulator is a very simple toy simulator, allowing you to +fly an airplane in a way similar to a radio controlled model plane. + +It is all implemented within the PicoLisp system, so that no additional +libraries like OpenGL or GL4Java are needed. It may be regarded as a proof of +concept, because a flight simulator is one of the least typical things to do in +Lisp. + +The plane is similar to the German WW-I aircraft Fokker "D-VII" (and a bit to +the British Sopwith Camel ;-). Though the user's position is that of a model +plane's pilot (i.e. viewing the plane from a fixed position), all parameters +like dimensions, mass, engine power and flight data are intended to be as close +as possible to a "real" Fokker D-VII. Unfortunately, some of these parameters +are not known exactly, but it is a fun project anyway, and I hope it comes +close. + + +The simulator supports two different kinds of user interface. The version in the +standard release uses a plain Xlib frontend. To use it, you'll have to build it +once: + + $ (cd src; make x11) + +Then start the PicoLisp server with + + $ ./dbg rcsim/main.l -main -go + +and then the Z3d-Client from another X-terminal + + $ bin/z3dClient localhost 8080 + +Then make sure that your keyboard focus is on the first X-terminal (where you +started the simulator from, _not_ the Z3d-Client window). + +Hitting ENTER at the PicoLisp prompt (the colon ':') will terminate the +simulation process and close the Z3d-Client window. As always, you can stop the +PicoLisp servers with 'killall picolisp'. + + + The second version runs in an Applet in any Java-enabled browser.To run it + locally, please download and unpack the "picoJavaGUI.tgz" tarball. It + contains the Java applet GUI which is no longer part of the standard PicoLisp + release. + + You can start the PicoLisp server with + + $ ./p rcsim/applet.main.l -main -go -wait + + or (to get an interactive PicoLisp command line) with + + $ ./dbg rcsim/main.l -main -go + + and then point your browser to "http://localhost:8080". + + If you don't have PicoLisp installed, you might want to try the online + version at: + + http://rcsim.7fach.de + + (please take care not to use a proxy for that address) + + In both cases, click onto the image to set the keyboard focus. + + +The simulator runs in the background, so if it is started interactively (see +above), the Lisp interpreter is fully available and lets you inspect or modify +the environment. For example + +: (show *Model) + +shows the current state of the model. + +In the Z3d-Version, terminal output is interlaced with the simulator's output. +If you see no ':' prompt, it is helpful to type a single dot '.' and ENTER, to +avoid terminating the interpreter: + +... +0 % 0 km/h 0 m/s 1 m +. +-> NIL +: + + +The simulator is controlled by the following 10 keys: + +- The cursor (arrow) keys UP and DOWN control the elevator +- The LEFT and RIGHT cursor keys control the combined rudder/ailerons +- The HOME key sets full throttle (F8) +- PAGE UP/DOWN increase/decrease the throttle (F7/F6) +- The END key turns the engine off (F5) +- INS/DEL zoom in/out (or F4/F3) + +For a first flight, just hit the HOME key as the plane sits waiting on the +runway, and watch it accelerate. After some time, when it starts to jump a bit +nervously, give a little up-elevator (the DOWN arrow key) to gain height. Then +hit the PAGE DOWN key once or twice to decrease the throttle, and cautiously +experiment with with the arrow keys. + + +There is some rudimentary sound implemented. It is not intended to be realistic +(the graphic isn't either ;-) but to give some audible feedback to the user. It +produces a simple square wave sound, depending on the engine's thrust, the +airspeed, the distance, and the Doppler effect. + +If you are using the Java/Applet version, you might simply click on the "Sound" +checkbox. Be warned, however, that this induces additional load on the client +side, and doesn't sound very smooth. BTW, does anybody know of a better way to +produce continuous sound with variable frequency in a Java applet? + +In the Z3d-Client version, a console speaker interface is used, which gives +better results. As the speaker can be accessed in Linux only from a virtual +console (not from an X-terminal), log into a virtual console (typically tty1 .. +tty6) _before_ you start the simulator, change to the installation directory, +and run the simple tone server: + + $ rcsim/tone + +When done, you can stop it with 'killall tone'. diff --git a/rcsim/env.l b/rcsim/env.l @@ -0,0 +1,103 @@ +# 21jan07abu +# (c) Software Lab. Alexander Burger + +(model This + '(runway1 -120.0 -200.0 -0.02 + (`DarkGrey NIL + +20.0 -20.0 0 + +20.0 +20.0 0 + -20.0 +20.0 0 + -20.0 -20.0 0 ) + (`White NIL + +10.0 -1.0 0 + +10.0 +1.0 0 + -10.0 +1.0 0 + -10.0 -1.0 0 ) ) ) + +(model This + '(runway2 -80.0 -200.0 -0.02 + (`DarkGrey NIL + +20.0 -20.0 0 + +20.0 +20.0 0 + -20.0 +20.0 0 + -20.0 -20.0 0 ) + (`White NIL + +10.0 -1.0 0 + +10.0 +1.0 0 + -10.0 +1.0 0 + -10.0 -1.0 0 ) ) ) + +(model This + '(runway3 -40.0 -200.0 -0.02 + (`DarkGrey NIL + +20.0 -20.0 0 + +20.0 +20.0 0 + -20.0 +20.0 0 + -20.0 -20.0 0 ) + (`White NIL + +10.0 -1.0 0 + +10.0 +1.0 0 + -10.0 +1.0 0 + -10.0 -1.0 0 ) ) ) + +(model This + '(runway4 0.0 -200.0 -0.02 + (`DarkGrey NIL + +20.0 -20.0 0 + +20.0 +20.0 0 + -20.0 +20.0 0 + -20.0 -20.0 0 ) + (`White NIL + +10.0 -1.0 0 + +10.0 +1.0 0 + -10.0 +1.0 0 + -10.0 -1.0 0 ) ) ) + +(model This + '(runway5 +40.0 -200.0 -0.02 + (`DarkGrey NIL + +20.0 -20.0 0 + +20.0 +20.0 0 + -20.0 +20.0 0 + -20.0 -20.0 0 ) + (`White NIL + +10.0 -1.0 0 + +10.0 +1.0 0 + -10.0 +1.0 0 + -10.0 -1.0 0 ) ) ) + +(model This + '(runway6 +80.0 -200.0 -0.02 + (`DarkGrey NIL + +20.0 -20.0 0 + +20.0 +20.0 0 + -20.0 +20.0 0 + -20.0 -20.0 0 ) + (`White NIL + +10.0 -1.0 0 + +10.0 +1.0 0 + -10.0 +1.0 0 + -10.0 -1.0 0 ) ) ) + +(model This + '(runway7 +120.0 -200.0 -0.02 + (`DarkGrey NIL + +20.0 -20.0 0 + +20.0 +20.0 0 + -20.0 +20.0 0 + -20.0 -20.0 0 ) + (`White NIL + +10.0 -1.0 0 + +10.0 +1.0 0 + -10.0 +1.0 0 + -10.0 -1.0 0 ) ) ) + +(=: env + (list + (: runway1) + (: runway2) + (: runway3) + (: runway4) + (: runway5) + (: runway6) + (: runway7) ) ) diff --git a/rcsim/fokker.l b/rcsim/fokker.l @@ -0,0 +1,456 @@ +# 01feb05abu +# (c) Software Lab. Alexander Burger + +(=: mass 910.0) # kg +(=: power 3924.0) # N +(=: rc -1.4) # kg/m +(=: lc -250.0) # kg/m +(=: trim 30) # Trimmung +(=: lim1 0.8) # tan(a) +(=: lim2 0.24) +(=: tx 1.2) # Touchdown +(=: tz -1.9) +(=: pitch 0.26) +(=: torq -10000.0) # Drehmoment +(=: stab (0.01 0.01 0.02)) # Stabilitaet + +(model This + '(body 0.0 0.0 1.50 + # Flaeche oben + (`Blue `Blue + -0.15 +0.30 +1.05 + +1.20 0.00 +1.05 + +1.20 +3.90 +1.05 + +0.90 +4.20 +1.05 + -0.20 +3.90 +1.05 + -0.60 +2.20 +1.05 + -0.60 +0.60 +1.05 ) + (`Blue `Blue + -0.60 -0.60 +1.05 + -0.60 -2.20 +1.05 + -0.20 -3.90 +1.05 + +0.90 -4.20 +1.05 + +1.20 -3.90 +1.05 + +1.20 0.00 +1.05 + -0.15 -0.30 +1.05 ) + (`Blue `Blue + +1.20 0.00 +1.05 + -0.15 -0.30 +1.05 + -0.15 +0.30 +1.05 ) + + # Querruder + (rightAileron -0.60 +2.20 +1.05 + (`Red `Red + +0.40 +1.70 0.00 + +0.72 +1.78 0.00 + +0.72 +1.90 0.00 + +0.40 +2.10 0.00 + 0.00 +1.80 0.00 + 0.00 +1.70 0.00 ) + (`Red `Red + +0.40 +1.70 0.00 + 0.00 +1.70 0.00 + 0.00 0.00 0.00 ) ) + (leftAileron -0.60 -2.20 +1.05 + (`Red `Red + +0.40 -1.70 0.00 + +0.72 -1.78 0.00 + +0.72 -1.90 0.00 + +0.40 -2.10 0.00 + 0.00 -1.80 0.00 + 0.00 -1.70 0.00 ) + (`Red `Red + +0.40 -1.70 0.00 + 0.00 -1.70 0.00 + 0.00 0.00 0.00 ) ) + + # Flaeche rechts unten + (`Blue `Blue + +0.90 +0.20 -0.60 + +0.90 +3.90 -0.30 + +0.60 +4.20 -0.30 + -0.90 +3.90 -0.30 + -0.90 +0.20 -0.60 ) + + # Flaeche links unten + (`Blue `Blue + -0.90 -0.20 -0.60 + -0.90 -3.90 -0.30 + +0.60 -4.20 -0.30 + +0.90 -3.90 -0.30 + +0.90 -0.20 -0.60 ) + + # Streben links + (`Brown `Brown + -0.20 -2.55 +1.05 + -0.50 -2.55 -0.37 + -0.60 -2.55 -0.37 + -0.30 -2.55 +1.05 ) + + (`Brown `Brown + -0.50 -2.55 -0.37 + -0.50 -2.55 -0.37 + +0.80 -2.55 +0.90 + +0.80 -2.55 +1.05 ) + + (`Brown `Brown + +0.90 -2.55 +1.05 + +0.60 -2.55 -0.37 + +0.50 -2.55 -0.37 + +0.80 -2.55 +1.05 ) + + # Streben rechts + (`Brown `Brown + -0.20 +2.55 +1.05 + -0.50 +2.55 -0.37 + -0.60 +2.55 -0.37 + -0.30 +2.55 +1.05 ) + + (`Brown `Brown + -0.50 +2.55 -0.37 + -0.50 +2.55 -0.37 + +0.80 +2.55 +0.90 + +0.80 +2.55 +1.05 ) + + (`Brown `Brown + +0.90 +2.55 +1.05 + +0.60 +2.55 -0.37 + +0.50 +2.55 -0.37 + +0.80 +2.55 +1.05 ) + + # Motorlager + (`Grey NIL + +1.80 +0.30 +0.30 + +1.80 -0.30 +0.30 + +1.80 -0.30 -0.30 + +1.80 +0.30 -0.30 ) + + # Rumpfnase + (`Blue NIL + +1.20 0.00 +0.60 + +1.80 -0.30 +0.30 + +1.80 +0.30 +0.30 ) + (`Blue NIL + +1.20 0.00 +0.60 + +1.20 -0.45 +0.30 + +1.80 -0.30 +0.30 ) + (`Blue NIL + +1.80 +0.30 +0.30 + +1.20 +0.45 +0.30 + +1.20 0.00 +0.60 ) + (`Blue NIL + +1.20 -0.45 +0.30 + +1.20 -0.45 -0.30 + +1.80 -0.30 -0.30 + +1.80 -0.30 +0.30 ) + (`Blue NIL + +1.80 +0.30 +0.30 + +1.80 +0.30 -0.30 + +1.20 +0.45 -0.30 + +1.20 +0.45 +0.30 ) + (`Blue NIL + +1.20 -0.45 -0.30 + +1.20 -0.30 -0.60 + +1.80 -0.30 -0.30 ) + (`Blue NIL + +1.80 +0.30 -0.30 + +1.20 +0.30 -0.60 + +1.20 +0.45 -0.30 ) + (`Blue NIL + +1.20 -0.30 -0.60 + +1.20 +0.30 -0.60 + +1.80 +0.30 -0.30 + +1.80 -0.30 -0.30 ) + + # Rumpfseite rechts + (`Red NIL + +1.20 +0.45 +0.30 + +1.20 +0.45 -0.30 + -1.50 +0.45 -0.30 + -1.50 +0.45 +0.30 + -1.20 +0.45 +0.45 + -0.90 +0.45 +0.45 ) + (`Red NIL + -1.50 +0.45 +0.30 + -1.50 +0.45 -0.30 + -4.80 0.00 -0.30 + -4.80 0.00 0.00 ) + + # Rumpfseite links + (`Red NIL + -0.90 -0.45 +0.45 + -1.20 -0.45 +0.45 + -1.50 -0.45 +0.30 + -1.50 -0.45 -0.30 + +1.20 -0.45 -0.30 + +1.20 -0.45 +0.30 ) + (`Red NIL + -4.80 0.00 0.00 + -4.80 0.00 -0.30 + -1.50 -0.45 -0.30 + -1.50 -0.45 +0.30 ) + + # Rumpfoberteil vorne + (`Red NIL + +1.20 0.00 +0.60 + +1.20 +0.45 +0.30 + -0.90 +0.45 +0.45 + -0.60 0.00 +0.60 ) + (`Red NIL + -0.60 0.00 +0.60 + -0.90 -0.45 +0.45 + +1.20 -0.45 +0.30 + +1.20 0.00 +0.60 ) + + # Cockpit + (`Brown NIL + -0.60 0.00 +0.60 + -0.90 +0.45 +0.45 + -0.90 -0.45 +0.45 ) + (`Black NIL + -0.90 +0.45 +0.45 + -1.20 +0.45 +0.45 + -1.20 -0.45 +0.45 + -0.90 -0.45 +0.45 ) + (`Black NIL + -1.20 +0.45 +0.45 + -1.35 0.00 +0.54 + -1.20 -0.45 +0.45 ) + + # Rumpfoberteil hinten + (`Red NIL + -1.35 0.00 +0.54 + -1.20 +0.45 +0.45 + -4.80 0.00 0.00 ) + (`Red NIL + -1.20 +0.45 +0.45 + -1.50 +0.45 +0.30 + -4.80 0.00 0.00 ) + (`Red NIL + -4.80 0.00 0.00 + -1.20 -0.45 +0.45 + -1.35 0.00 +0.54 ) + (`Red NIL + -4.80 0.00 0.00 + -1.50 -0.45 +0.30 + -1.20 -0.45 +0.45 ) + + # Rumpfboden + (`Red NIL + +1.20 +0.45 -0.30 + +1.20 +0.30 -0.60 + -1.50 +0.30 -0.60 + -1.50 +0.45 -0.30 ) + (`Red NIL + +1.20 +0.30 -0.60 + +1.20 -0.30 -0.60 + -1.50 -0.30 -0.60 + -1.50 +0.30 -0.60 ) + (`Red NIL + -1.50 -0.45 -0.30 + -1.50 -0.30 -0.60 + +1.20 -0.30 -0.60 + +1.20 -0.45 -0.30 ) + (`Red NIL + -4.80 0.00 -0.30 + -1.50 -0.30 -0.60 + -1.50 -0.45 -0.30 ) + (`Red NIL + -4.80 0.00 -0.30 + -1.50 +0.30 -0.60 + -1.50 -0.30 -0.60 ) + (`Red NIL + -1.50 +0.45 -0.30 + -1.50 +0.30 -0.60 + -4.80 0.00 -0.30 ) + + # Hoehenleitwerk + (`Red `Red + -3.60 +0.15 0.00 + -4.20 +1.80 0.00 + -4.50 +1.80 0.00 + -4.50 +0.06 0.00 ) + (`Red `Red + -4.50 -0.06 0.00 + -4.50 -1.80 0.00 + -4.20 -1.80 0.00 + -3.60 -0.15 0.00 ) + + # Hoehenruder + (elevator -4.50 0.00 0.00 + (`Blue `Blue + 0.00 +1.80 0.00 + -0.60 +1.50 0.00 + -0.60 +0.60 0.00 + 0.00 +0.06 0.00 ) + (`Blue `Blue + 0.00 -0.06 0.00 + -0.60 -0.60 0.00 + -0.60 -1.50 0.00 + 0.00 -1.80 0.00 ) ) + + # Seitenleitwerk + (`Red `Red + -4.80 0.00 0.00 + -3.60 0.00 +0.15 + -4.20 0.00 +0.90 + -4.80 0.00 +1.05 ) + + # Seitenruder + (rudder -4.80 0.00 0.00 + (`Blue `Blue + 0.00 0.00 +1.05 + 0.00 0.00 -0.30 + -0.45 0.00 +0.30 + -0.45 0.00 +0.90 ) ) + + # Schatten Nase + (NIL T + +0.90 -0.30 -0.20 + +1.70 0.00 -0.20 + +0.90 +0.30 -0.20 ) + + # Schatten Flaechen + (NIL T + +0.90 -3.00 -0.20 + +0.90 +3.00 -0.20 + -0.90 +3.00 -0.20 + -0.90 -3.00 -0.20 ) + + # Schatten Rumpf + (NIL T + -0.90 -0.40 -0.20 + -0.90 +0.40 -0.20 + -4.70 0.00 -0.20 ) + + # Schatten Leitwerk + (NIL T + -3.60 0.00 -0.20 + -4.20 +1.80 -0.20 + -4.50 +1.80 -0.20 + -4.50 -1.80 -0.20 + -4.20 -1.80 -0.20 ) + + # Spinner + (`Blue NIL + +1.80 +0.15 -0.15 + +1.80 +0.15 +0.15 + +2.10 0.00 0.00 ) + (`Blue NIL + +1.80 -0.15 -0.15 + +1.80 +0.15 -0.15 + +2.10 0.00 0.00 ) + (`Blue NIL + +1.80 -0.15 +0.15 + +1.80 -0.15 -0.15 + +2.10 0.00 0.00 ) + (`Blue NIL + +1.80 +0.15 +0.15 + +1.80 -0.15 +0.15 + +2.10 0.00 0.00 ) + + # Fahrwerk + (`Grey `Grey + +1.20 +0.30 -0.60 + +1.20 +0.90 -1.47 + +1.20 +1.00 -1.47 + +1.20 +0.40 -0.60 ) + (`Grey `Grey + +1.20 -0.30 -0.60 + +1.20 -0.90 -1.47 + +1.20 -1.00 -1.47 + +1.20 -0.40 -0.60 ) + (`Grey `Grey + +1.20 -1.20 -1.47 + +1.20 -1.20 -1.53 + +1.20 +1.20 -1.53 + +1.20 +1.20 -1.47 ) + (`Grey `Grey + +1.20 +0.90 -1.53 + +1.20 +0.90 -1.47 + +0.30 +0.30 -0.60 + +0.18 +0.30 -0.60 ) + (`Grey `Grey + +1.20 -0.90 -1.53 + +1.20 -0.90 -1.47 + +0.30 -0.30 -0.60 + +0.18 -0.30 -0.60 ) + + # Rad rechts + (`Yellow `Yellow + +1.20 +1.20 -1.20 + +1.38 +1.20 -1.25 + +1.50 +1.20 -1.37 + +1.55 +1.20 -1.55 + +1.50 +1.20 -1.73 + +1.38 +1.20 -1.85 + +1.20 +1.20 -1.90 + +1.02 +1.20 -1.85 + +0.90 +1.20 -1.72 + +0.85 +1.20 -1.55 + +0.90 +1.20 -1.37 + +1.02 +1.20 -1.25 ) + + # Schatten Rad rechts + (NIL T + +1.60 +1.00 -1.55 + +1.60 +1.40 -1.55 + +0.80 +1.40 -1.55 + +0.80 +1.00 -1.55 ) + + # Rad links + (`Yellow `Yellow + +1.20 -1.20 -1.20 + +1.38 -1.20 -1.25 + +1.50 -1.20 -1.37 + +1.55 -1.20 -1.55 + +1.50 -1.20 -1.73 + +1.38 -1.20 -1.85 + +1.20 -1.20 -1.90 + +1.02 -1.20 -1.85 + +0.90 -1.20 -1.72 + +0.85 -1.20 -1.55 + +0.90 -1.20 -1.37 + +1.02 -1.20 -1.25 ) + + # Schatten Rad links + (NIL T + +1.60 -1.00 -1.55 + +1.60 -1.40 -1.55 + +0.80 -1.40 -1.55 + +0.80 -1.00 -1.55 ) + + # Latte + (propeller +1.95 0.00 0.00) ) ) + +(model This + '(blade +1.95 0.00 0.00 + (`Black `Black + -0.05 0.00 0.00 + +0.05 0.00 0.00 + +0.02 +0.40 -0.50 + +0.00 +0.90 -0.90 + -0.02 +0.50 -0.40 + -0.05 0.00 0.00 + -0.02 -0.50 +0.40 + +0.00 -0.90 +0.90 + +0.02 -0.40 +0.50 + +0.05 0.00 0.00 ) ) ) + +(model This + '(disk +1.95 0.00 0.00 + (NIL NIL + +0.00 -0.30 +1.20 + +0.00 -0.90 +0.90 + +0.00 -1.20 +0.30 + +0.00 -1.20 -0.30 + +0.00 -0.90 -0.90 + +0.00 -0.30 -1.20 + +0.00 +0.30 -1.20 + +0.00 +0.90 -0.90 + +0.00 +1.20 -0.30 + +0.00 +1.20 +0.30 + +0.00 +0.90 +0.90 + +0.00 +0.30 +1.20 ) ) ) + +(z3d:Yrot 0.26 (: body)) diff --git a/rcsim/lib.l b/rcsim/lib.l @@ -0,0 +1,255 @@ +# 26aug09abu +# (c) Software Lab. Alexander Burger + +# *Pilot *Scene *Model +# *DT *Thr *Speed *Climb *Alt + +(load "simul/lib.l") + +(de *DT . 0.020) +(de *Tower . 12.0) + +(de start () + (task -20 0 (simulate)) + (setq "Time" (time)) ) + +(de stop () + (task -20) ) + +(de draw () + (at (0 . 100) + (let N (time) + (rate> *Pilot (- N "Time")) + (setq "Time" N) ) ) + (draw> *Scene) ) + +(de simulate () + (sim> *Scene) + (sim> *Model) ) + +(de MUL Args + (let D 1.0 + (make + (link '*/ (pop 'Args) (pop 'Args)) + (while Args + (setq D (* D 1.0)) + (link (pop 'Args)) ) + (link D) ) ) ) + +(de dist (X Y) + (sqrt (+ (* X X) (* Y Y))) ) + +(de damp ("Var" Val) + (set "Var" (>> 1 (+ Val (val "Var")))) ) + +(de doppler (F X Y VX VY) + (let N (dist X Y) + (if (=0 N) + F + (- F + (*/ F + (+ `(MUL X VX) `(MUL Y VY)) + (* N 150) ) ) ) ) ) + + +(class +Model) +# mass power rc lc limit tx tz pitch torq stab +# body leftAileron rightAileron rudder elevator propeller blade disk +# ele ail rud thr thrust vx vy vz fx fy fz dx dy dz + +(dm T () + (load "rcsim/fokker.l") + (=: ele (=: ail (=: rud (=: thr (=: thrust 0))))) + (=: vx (=: vy (=: vz 0))) + (=: fx (=: fy (=: fz 0))) + (=: dx (=: dy (=: dz 0))) + (z3d:dx -100.0 (: body)) + (z3d:dy -200.0 (: body)) + (blade> This) ) + +(dm dir> () + (let B (val (: body)) + (z3d:Spot + (+ (car B) (>> 3 (: vx)) (>> 2 (: vz))) + (+ (cadr B) (>> 3 (: vy)) (>> 2 (: vz))) + (+ (caddr B) (>> 3 (: vz)) (>> 2 (: vz))) + 0 0 *Tower ) ) ) + +(dm blade> () + (set (: propeller) (val (: blade))) ) + +(dm disk> () + (set (: propeller) (val (: disk))) ) + + +(dm down> () + (when (> (: ele) -100) + (dec (:: ele) 20) + (z3d:Arot +0.2 (: elevator)) ) ) + +(dm up> () + (when (> 100 (: ele)) + (inc (:: ele) 20) + (z3d:Arot -0.2 (: elevator)) ) ) + +(dm left> () + (when (> (: ail) -100) + (dec (:: ail) 20) + (dec (:: rud) 20) + (z3d:Arot +0.2 (: leftAileron)) + (z3d:Arot +0.2 (: rightAileron)) + (z3d:Arot +0.2 (: rudder)) ) ) + +(dm right> () + (when (> 100 (: ail)) + (inc (:: ail) 20) + (inc (:: rud) 20) + (z3d:Arot -0.2 (: leftAileron)) + (z3d:Arot -0.2 (: rightAileron)) + (z3d:Arot -0.2 (: rudder)) ) ) + +(dm throt> (X) + (=: thr + (cond + ((not X) 0) + ((=T X) 100) + ((lt0 X) (max 10 (- (: thr) 25))) + ((=0 (: thr)) 10) + ((= 10 (: thr)) 25) + (T (min 100 (+ 25 (: thr)))) ) ) ) + +(dm sim> () + (cond + ((gt0 (: ele)) + (dec (:: ele)) + (z3d:Arot +0.01 (: elevator)) ) + ((lt0 (: ele)) + (inc (:: ele)) + (z3d:Arot -0.01 (: elevator)) ) ) + (cond + ((gt0 (: ail)) + (dec (:: ail)) + (dec (:: rud)) + (z3d:Arot +0.01 (: leftAileron)) + (z3d:Arot +0.01 (: rightAileron)) + (z3d:Arot +0.01 (: rudder)) ) + ((lt0 (: ail)) + (inc (:: ail)) + (inc (:: rud)) + (z3d:Arot -0.01 (: leftAileron)) + (z3d:Arot -0.01 (: rightAileron)) + (z3d:Arot -0.01 (: rudder)) ) ) + (cond + ((> (: thr) (: thrust)) + (inc (:: thrust)) ) + ((> (: thrust) (: thr)) + (dec (:: thrust)) ) ) + (if (> 20 (: thrust)) + (blade> This) + (disk> This) ) + (unless (=0 (: thrust)) + (z3d:Xrot 0.2 (: propeller)) ) + (use (Touch VX VY VZ Body Taxi Stick A FX FY FZ DX DY DZ) + (z3d:Rotate (: tx) 0 (: tz) (: body) NIL NIL 'Touch) + (z3d:Rotate (: vx) (: vy) (: vz) (: body) 'VX 'VY 'VZ T) + (setq + Body (val (: body)) + Taxi (> 0.1 (+ (caddr Body) Touch)) + Stick (>= 1.0 (+ VX VY)) + FX (+ (*/ (: thrust) (: power) 100) `(MUL (: rc) VX (abs VX))) + FZ (+ + (cond + ((> 0.1 VX) 0) + ((> (abs (setq A (*/ 1.0 VZ VX))) (: lim2)) + 0 ) + ((>= (: lim1) A) + `(MUL VX VX (: lc) A) ) + (T `(MUL VX VX (: lc) (- (: lim2) A))) ) + `(MUL 8.0 (: rc) VZ (abs VZ)) ) ) + + (ifn Taxi + (setq FY `(MUL 4.0 (: rc) VY (abs VY))) + (let F (>> 2 (: mass)) + (cond + ((> 0.1 (abs VX)) + (and (>= F FX) (zero FX)) ) + ((gt0 VX) + (dec 'FX F) ) + (T (inc 'FX F)) ) + (setq FY (if (lt0 VY) (* 12 F) (* -12 F))) ) + (z3d:Yrot + (>> 3 (- (: pitch) (get Body 6))) # rot.a.z + (: body) ) ) + (unless Stick + (z3d:Yrot + (+ + (*/ VX (+ (: ele) (: trim)) 80000) + `(MUL VZ (: stab 2)) ) + (: body) ) + (if Taxi + (prog + (z3d:Zrot (*/ VX (: rud) 80000) (: body)) + (z3d:Xrot (get Body 9) (: body)) ) # rot.b.z + (z3d:Xrot # roll + (+ + (- (*/ VX (: ail) 80000) (/ VY 400)) + (*/ (: thrust) (: torq) (: mass)) + `(MUL (get Body 9) (: stab 1)) ) # rot.b.z + (: body) ) + (z3d:Zrot + (+ + (*/ VX (: rud) 80000) + `(MUL VY (: stab 3)) ) + (: body) ) ) ) + + # World system + (z3d:Rotate FX FY FZ (: body) 'FX 'FY 'FZ) + (dec 'FZ `(MUL (: mass) 9.81)) + + # Accelerate + (setq + A (*/ 1.0 *DT (: mass)) + DX `(MUL A (damp (:: fx) FX)) + DY `(MUL A (damp (:: fy) FY)) + DZ `(MUL A (damp (:: fz) FZ)) ) + (if (and Stick (> 0.001 (+ `(MUL DX DX) `(MUL DY DY)))) + (=: vx (=: vy (=: dx (=: dy 0)))) + (inc (:: vx) (damp (:: dx) DX)) + (inc (:: vy) (damp (:: dy) DY)) ) + (inc (:: vz) (damp (:: dz) DZ)) + (when (and Taxi (lt0 (: vz))) + (when (> -6.0 (: vz)) + (=: thr (=: thrust 0)) + (=: vx (=: vy 0)) + (blade> This) ) + (set (cddr Body) (- Touch)) + (=: vz 0) ) + + # Translate + (inc Body `(MUL (: vx) *DT)) + (inc (cdr Body) `(MUL (: vy) *DT)) + (inc (cddr Body) `(MUL (: vz) *DT)) + + # Sound/Display + (tone> *Scene + (max 0 + (- 100 + (/ (dist (car Body) (cadr Body)) 40.0) ) ) + (cond + ((=0 (: thrust)) 0) + ((> 22 (: thrust)) 11) + (T + (doppler + (>> 1 (+ (: thrust) (/ VX 0.5))) + (car Body) + (cadr Body) + (: vx) + (: vy) ) ) ) ) + (unless (= *Thr (: thr)) + (thr> *Pilot (setq *Thr (: thr))) ) + (unless (= *Speed (setq A (*/ VX 3.6 `(* 1.0 1.0)))) + (speed> *Pilot (setq *Speed A)) ) + (unless (= *Climb (setq A (/ (: vz) 1.0))) + (climb> *Pilot (setq *Climb A)) ) + (unless (= *Alt (setq A (/ (caddr Body) 1.0))) + (alt> *Pilot (setq *Alt A)) ) ) ) diff --git a/rcsim/main.l b/rcsim/main.l @@ -0,0 +1,124 @@ +# 24jul07abu +# (c) Software Lab. Alexander Burger + +# *Sock *Panel *FocLen + +(load "lib/term.l") +(load "rcsim/lib.l") + + +(de main () + (setq + *FocLen 8000.0 + *Pilot (new '(+Pilot)) + *Scene (new '(+Scene)) + *Model (new '(+Model)) + *Panel (list + 0 " % " + 0 " km/h " + 0 " m/s " + 0 " m " + NIL ) ) + (push1 '*Bye '(tone> *Scene 0 0)) ) + +(de setPanel (N X) + (set (nth *Panel N) X) + (prinl *Panel) ) + +(de go () + (out (setq *Sock (listen (port 8080) 120000)) + (pr 800 600) ) + (start) + (draw) + (task *Sock + (in *Sock + (case (rd) + (`(char "o") # ok + (draw) ) + (`(char "c") # clk + (rd) (rd) ) ) ) ) ) + +# Key Controls +(fkey *XtIns + (when (> 32000.0 *FocLen) + (setq *FocLen (>> -1 *FocLen)) ) ) + +(fkey *XtDel + (when (> *FocLen 2000.0) + (setq *FocLen (>> 1 *FocLen)) ) ) + +(fkey *XtUp + (down> *Model) ) + +(fkey *XtDown + (up> *Model) ) + +(fkey *XtLeft + (left> *Model) ) + +(fkey *XtRight + (right> *Model) ) + +(fkey *XtHome + (throt> *Model T) ) + +(fkey *XtPgDn + (throt> *Model -1) ) + +(fkey *XtPgUp + (throt> *Model +1) ) + +(fkey *XtEnd + (throt> *Model) ) + +(fkey *XtF3 ~(get (fkey) *XtDel)) +(fkey *XtF4 ~(get (fkey) *XtIns)) +(fkey *XtF5 ~(get (fkey) *XtEnd)) +(fkey *XtF6 ~(get (fkey) *XtPgDn)) +(fkey *XtF7 ~(get (fkey) *XtPgUp)) +(fkey *XtF8 ~(get (fkey) *XtHome)) + + +# Pilot +(class +Pilot) + +(dm thr> (N) + (setPanel 1 N) ) + +(dm speed> (N) + (setPanel 3 N) ) + +(dm climb> (N) + (setPanel 5 N) ) + +(dm alt> (N) + (setPanel 7 N) ) + +(dm rate> (N) + (setPanel 9 (pack (format N 2) " s")) ) + + +# Scene +(class +Scene) +# env tone + +(dm T () + (load "rcsim/env.l") + (when (call 'test "-p" "fifo/tone") + (=: tone (open "fifo/tone")) ) ) + +(dm sim> ()) + +(dm draw> () + (out *Sock + (let Dir (dir> *Model) + (z3d:Draw *FocLen (car Dir) (cdr Dir) 0 0 *Tower LightBlue DarkGreen) + (z3d:Draw (get *Model 'body)) + (mapc z3d:Draw (: env)) + (z3d:Draw) ) ) ) + +(dm tone> (A F) + (when (: tone) + (out @ (pr A (*/ F 22 10))) ) ) + +# vi:et:ts=3:sw=3 diff --git a/rcsim/tone b/rcsim/tone @@ -0,0 +1,41 @@ +#!bin/picolisp lib.l +# 13oct06abu +# (c) Software Lab. Alexander Burger + +# Must be run on a virtual console + +(load "lib/misc.l" "lib/gcc.l") + +### 'ioctl' glue function +(gcc "tst" NIL 'tone) + +#include <sys/ioctl.h> +#include <linux/kd.h> // KIOCSOUND + +// (tone 'freq) -> flg +any tone(any ex) { + long amp = evCnt(ex,cdr(ex)); + long freq = evCnt(ex,cddr(ex)); + + return ioctl(0, KIOCSOUND, amp==0 || freq==0? 0 : 1193180L/freq) < 0? Nil : T; +} + +/**/ + +### Create named pipe +(unless (call 'test "-p" "fifo/tone") + (call 'mkdir "-p" "fifo") + (call 'mkfifo "fifo/tone") ) + +(push1 '*Bye '(call 'rm "fifo/tone")) + + +### Serve calls like: +# (setq *Tone (open "fifo/tone")) +# (out *Tone (pr 100 440)) # 440 Hz +# (out *Tone (pr 0 0)) # Off +# (close *Tone) +(loop + (in "fifo/tone" + (while (rd) + (tone @ (rd)) ) ) ) diff --git a/simul/lib.l b/simul/lib.l @@ -0,0 +1,90 @@ +# 18mar10abu +# (c) Software Lab. Alexander Burger + +(scl 6) # Keep in sync with `SCL' in "src/z3d.c" + +(load "lib/simul.l") +(load "simul/rgb.l") + +# Unity Matrix +(setq + *UMat (1.0 0.0 0.0 0.0 1.0 0.0 0.0 0.0 1.0) + PI 3.1415927 + PI/2 1.5707963 ) + +# Mirror in y-direction +(de y-mirror (Lst) + (make + (while (sym? (car Lst)) + (link (pop 'Lst)) ) + (link + (pop 'Lst) # pos-x + (- (pop 'Lst)) # pos-y + (pop 'Lst) ) # pos-z + (for L Lst + (link + (if (sym? (car L)) + (y-mirror L) + (make + (link (cadr L) (car L)) + (when (sym? (car (setq L (cddr L)))) + (link (pop 'L)) ) + (while L + (link (pop 'L) (- (pop 'L)) (pop 'L)) ) ) ) ) ) ) ) + +# Create model +(de model (Obj Lst) + (let X Obj + (while (sym? (cadr Lst)) + (setq X (get X (pop 'Lst))) ) + (unless X + (quit "Can't attach (sub)model" (car Lst)) ) + (prog1 + (put X (pop 'Lst) (new (ext? Obj))) + (set @ + (make + (link (pop 'Lst) (pop 'Lst) (pop 'Lst)) + (mapc link *UMat) + (for M Lst + (link + (if (and (car M) (sym? (car M))) + (model Obj M) + M ) ) ) ) ) ) ) ) + +# Duplicate position and orientation +(de placement (Sym) + (prog1 + (new (ext? Sym)) + (set @ + (conc + (head 12 (val Sym)) + (mapcan + '((X) + (and + (sym? X) + (list (placement X)) ) ) + (nth (val Sym) 13) ) ) ) ) ) + +# Reset orientation +(de straight (M) + (touch M) + (map + '((V L) (set L (car V))) + *UMat + (cdddr (val M)) ) ) + +# Movements +(de z3d:dx (X M) + (touch M) + (set (val M) + (+ X (car (val M))) ) ) + +(de z3d:dy (Y M) + (touch M) + (set (cdr (val M)) + (+ Y (cadr (val M))) ) ) + +(de z3d:dz (Z M) + (touch M) + (set (cddr (val M)) + (+ Z (caddr (val M))) ) ) diff --git a/simul/rgb.l b/simul/rgb.l @@ -0,0 +1,29 @@ +# 02sep99abu +# (c) Software Lab. Alexander Burger + +(de rgb (R G B . S) + (def S (+ B (* G 256) (* R 65536))) ) + +# Color Constant Definitions from "/usr/lib/X11/rgb.txt" +(rgb 0 0 0 . Black) +(rgb 0 0 255 . Blue) +(rgb 165 42 42 . Brown) +(rgb 0 100 0 . DarkGreen) +(rgb 169 169 169 . DarkGrey) +(rgb 190 190 190 . Grey) +(rgb 173 216 230 . LightBlue) +(rgb 211 211 211 . LightGrey) +(rgb 255 0 0 . Red) +(rgb 46 139 87 . SeaGreen) +(rgb 255 255 0 . Yellow) + +(rgb 255 193 193 . RosyBrown1) +(rgb 238 180 180 . RosyBrown2) +(rgb 205 155 155 . RosyBrown3) +(rgb 139 105 105 . RosyBrown4) + +(rgb 221 160 221 . Plum) +(rgb 135 206 250 . LightSkyBlue) +(rgb 245 222 179 . Wheat) +(rgb 255 255 255 . White) +(rgb 139 0 0 . DarkRed) diff --git a/src/Makefile b/src/Makefile @@ -0,0 +1,145 @@ +# 09dec09abu +# 27feb08rdo +# (c) Software Lab. Alexander Burger + +bin = ../bin +lib = ../lib + +picoFiles = main.c gc.c apply.c flow.c sym.c subr.c big.c io.c net.c tab.c + +CFLAGS := -c -O2 -m32 -pipe \ + -falign-functions -fomit-frame-pointer -fno-strict-aliasing \ + -W -Wimplicit -Wreturn-type -Wunused -Wformat \ + -Wuninitialized -Wstrict-prototypes \ + -D_GNU_SOURCE -D_FILE_OFFSET_BITS=64 + + +ifeq ($(shell uname), Linux) + OS = Linux + PICOLISP-FLAGS = -m32 -rdynamic + LIB-FLAGS = -lc -lm -ldl + DYNAMIC-LIB-FLAGS = -m32 -shared -export-dynamic + STRIP = strip +else +ifeq ($(shell uname), OpenBSD) + OS = OpenBSD + PICOLISP-FLAGS = -m32 -rdynamic + LIB-FLAGS = -lc -lm + DYNAMIC-LIB-FLAGS = -m32 -shared -export-dynamic + STRIP = strip +else +ifeq ($(shell uname), FreeBSD) + OS = FreeBSD + PICOLISP-FLAGS = -m32 -rdynamic + LIB-FLAGS = -lc -lm + DYNAMIC-LIB-FLAGS = -m32 -shared -export-dynamic + STRIP = strip +else +ifeq ($(shell uname), NetBSD) + OS = NetBSD + PICOLISP-FLAGS = -m32 -rdynamic + LIB-FLAGS = -lc -lm + DYNAMIC-LIB-FLAGS = -m32 -shared -export-dynamic + STRIP = strip +else +ifeq ($(shell uname), Darwin) + OS = Darwin + PICOLISP-FLAGS = -m32 + LIB-FLAGS = -lc -lm -ldl + DYNAMIC-LIB-FLAGS = -m32 -dynamiclib -undefined dynamic_lookup + STRIP = : +else +ifeq ($(shell uname -o), Cygwin) + OS = Cygwin + DYNAMIC-LIB-FLAGS = -shared + PICOLISP-FLAGS = + DLL-DEFS = $(bin)/picolisp.dll + STRIP = strip + exe = .exe + dll = .dll +endif +endif +endif +endif +endif +endif + + +picolisp: $(bin)/picolisp $(lib)/ext$(dll) $(lib)/ht$(dll) $(lib)/z3d$(dll) +tools: $(bin)/lat1 $(bin)/utf2 $(bin)/balance +gate: $(bin)/ssl $(bin)/httpGate +x11: $(bin)/z3dClient + +all: picolisp tools gate x11 + +.c.o: + gcc $(CFLAGS) -D_OS='"$(OS)"' $*.c + + +$(picoFiles:.c=.o) ext.o ht.o z3d.o: pico.h + + +ifeq ($(OS), Cygwin) + +$(bin)/picolisp$(dll): $(picoFiles:.c=.o) + gcc -o $(bin)/picolisp$(dll) $(DYNAMIC-LIB-FLAGS) $(picoFiles:.c=.o) + $(STRIP) $(bin)/picolisp$(dll) + +$(bin)/picolisp: $(picoFiles:.c=.o) $(bin)/picolisp$(dll) start.o + mkdir -p $(bin) $(lib) + gcc -o $(bin)/picolisp$(exe) $(PICOLISP-FLAGS) start.o -L$(bin) -l$(bin)/picolisp + $(STRIP) $(bin)/picolisp$(exe) + +else + +$(bin)/picolisp: $(picoFiles:.c=.o) + mkdir -p $(bin) $(lib) + gcc -o $(bin)/picolisp$(exe) $(PICOLISP-FLAGS) $(picoFiles:.c=.o) $(LIB-FLAGS) + $(STRIP) $(bin)/picolisp$(exe) + +endif + + +$(lib)/ext$(dll): ext.o + gcc -o $(lib)/ext$(dll) $(DYNAMIC-LIB-FLAGS) ext.o $(DLL-DEFS) + $(STRIP) $(lib)/ext$(dll) + +$(lib)/ht$(dll): ht.o + gcc -o $(lib)/ht$(dll) $(DYNAMIC-LIB-FLAGS) ht.o $(DLL-DEFS) + $(STRIP) $(lib)/ht$(dll) + +$(lib)/z3d$(dll): z3d.o + gcc -o $(lib)/z3d$(dll) $(DYNAMIC-LIB-FLAGS) z3d.o $(DLL-DEFS) + $(STRIP) $(lib)/z3d$(dll) + + +$(bin)/lat1: lat1.o + gcc -m32 -o $(bin)/lat1$(exe) lat1.o + $(STRIP) $(bin)/lat1$(exe) + +$(bin)/utf2: utf2.o + gcc -m32 -o $(bin)/utf2$(exe) utf2.o + $(STRIP) $(bin)/utf2$(exe) + +$(bin)/balance: balance.o + gcc -m32 -o $(bin)/balance$(exe) balance.o + $(STRIP) $(bin)/balance$(exe) + +$(bin)/ssl: ssl.o + gcc -m32 -o $(bin)/ssl$(exe) ssl.o -lssl -lcrypto + $(STRIP) $(bin)/ssl$(exe) + +$(bin)/httpGate: httpGate.o + gcc -m32 -o $(bin)/httpGate$(exe) httpGate.o -lssl -lcrypto + $(STRIP) $(bin)/httpGate$(exe) + +$(bin)/z3dClient: z3dClient.o + gcc -m32 -o $(bin)/z3dClient$(exe) z3dClient.o -L/usr/X11R6/lib -lXext -lX11 + $(STRIP) $(bin)/z3dClient$(exe) + + +# Clean up +clean: + rm -f *.o + +# vi:noet:ts=4:sw=4 diff --git a/src/apply.c b/src/apply.c @@ -0,0 +1,676 @@ +/* 06jun09abu + * (c) Software Lab. Alexander Burger + */ + +#include "pico.h" + +any apply(any ex, any foo, bool cf, int n, cell *p) { + while (!isNum(foo)) { + if (isCell(foo)) { + int i; + any x = car(foo); + struct { // bindFrame + struct bindFrame *link; + int i, cnt; + struct {any sym; any val;} bnd[length(x)+2]; + } f; + + f.link = Env.bind, Env.bind = (bindFrame*)&f; + f.i = 0; + f.cnt = 1, f.bnd[0].sym = At, f.bnd[0].val = val(At); + while (isCell(x)) { + f.bnd[f.cnt].val = val(f.bnd[f.cnt].sym = car(x)); + val(f.bnd[f.cnt].sym) = --n<0? Nil : cf? car(data(p[f.cnt-1])) : data(p[f.cnt-1]); + ++f.cnt, x = cdr(x); + } + if (isNil(x)) + x = prog(cdr(foo)); + else if (x != At) { + f.bnd[f.cnt].sym = x, f.bnd[f.cnt++].val = val(x), val(x) = Nil; + x = prog(cdr(foo)); + } + else { + int cnt = n; + int next = Env.next; + cell *arg = Env.arg; + cell c[Env.next = n]; + + Env.arg = c; + for (i = f.cnt-1; --n >= 0; ++i) + Push(c[n], cf? car(data(p[i])) : data(p[i])); + x = prog(cdr(foo)); + if (cnt) + drop(c[cnt-1]); + Env.arg = arg, Env.next = next; + } + while (--f.cnt >= 0) + val(f.bnd[f.cnt].sym) = f.bnd[f.cnt].val; + Env.bind = f.link; + return x; + } + if (val(foo) == val(Meth)) { + any expr, o, x; + + o = cf? car(data(p[0])) : data(p[0]); + NeedSym(ex,o); + Fetch(ex,o); + TheKey = foo, TheCls = Nil; + if (expr = method(o)) { + int i; + methFrame m; + struct { // bindFrame + struct bindFrame *link; + int i, cnt; + struct {any sym; any val;} bnd[length(x = car(expr))+3]; + } f; + + m.link = Env.meth; + m.key = TheKey; + m.cls = TheCls; + f.link = Env.bind, Env.bind = (bindFrame*)&f; + f.i = 0; + f.cnt = 1, f.bnd[0].sym = At, f.bnd[0].val = val(At); + --n, ++p; + while (isCell(x)) { + f.bnd[f.cnt].val = val(f.bnd[f.cnt].sym = car(x)); + val(f.bnd[f.cnt].sym) = --n<0? Nil : cf? car(data(p[f.cnt-1])) : data(p[f.cnt-1]); + ++f.cnt, x = cdr(x); + } + if (isNil(x)) { + f.bnd[f.cnt].sym = This; + f.bnd[f.cnt++].val = val(This); + val(This) = o; + Env.meth = &m; + x = prog(cdr(expr)); + } + else if (x != At) { + f.bnd[f.cnt].sym = x, f.bnd[f.cnt++].val = val(x), val(x) = Nil; + f.bnd[f.cnt].sym = This; + f.bnd[f.cnt++].val = val(This); + val(This) = o; + Env.meth = &m; + x = prog(cdr(expr)); + } + else { + int cnt = n; + int next = Env.next; + cell *arg = Env.arg; + cell c[Env.next = n]; + + Env.arg = c; + for (i = f.cnt-1; --n >= 0; ++i) + Push(c[n], cf? car(data(p[i])) : data(p[i])); + f.bnd[f.cnt].sym = This; + f.bnd[f.cnt++].val = val(This); + val(This) = o; + Env.meth = &m; + x = prog(cdr(expr)); + if (cnt) + drop(c[cnt-1]); + Env.arg = arg, Env.next = next; + } + while (--f.cnt >= 0) + val(f.bnd[f.cnt].sym) = f.bnd[f.cnt].val; + Env.bind = f.link; + Env.meth = Env.meth->link; + return x; + } + err(ex, o, "Bad object"); + } + if (isNil(val(foo)) || foo == val(foo)) + undefined(foo,ex); + foo = val(foo); + } + if (--n < 0) + cdr(ApplyBody) = Nil; + else { + any x = ApplyArgs; + val(caar(x)) = cf? car(data(p[n])) : data(p[n]); + while (--n >= 0) { + if (!isCell(cdr(x))) + cdr(x) = cons(cons(consSym(Nil,Nil), car(x)), Nil); + x = cdr(x); + val(caar(x)) = cf? car(data(p[n])) : data(p[n]); + } + cdr(ApplyBody) = car(x); + } + return evSubr(foo, ApplyBody); +} + +// (apply 'fun 'lst ['any ..]) -> any +any doApply(any ex) { + any x, y; + int i, n; + cell foo; + + x = cdr(ex), Push(foo, EVAL(car(x))); + x = cdr(x), y = EVAL(car(x)); + { + cell c[(n = length(cdr(x))) + length(y)]; + + while (isCell(y)) + Push(c[n], car(y)), y = cdr(y), ++n; + for (i = 0; isCell(x = cdr(x)); ++i) + Push(c[i], EVAL(car(x))); + x = apply(ex, data(foo), NO, n, c); + } + drop(foo); + return x; +} + +// (pass 'fun ['any ..]) -> any +any doPass(any ex) { + any x; + int n, i; + cell foo, c[length(cdr(x = cdr(ex))) + (Env.next>0? Env.next : 0)]; + + Push(foo, EVAL(car(x))); + for (n = 0; isCell(x = cdr(x)); ++n) + Push(c[n], EVAL(car(x))); + for (i = Env.next; --i >= 0; ++n) + Push(c[n], data(Env.arg[i])); + x = apply(ex, data(foo), NO, n, c); + drop(foo); + return x; +} + +// (maps 'fun 'sym ['lst ..]) -> any +any doMaps(any ex) { + any x; + int i, n; + cell foo, c[length(cdr(x = cdr(ex)))]; + + Push(foo, EVAL(car(x))); + x = cdr(x), Push(c[0], EVAL(car(x))); + NeedSym(ex, data(c[0])); + for (n = 1; isCell(x = cdr(x)); ++n) + Push(c[n], EVAL(car(x))); + Fetch(ex, data(c[0])); + data(c[0]) = tail1(data(c[0])); + while (isCell(data(c[0]))) { + x = apply(ex, data(foo), YES, n, c); + for (i = 0; i < n; ++i) + data(c[i]) = cdr(data(c[i])); + } + drop(foo); + return x; +} + +// (map 'fun 'lst ..) -> lst +any doMap(any ex) { + any x = cdr(ex); + cell foo; + + Push(foo, EVAL(car(x))); + if (isCell(x = cdr(x))) { + int i, n = 0; + cell c[length(x)]; + + do + Push(c[n], EVAL(car(x))), ++n; + while (isCell(x = cdr(x))); + while (isCell(data(c[0]))) { + x = apply(ex, data(foo), NO, n, c); + for (i = 0; i < n; ++i) + data(c[i]) = cdr(data(c[i])); + } + } + drop(foo); + return x; +} + +// (mapc 'fun 'lst ..) -> any +any doMapc(any ex) { + any x = cdr(ex); + cell foo; + + Push(foo, EVAL(car(x))); + if (isCell(x = cdr(x))) { + int i, n = 0; + cell c[length(x)]; + + do + Push(c[n], EVAL(car(x))), ++n; + while (isCell(x = cdr(x))); + while (isCell(data(c[0]))) { + x = apply(ex, data(foo), YES, n, c); + for (i = 0; i < n; ++i) + data(c[i]) = cdr(data(c[i])); + } + } + drop(foo); + return x; +} + +// (maplist 'fun 'lst ..) -> lst +any doMaplist(any ex) { + any x = cdr(ex); + cell res, foo; + + Push(res, Nil); + Push(foo, EVAL(car(x))); + if (isCell(x = cdr(x))) { + int i, n = 0; + cell c[length(x)]; + + do + Push(c[n], EVAL(car(x))), ++n; + while (isCell(x = cdr(x))); + if (!isCell(data(c[0]))) + return Pop(res); + data(res) = x = cons(apply(ex, data(foo), NO, n, c), Nil); + while (isCell(data(c[0]) = cdr(data(c[0])))) { + for (i = 1; i < n; ++i) + data(c[i]) = cdr(data(c[i])); + cdr(x) = cons(apply(ex, data(foo), NO, n, c), Nil); + x = cdr(x); + } + } + return Pop(res); +} + +// (mapcar 'fun 'lst ..) -> lst +any doMapcar(any ex) { + any x = cdr(ex); + cell res, foo; + + Push(res, Nil); + Push(foo, EVAL(car(x))); + if (isCell(x = cdr(x))) { + int i, n = 0; + cell c[length(x)]; + + do + Push(c[n], EVAL(car(x))), ++n; + while (isCell(x = cdr(x))); + if (!isCell(data(c[0]))) + return Pop(res); + data(res) = x = cons(apply(ex, data(foo), YES, n, c), Nil); + while (isCell(data(c[0]) = cdr(data(c[0])))) { + for (i = 1; i < n; ++i) + data(c[i]) = cdr(data(c[i])); + cdr(x) = cons(apply(ex, data(foo), YES, n, c), Nil); + x = cdr(x); + } + } + return Pop(res); +} + +// (mapcon 'fun 'lst ..) -> lst +any doMapcon(any ex) { + any x = cdr(ex); + cell res, foo; + + Push(res, Nil); + Push(foo, EVAL(car(x))); + if (isCell(x = cdr(x))) { + int i, n = 0; + cell c[length(x)]; + + do + Push(c[n], EVAL(car(x))), ++n; + while (isCell(x = cdr(x))); + if (!isCell(data(c[0]))) + return Pop(res); + while (!isCell(x = apply(ex, data(foo), NO, n, c))) { + if (!isCell(data(c[0]) = cdr(data(c[0])))) + return Pop(res); + for (i = 1; i < n; ++i) + data(c[i]) = cdr(data(c[i])); + } + data(res) = x; + while (isCell(data(c[0]) = cdr(data(c[0])))) { + for (i = 1; i < n; ++i) + data(c[i]) = cdr(data(c[i])); + while (isCell(cdr(x))) + x = cdr(x); + cdr(x) = apply(ex, data(foo), NO, n, c); + } + } + return Pop(res); +} + +// (mapcan 'fun 'lst ..) -> lst +any doMapcan(any ex) { + any x = cdr(ex); + cell res, foo; + + Push(res, Nil); + Push(foo, EVAL(car(x))); + if (isCell(x = cdr(x))) { + int i, n = 0; + cell c[length(x)]; + + do + Push(c[n], EVAL(car(x))), ++n; + while (isCell(x = cdr(x))); + if (!isCell(data(c[0]))) + return Pop(res); + while (!isCell(x = apply(ex, data(foo), YES, n, c))) { + if (!isCell(data(c[0]) = cdr(data(c[0])))) + return Pop(res); + for (i = 1; i < n; ++i) + data(c[i]) = cdr(data(c[i])); + } + data(res) = x; + while (isCell(data(c[0]) = cdr(data(c[0])))) { + for (i = 1; i < n; ++i) + data(c[i]) = cdr(data(c[i])); + while (isCell(cdr(x))) + x = cdr(x); + cdr(x) = apply(ex, data(foo), YES, n, c); + } + } + return Pop(res); +} + +// (filter 'fun 'lst ..) -> lst +any doFilter(any ex) { + any x = cdr(ex); + cell res, foo; + + Push(res, Nil); + Push(foo, EVAL(car(x))); + if (isCell(x = cdr(x))) { + int i, n = 0; + cell c[length(x)]; + + do + Push(c[n], EVAL(car(x))), ++n; + while (isCell(x = cdr(x))); + if (!isCell(data(c[0]))) + return Pop(res); + while (isNil(apply(ex, data(foo), YES, n, c))) { + if (!isCell(data(c[0]) = cdr(data(c[0])))) + return Pop(res); + for (i = 1; i < n; ++i) + data(c[i]) = cdr(data(c[i])); + } + data(res) = x = cons(car(data(c[0])), Nil); + while (isCell(data(c[0]) = cdr(data(c[0])))) { + for (i = 1; i < n; ++i) + data(c[i]) = cdr(data(c[i])); + if (!isNil(apply(ex, data(foo), YES, n, c))) + x = cdr(x) = cons(car(data(c[0])), Nil); + } + } + return Pop(res); +} + +// (extract 'fun 'lst ..) -> lst +any doExtract(any ex) { + any x = cdr(ex); + any y; + cell res, foo; + + Push(res, Nil); + Push(foo, EVAL(car(x))); + if (isCell(x = cdr(x))) { + int i, n = 0; + cell c[length(x)]; + + do + Push(c[n], EVAL(car(x))), ++n; + while (isCell(x = cdr(x))); + if (!isCell(data(c[0]))) + return Pop(res); + while (isNil(y = apply(ex, data(foo), YES, n, c))) { + if (!isCell(data(c[0]) = cdr(data(c[0])))) + return Pop(res); + for (i = 1; i < n; ++i) + data(c[i]) = cdr(data(c[i])); + } + data(res) = x = cons(y, Nil); + while (isCell(data(c[0]) = cdr(data(c[0])))) { + for (i = 1; i < n; ++i) + data(c[i]) = cdr(data(c[i])); + if (!isNil(y = apply(ex, data(foo), YES, n, c))) + x = cdr(x) = cons(y, Nil); + } + } + return Pop(res); +} + +// (seek 'fun 'lst ..) -> lst +any doSeek(any ex) { + any x = cdr(ex); + cell foo; + + Push(foo, EVAL(car(x))); + if (isCell(x = cdr(x))) { + int i, n = 0; + cell c[length(x)]; + + do + Push(c[n], EVAL(car(x))), ++n; + while (isCell(x = cdr(x))); + while (isCell(data(c[0]))) { + if (!isNil(apply(ex, data(foo), NO, n, c))) { + drop(foo); + return data(c[0]); + } + for (i = 0; i < n; ++i) + data(c[i]) = cdr(data(c[i])); + } + } + drop(foo); + return Nil; +} + +// (find 'fun 'lst ..) -> any +any doFind(any ex) { + any x = cdr(ex); + cell foo; + + Push(foo, EVAL(car(x))); + if (isCell(x = cdr(x))) { + int i, n = 0; + cell c[length(x)]; + + do + Push(c[n], EVAL(car(x))), ++n; + while (isCell(x = cdr(x))); + while (isCell(data(c[0]))) { + if (!isNil(apply(ex, data(foo), YES, n, c))) { + drop(foo); + return car(data(c[0])); + } + for (i = 0; i < n; ++i) + data(c[i]) = cdr(data(c[i])); + } + } + drop(foo); + return Nil; +} + +// (pick 'fun 'lst ..) -> any +any doPick(any ex) { + any x = cdr(ex); + cell foo; + + Push(foo, EVAL(car(x))); + if (isCell(x = cdr(x))) { + int i, n = 0; + cell c[length(x)]; + + do + Push(c[n], EVAL(car(x))), ++n; + while (isCell(x = cdr(x))); + while (isCell(data(c[0]))) { + if (!isNil(x = apply(ex, data(foo), YES, n, c))) { + drop(foo); + return x; + } + for (i = 0; i < n; ++i) + data(c[i]) = cdr(data(c[i])); + } + } + drop(foo); + return Nil; +} + +// (cnt 'fun 'lst ..) -> cnt +any doCnt(any ex) { + any x = cdr(ex); + int res; + cell foo; + + res = 0; + Push(foo, EVAL(car(x))); + if (isCell(x = cdr(x))) { + int i, n = 0; + cell c[length(x)]; + + do + Push(c[n], EVAL(car(x))), ++n; + while (isCell(x = cdr(x))); + while (isCell(data(c[0]))) { + if (!isNil(apply(ex, data(foo), YES, n, c))) + res += 2; + for (i = 0; i < n; ++i) + data(c[i]) = cdr(data(c[i])); + } + } + drop(foo); + return box(res); +} + +// (sum 'fun 'lst ..) -> num +any doSum(any ex) { + any x = cdr(ex); + cell res, foo, c1; + + Push(res, box(0)); + Push(foo, EVAL(car(x))); + if (isCell(x = cdr(x))) { + int i, n = 0; + cell c[length(x)]; + + do + Push(c[n], EVAL(car(x))), ++n; + while (isCell(x = cdr(x))); + while (isCell(data(c[0]))) { + if (isNum(data(c1) = apply(ex, data(foo), YES, n, c))) { + Save(c1); + if (isNeg(data(res))) { + if (isNeg(data(c1))) + bigAdd(data(res),data(c1)); + else + bigSub(data(res),data(c1)); + if (!IsZero(data(res))) + neg(data(res)); + } + else if (isNeg(data(c1))) + bigSub(data(res),data(c1)); + else + bigAdd(data(res),data(c1)); + drop(c1); + } + for (i = 0; i < n; ++i) + data(c[i]) = cdr(data(c[i])); + } + } + return Pop(res); +} + +// (maxi 'fun 'lst ..) -> any +any doMaxi(any ex) { + any x = cdr(ex); + cell res, val, foo; + + Push(res, Nil); + Push(val, Nil); + Push(foo, EVAL(car(x))); + if (isCell(x = cdr(x))) { + int i, n = 0; + cell c[length(x)]; + + do + Push(c[n], EVAL(car(x))), ++n; + while (isCell(x = cdr(x))); + while (isCell(data(c[0]))) { + if (compare(x = apply(ex, data(foo), YES, n, c), data(val)) > 0) + data(res) = car(data(c[0])), data(val) = x; + for (i = 0; i < n; ++i) + data(c[i]) = cdr(data(c[i])); + } + } + return Pop(res); +} + +// (mini 'fun 'lst ..) -> any +any doMini(any ex) { + any x = cdr(ex); + cell res, val, foo; + + Push(res, Nil); + Push(val, T); + Push(foo, EVAL(car(x))); + if (isCell(x = cdr(x))) { + int i, n = 0; + cell c[length(x)]; + + do + Push(c[n], EVAL(car(x))), ++n; + while (isCell(x = cdr(x))); + while (isCell(data(c[0]))) { + if (compare(x = apply(ex, data(foo), YES, n, c), data(val)) < 0) + data(res) = car(data(c[0])), data(val) = x; + for (i = 0; i < n; ++i) + data(c[i]) = cdr(data(c[i])); + } + } + return Pop(res); +} + +static void fish(any ex, any foo, any x, cell *r) { + if (!isNil(apply(ex, foo, NO, 1, (cell*)&x))) + data(*r) = cons(x, data(*r)); + else if (isCell(x)) { + if (!isNil(cdr(x))) + fish(ex, foo, cdr(x), r); + fish(ex, foo, car(x), r); + } +} + +// (fish 'fun 'any) -> lst +any doFish(any ex) { + any x = cdr(ex); + cell res, foo, c1; + + Push(res, Nil); + Push(foo, EVAL(car(x))); + x = cdr(x), Push(c1, EVAL(car(x))); + fish(ex, data(foo), data(c1), &res); + return Pop(res); +} + +// (by 'fun1 'fun2 'lst ..) -> lst +any doBy(any ex) { + any x = cdr(ex); + cell res, foo1, foo2; + + Push(res, Nil); + Push(foo1, EVAL(car(x))), x = cdr(x), Push(foo2, EVAL(car(x))); + if (isCell(x = cdr(x))) { + int i, n = 0; + cell c[length(x)]; + + do + Push(c[n], EVAL(car(x))), ++n; + while (isCell(x = cdr(x))); + if (!isCell(data(c[0]))) + return Pop(res); + data(res) = x = cons(cons(apply(ex, data(foo1), YES, n, c), car(data(c[0]))), Nil); + while (isCell(data(c[0]) = cdr(data(c[0])))) { + for (i = 1; i < n; ++i) + data(c[i]) = cdr(data(c[i])); + cdr(x) = cons(cons(apply(ex, data(foo1), YES, n, c), car(data(c[0]))), Nil); + x = cdr(x); + } + data(res) = apply(ex, data(foo2), NO, 1, &res); + for (x = data(res); isCell(x); x = cdr(x)) + car(x) = cdar(x); + } + return Pop(res); +} diff --git a/src/balance.c b/src/balance.c @@ -0,0 +1,94 @@ +/* balance.c + * 06jul05abu + */ + +#include <stdio.h> +#include <stdlib.h> +#include <unistd.h> +#include <string.h> +#include <errno.h> +#include <signal.h> +#include <sys/wait.h> + +int Len, Siz; +char *Line, **Data; + +static void giveup(char *msg) { + fprintf(stderr, "balance: %s\n", msg); + exit(1); +} + +static char *getLine(FILE *fp) { + int i, c; + char *s; + + i = 0; + while ((c = getc_unlocked(fp)) != '\n') { + if (c == EOF) + return NULL; + Line[i] = c; + if (++i == Len && !(Line = realloc(Line, Len *= 2))) + giveup("No memory"); + } + Line[i] = '\0'; + if (!(s = strdup(Line))) + giveup("No memory"); + return s; +} + +static void balance(char **data, int len) { + if (len) { + int n = (len + 1) / 2; + char **p = data + n - 1; + + printf("%s\n", *p); + balance(data, n - 1); + balance(p + 1, len - n); + } +} + +// balance [-<cmd> [<arg> ..]] +// balance [<file>] +int main(int ac, char *av[]) { + int cnt; + char *s; + pid_t pid = 0; + FILE *fp = stdin; + + if (ac > 1) { + if (*av[1] == '-') { + int pfd[2]; + + if (pipe(pfd) < 0) + giveup("Pipe error\n"); + if ((pid = fork()) == 0) { + close(pfd[0]); + if (pfd[1] != STDOUT_FILENO) + dup2(pfd[1], STDOUT_FILENO), close(pfd[1]); + execvp(av[1]+1, av+1); + } + if (pid < 0) + giveup("Fork error\n"); + close(pfd[1]); + if (!(fp = fdopen(pfd[0], "r"))) + giveup("Pipe open error\n"); + } + else if (!(fp = fopen(av[1], "r"))) + giveup("File open error\n"); + } + Line = malloc(Len = 4096); + Data = malloc((Siz = 4096) * sizeof(char*)); + for (cnt = 0; s = getLine(fp); ++cnt) { + if (cnt == Siz && !(Data = realloc(Data, (Siz *= 2) * sizeof(char*)))) + giveup("No memory"); + Data[cnt] = s; + } + if (pid) { + fclose(fp); + while (waitpid(pid, NULL, 0) < 0) + if (errno != EINTR) + giveup("Pipe close error\n"); + } + balance(Data, cnt); + return 0; +} diff --git a/src/big.c b/src/big.c @@ -0,0 +1,1137 @@ +/* 01mar10abu + * (c) Software Lab. Alexander Burger + */ + +#include "pico.h" + +#define MAX MASK // Max digit size 0xFFFF.... +#define OVFL ((1<<BITS-1)) // Carry/Overflow 0x8000.... + + +static void divErr(any ex) {err(ex,NULL,"Div/0");} + +/* Box double word */ +any boxWord2(word2 t) { + cell c1; + + Push(c1, hi(t)? consNum(num(t), box(hi(t))) : box(num(t))); + digMul2(data(c1)); + return Pop(c1); +} + +word2 unBoxWord2(any x) { + word2 n = unDig(x); + + if (isNum(x = cdr(numCell(x)))) + n = n << BITS + unDig(x); + return n / 2; +} + +/* Bignum copy */ +any bigCopy(any x) { + any y; + cell c1, c2; + + Push(c1, x); + Push(c2, y = box(unDig(x))); + while (isNum(x = cdr(numCell(x)))) + y = cdr(numCell(y)) = box(unDig(x)); + drop(c1); + return data(c2); +} + +/* Remove leading zero words */ +void zapZero(any x) { + any r = x; + + while (isNum(x = cdr(numCell(x)))) + if (unDig(x)) + r = x; + cdr(numCell(r)) = x; +} + +/* Multiply a (positive) bignum by 2 */ +void digMul2(any x) { + any y; + word n, carry; + + n = unDig(x), setDig(x, n + n), carry = n & OVFL; + while (isNum(x = cdr(numCell(y = x)))) { + n = unDig(x); + setDig(x, n + n + (carry? 1 : 0)); + carry = n & OVFL; + } + if (carry) + cdr(numCell(y)) = box(1); +} + +/* Shift right by one bit */ +void digDiv2(any x) { + any r, y; + + r = NULL; + setDig(x, unDig(x) / 2); + while (isNum(x = cdr(numCell(y = x)))) { + if (unDig(x) & 1) + setDig(y, unDig(y) | OVFL); + setDig(x, unDig(x) / 2); + r = y; + } + if (r && unDig(y) == 0) + cdr(numCell(r)) = x; +} + +/* Add two (positive) bignums */ +void bigAdd(any dst, any src) { + any x; + word n, carry; + + carry = (unDig(src) & ~1) > num(setDig(dst, (unDig(src) & ~1) + (unDig(dst) & ~1))); + src = cdr(numCell(src)); + dst = cdr(numCell(x = dst)); + for (;;) { + if (!isNum(src)) { + while (isNum(dst)) { + if (!carry) + return; + carry = 0 == num(setDig(dst, 1 + unDig(dst))); + dst = cdr(numCell(x = dst)); + } + break; + } + if (!isNum(dst)) { + do { + carry = unDig(src) > (n = carry + unDig(src)); + x = cdr(numCell(x)) = box(n); + } while (isNum(src = cdr(numCell(src)))); + break; + } + if ((n = carry + unDig(src)) >= carry) + carry = unDig(dst) > (n += unDig(dst)); + else + n = unDig(dst); + setDig(dst,n); + src = cdr(numCell(src)); + dst = cdr(numCell(x = dst)); + } + if (carry) + cdr(numCell(x)) = box(1); +} + +/* Add digit to a (positive) bignum */ +void digAdd(any x, word n) { + any y; + word carry; + + carry = n > num(setDig(x, n + unDig(x))); + while (carry) { + if (isNum(x = cdr(numCell(y = x)))) + carry = 0 == num(setDig(x, 1 + unDig(x))); + else { + cdr(numCell(y)) = box(1); + break; + } + } +} + +/* Subtract two (positive) bignums */ +void bigSub(any dst, any src) { + any x, y; + word n, borrow; + + borrow = MAX - (unDig(src) & ~1) < num(setDig(dst, (unDig(dst) & ~1) - (unDig(src) & ~1))); + y = dst; + for (;;) { + src = cdr(numCell(src)); + dst = cdr(numCell(x = dst)); + if (!isNum(src)) { + while (isNum(dst)) { + if (!borrow) + return; + borrow = MAX == num(setDig(dst, unDig(dst) - 1)); + dst = cdr(numCell(x = dst)); + } + break; + } + if (!isNum(dst)) { + do { + if (borrow) + n = MAX - unDig(src); + else + borrow = 0 != (n = -unDig(src)); + x = cdr(numCell(x)) = box(n); + } while (isNum(src = cdr(numCell(src)))); + break; + } + if ((n = unDig(dst) - borrow) > MAX - borrow) + setDig(dst, MAX - unDig(src)); + else + borrow = num(setDig(dst, n - unDig(src))) > MAX - unDig(src); + } + if (borrow) { + dst = y; + borrow = 0 != (n = -unDig(dst)); + setDig(dst, n | 1); /* Negate */ + while (dst != x) { + dst = cdr(numCell(dst)); + if (borrow) + setDig(dst, MAX - unDig(dst)); + else + borrow = 0 != num(setDig(dst, -unDig(dst))); + } + } + if (unDig(x) == 0) + zapZero(y); +} + +/* Subtract 1 from a (positive) bignum */ +void digSub1(any x) { + any r, y; + word borrow; + + r = NULL; + borrow = MAX-1 == num(setDig(x, unDig(x) - 2)); + while (isNum(x = cdr(numCell(y = x)))) { + if (!borrow) + return; + borrow = MAX == num(setDig(x, unDig(x) - 1)); + r = y; + } + if (r && unDig(y) == 0) + cdr(numCell(r)) = x; +} + +/* Multiply two (positive) bignums */ +static any bigMul(any x1, any x2) { + any x, y, z; + word n, carry; + word2 t; + cell c1; + + Push(c1, x = y = box(0)); + for (;;) { + n = unDig(x2) / 2; + if (isNum(x2 = cdr(numCell(x2))) && unDig(x2) & 1) + n |= OVFL; + t = (word2)n * unDig(z = x1); // x += n * x1 + carry = (lo(t) > num(setDig(y, unDig(y) + lo(t)))) + hi(t); + while (isNum(z = cdr(numCell(z)))) { + if (!isNum(cdr(numCell(y)))) + cdr(numCell(y)) = box(0); + y = cdr(numCell(y)); + t = (word2)n * unDig(z); + carry = carry > num(setDig(y, carry + unDig(y))); + if (lo(t) > num(setDig(y, unDig(y) + lo(t)))) + ++carry; + carry += hi(t); + } + if (carry) + cdr(numCell(y)) = box(carry); + if (!isNum(x2)) + break; + if (!isNum(y = cdr(numCell(x)))) + y = cdr(numCell(x)) = box(0); + x = y; + } while (isNum(x2)); + zapZero(data(c1)); + return Pop(c1); +} + +/* Multiply digit with a (positive) bignum */ +static void digMul(any x, word n) { + word2 t; + any y; + + t = (word2)n * unDig(x); + for (;;) { + setDig(x, num(t)); + t = hi(t); + if (!isNum(x = cdr(numCell(y = x)))) + break; + t += (word2)n * unDig(x); + } + if (t) + cdr(numCell(y)) = box(num(t)); +} + +/* (Positive) Bignum comparison */ +static int bigCmp(any x, any y) { + int res; + any x1, y1, x2, y2; + + x1 = y1 = Nil; + for (;;) { + if ((x2 = cdr(numCell(x))) == (y2 = cdr(numCell(y)))) { + for (;;) { + if (unDig(x) < unDig(y)) { + res = -1; + break; + } + if (unDig(x) > unDig(y)) { + res = +1; + break; + } + if (!isNum(x1)) + return 0; + x2 = cdr(numCell(x1)), cdr(numCell(x1)) = x, x = x1, x1 = x2; + y2 = cdr(numCell(y1)), cdr(numCell(y1)) = y, y = y1, y1 = y2; + } + break; + } + if (!isNum(x2)) { + res = -1; + break; + } + if (!isNum(y2)) { + res = +1; + break; + } + cdr(numCell(x)) = x1, x1 = x, x = x2; + cdr(numCell(y)) = y1, y1 = y, y = y2; + } + while (isNum(x1)) { + x2 = cdr(numCell(x1)), cdr(numCell(x1)) = x, x = x1, x1 = x2; + y2 = cdr(numCell(y1)), cdr(numCell(y1)) = y, y = y1, y1 = y2; + } + return res; +} + +/* Divide two (positive) bignums (Knuth Vol.2, p.257) */ +static any bigDiv(any u, any v, bool rem) { + int m, n, d, i; + word q, v1, v2, u1, u2, u3, borrow; + word2 t, r; + any x, y, z; + cell c1; + + digDiv2(u), digDiv2(v); // Normalize + for (m = 0, z = u; isNum(y = cdr(numCell(z))); ++m, z = y); + x = v, y = NULL, n = 1; + while (isNum(cdr(numCell(x)))) + y = x, x = cdr(numCell(x)), ++n, --m; + if (m < 0) { + if (rem) + digMul2(u); + return box(0); + } + cdr(numCell(z)) = box(0); + for (d = 0; (unDig(x) & OVFL) == 0; ++d) + digMul2(u), digMul2(v); + v1 = unDig(x); + v2 = y? unDig(y) : 0; + Push(c1, Nil); + do { + for (i = m, x = u; --i >= 0; x = cdr(numCell(x))); // Index x -> u + i = n; + y = x; + u1 = u2 = 0; + do + u3 = u2, u2 = u1, u1 = unDig(y), y = cdr(numCell(y)); + while (--i >= 0); + + t = ((word2)u1 << BITS) + u2; // Calculate q + q = u1 == v1? MAX : t / v1; + r = t - (word2)q*v1; + while (r <= MAX && (word2)q*v2 > (r << BITS) + u3) + --q, r += v1; + + z = x; // x -= q*v + t = (word2)q * unDig(y = v); + borrow = (MAX - lo(t) < num(setDig(z, unDig(z) - lo(t)))) + hi(t); + while (isNum(y = cdr(numCell(y)))) { + z = cdr(numCell(z)); + t = (word2)q * unDig(y); + borrow = MAX - borrow < num(setDig(z, unDig(z) - borrow)); + if (MAX - lo(t) < num(setDig(z, unDig(z) - lo(t)))) + ++borrow; + borrow += hi(t); + } + if (borrow) { + z = cdr(numCell(z)); + if (MAX - borrow < num(setDig(z, unDig(z) - borrow))) { + word n, carry; // x += v + + --q; + if (m || rem) { + y = v; + carry = unDig(y) > num(setDig(x, unDig(y) + unDig(x))); + while (x = cdr(numCell(x)), isNum(y = cdr(numCell(y)))) { + if ((n = carry + unDig(y)) >= carry) + carry = unDig(x) > (n += unDig(x)); + else + n = unDig(x); + setDig(x,n); + } + setDig(x, carry + unDig(x)); + } + } + } + data(c1) = consNum(q, data(c1)); // Store result + } while (--m >= 0); + if (!rem) + zapZero(data(c1)), digMul2(data(c1)); + else { + zapZero(u); + if (!d) + digMul2(u); + else + while (--d) + digDiv2(u); + } + return Pop(c1); +} + +/* Compare two numbers */ +int bigCompare(any x, any y) { + if (isNeg(x)) { + if (!isNeg(y)) + return -1; + return bigCmp(y,x); + } + if (isNeg(y)) + return +1; + return bigCmp(x,y); +} + +/* Make number from symbol */ +any symToNum(any s, int scl, int sep, int ign) { + unsigned c; + bool sign, frac; + cell c1, c2; + + if (!(c = symByte(s))) + return NULL; + while (c <= ' ') /* Skip white space */ + if (!(c = symByte(NULL))) + return NULL; + sign = NO; + if (c == '+' || c == '-' && (sign = YES)) + if (!(c = symByte(NULL))) + return NULL; + if ((c -= '0') > 9) + return NULL; + frac = NO; + Push(c1, s); + Push(c2, box(c+c)); + while ((c = symChar(NULL)) && (!frac || scl)) { + if ((int)c == sep) { + if (frac) { + drop(c1); + return NULL; + } + frac = YES; + } + else if ((int)c != ign) { + if ((c -= '0') > 9) { + drop(c1); + return NULL; + } + digMul(data(c2), 10); + digAdd(data(c2), c+c); + if (frac) + --scl; + } + } + if (c) { + if ((c -= '0') > 9) { + drop(c1); + return NULL; + } + if (c >= 5) + digAdd(data(c2), 1+1); + while (c = symByte(NULL)) { + if ((c -= '0') > 9) { + drop(c1); + return NULL; + } + } + } + if (frac) + while (--scl >= 0) + digMul(data(c2), 10); + if (sign && !IsZero(data(c2))) + neg(data(c2)); + drop(c1); + return data(c2); +} + +/* Buffer size calculation */ +static inline int numlen(any x) { + int n = 10; + while (isNum(x = cdr(numCell(x)))) + n += 10; + return (n + 8) / 9; +} + +/* Make symbol from number */ +any numToSym(any x, int scl, int sep, int ign) { + int i; + bool sign; + cell c1; + word n = numlen(x); + word c, *p, *q, *ta, *ti, acc[n], inc[n]; + char *b, buf[10]; + + sign = isNeg(x); + *(ta = acc) = 0; + *(ti = inc) = 1; + n = 2; + for (;;) { + do { + if (unDig(x) & n) { + c = 0, p = acc, q = inc; + do { + if (ta < p) + *++ta = 0; + if (c = (*p += *q + c) > 999999999) + *p -= 1000000000; + } while (++p, ++q <= ti); + if (c) + *p = 1, ++ta; + } + c = 0, q = inc; + do + if (c = (*q += *q + c) > 999999999) + *q -= 1000000000; + while (++q <= ti); + if (c) + *q = 1, ++ti; + } while (n <<= 1); + if (!isNum(x = cdr(numCell(x)))) + break; + n = 1; + } + n = (ta - acc) * 9 + sprintf(b = buf, "%ld", *ta--); + if (sep < 0) + return boxCnt(n + sign); + i = -8, Push(c1, x = box(0)); + if (sign) + byteSym('-', &i, &x); + if ((scl = n - scl - 1) < 0) { + byteSym('0', &i, &x); + charSym(sep, &i, &x); + while (scl < -1) + byteSym('0', &i, &x), ++scl; + } + for (;;) { + byteSym(*b++, &i, &x); + if (!*b) { + if (ta < acc) + return consStr(Pop(c1)); + sprintf(b = buf, "%09ld", *ta--); + } + if (scl == 0) + charSym(sep, &i, &x); + else if (ign && scl > 0 && scl % 3 == 0) + charSym(ign, &i, &x); + --scl; + } +} + +#define DMAX ((double)((word2)MASK+1)) + +/* Make number from double */ +any doubleToNum(double d) { + bool sign; + any x; + cell c1; + + sign = NO; + if (d < 0.0) + sign = YES, d = -d; + d += 0.5; + Push(c1, x = box((word)fmod(d,DMAX))); + while (d > DMAX) + x = cdr(numCell(x)) = box((word)fmod(d /= DMAX, DMAX)); + digMul2(data(c1)); + if (sign && !IsZero(data(c1))) + neg(data(c1)); + return Pop(c1); +} + +/* Make double from number */ +double numToDouble(any x) { + double d, m; + bool sign; + + sign = isNeg(x); + d = (double)(unDig(x) / 2), m = DMAX/2.0; + while (isNum(x = cdr(numCell(x)))) + d += m * (double)unDig(x), m *= DMAX; + return sign? -d : d; +} + +// (format 'num ['cnt ['sym1 ['sym2]]]) -> sym +// (format 'sym ['cnt ['sym1 ['sym2]]]) -> num +any doFormat(any ex) { + int scl, sep, ign; + any x, y; + cell c1; + + x = cdr(ex), Push(c1, EVAL(car(x))); + NeedAtom(ex,data(c1)); + x = cdr(x), y = EVAL(car(x)); + scl = isNil(y)? 0 : xCnt(ex, y); + sep = '.'; + ign = 0; + if (isCell(x = cdr(x))) { + y = EVAL(car(x)); + NeedSym(ex,y); + sep = symChar(name(y)); + if (isCell(x = cdr(x))) { + y = EVAL(car(x)); + NeedSym(ex,y); + ign = symChar(name(y)); + } + } + data(c1) = isNum(data(c1))? + numToSym(data(c1), scl, sep, ign) : + symToNum(name(data(c1)), scl, sep, ign) ?: Nil; + return Pop(c1); +} + +// (+ 'num ..) -> num +any doAdd(any ex) { + any x; + cell c1, c2; + + x = cdr(ex); + if (isNil(data(c1) = EVAL(car(x)))) + return Nil; + NeedNum(ex,data(c1)); + Push(c1, bigCopy(data(c1))); + while (isCell(x = cdr(x))) { + Push(c2, EVAL(car(x))); + if (isNil(data(c2))) { + drop(c1); + return Nil; + } + NeedNum(ex,data(c2)); + if (isNeg(data(c1))) { + if (isNeg(data(c2))) + bigAdd(data(c1),data(c2)); + else + bigSub(data(c1),data(c2)); + if (!IsZero(data(c1))) + neg(data(c1)); + } + else if (isNeg(data(c2))) + bigSub(data(c1),data(c2)); + else + bigAdd(data(c1),data(c2)); + drop(c2); + } + return Pop(c1); +} + +// (- 'num ..) -> num +any doSub(any ex) { + any x; + cell c1, c2; + + x = cdr(ex); + if (isNil(data(c1) = EVAL(car(x)))) + return Nil; + NeedNum(ex,data(c1)); + if (!isCell(x = cdr(x))) + return IsZero(data(c1))? + data(c1) : consNum(unDig(data(c1)) ^ 1, cdr(numCell(data(c1)))); + Push(c1, bigCopy(data(c1))); + do { + Push(c2, EVAL(car(x))); + if (isNil(data(c2))) { + drop(c1); + return Nil; + } + NeedNum(ex,data(c2)); + if (isNeg(data(c1))) { + if (isNeg(data(c2))) + bigSub(data(c1),data(c2)); + else + bigAdd(data(c1),data(c2)); + if (!IsZero(data(c1))) + neg(data(c1)); + } + else if (isNeg(data(c2))) + bigAdd(data(c1),data(c2)); + else + bigSub(data(c1),data(c2)); + drop(c2); + } while (isCell(x = cdr(x))); + return Pop(c1); +} + +// (inc 'num) -> num +// (inc 'var ['num]) -> num +any doInc(any ex) { + any x; + cell c1, c2; + + x = cdr(ex); + if (isNil(data(c1) = EVAL(car(x)))) + return Nil; + if (isNum(data(c1))) { + Push(c1, bigCopy(data(c1))); + if (!isNeg(data(c1))) + digAdd(data(c1), 2); + else { + pos(data(c1)), digSub1(data(c1)), neg(data(c1)); + if (unDig(data(c1)) == 1 && !isNum(cdr(numCell(data(c1))))) + setDig(data(c1), 0); + } + return Pop(c1); + } + CheckVar(ex,data(c1)); + if (isSym(data(c1))) + Touch(ex,data(c1)); + if (!isCell(x = cdr(x))) { + if (isNil(val(data(c1)))) + return Nil; + NeedNum(ex,val(data(c1))); + Save(c1); + val(data(c1)) = bigCopy(val(data(c1))); + if (!isNeg(val(data(c1)))) + digAdd(val(data(c1)), 2); + else { + pos(val(data(c1))), digSub1(val(data(c1))), neg(val(data(c1))); + if (unDig(val(data(c1))) == 1 && !isNum(cdr(numCell(val(data(c1)))))) + setDig(val(data(c1)), 0); + } + } + else { + Save(c1); + Push(c2, EVAL(car(x))); + if (isNil(val(data(c1))) || isNil(data(c2))) { + drop(c1); + return Nil; + } + NeedNum(ex,val(data(c1))); + val(data(c1)) = bigCopy(val(data(c1))); + NeedNum(ex,data(c2)); + if (isNeg(val(data(c1)))) { + if (isNeg(data(c2))) + bigAdd(val(data(c1)),data(c2)); + else + bigSub(val(data(c1)),data(c2)); + if (!IsZero(val(data(c1)))) + neg(val(data(c1))); + } + else if (isNeg(data(c2))) + bigSub(val(data(c1)),data(c2)); + else + bigAdd(val(data(c1)),data(c2)); + } + return val(Pop(c1)); +} + +// (dec 'num) -> num +// (dec 'var ['num]) -> num +any doDec(any ex) { + any x; + cell c1, c2; + + x = cdr(ex); + if (isNil(data(c1) = EVAL(car(x)))) + return Nil; + if (isNum(data(c1))) { + Push(c1, bigCopy(data(c1))); + if (isNeg(data(c1))) + digAdd(data(c1), 2); + else if (IsZero(data(c1))) + setDig(data(c1), 3); + else + digSub1(data(c1)); + return Pop(c1); + } + CheckVar(ex,data(c1)); + if (isSym(data(c1))) + Touch(ex,data(c1)); + if (!isCell(x = cdr(x))) { + if (isNil(val(data(c1)))) + return Nil; + NeedNum(ex,val(data(c1))); + Save(c1); + val(data(c1)) = bigCopy(val(data(c1))); + if (isNeg(val(data(c1)))) + digAdd(val(data(c1)), 2); + else if (IsZero(val(data(c1)))) + setDig(val(data(c1)), 3); + else + digSub1(val(data(c1))); + } + else { + Save(c1); + Push(c2, EVAL(car(x))); + if (isNil(val(data(c1))) || isNil(data(c2))) { + drop(c1); + return Nil; + } + NeedNum(ex,val(data(c1))); + val(data(c1)) = bigCopy(val(data(c1))); + NeedNum(ex,data(c2)); + if (isNeg(val(data(c1)))) { + if (isNeg(data(c2))) + bigSub(val(data(c1)),data(c2)); + else + bigAdd(val(data(c1)),data(c2)); + if (!IsZero(val(data(c1)))) + neg(val(data(c1))); + } + else if (isNeg(data(c2))) + bigAdd(val(data(c1)),data(c2)); + else + bigSub(val(data(c1)),data(c2)); + } + return val(Pop(c1)); +} + +// (* 'num ..) -> num +any doMul(any ex) { + any x; + bool sign; + cell c1, c2; + + x = cdr(ex); + if (isNil(data(c1) = EVAL(car(x)))) + return Nil; + NeedNum(ex,data(c1)); + Push(c1, bigCopy(data(c1))); + sign = isNeg(data(c1)), pos(data(c1)); + while (isCell(x = cdr(x))) { + Push(c2, EVAL(car(x))); + if (isNil(data(c2))) { + drop(c1); + return Nil; + } + NeedNum(ex,data(c2)); + sign ^= isNeg(data(c2)); + data(c1) = bigMul(data(c1),data(c2)); + drop(c2); + } + if (sign && !IsZero(data(c1))) + neg(data(c1)); + return Pop(c1); +} + +// (*/ 'num1 ['num2 ..] 'num3) -> num +any doMulDiv(any ex) { + any x; + bool sign; + cell c1, c2, c3; + + x = cdr(ex); + if (isNil(data(c1) = EVAL(car(x)))) + return Nil; + NeedNum(ex,data(c1)); + Push(c1, bigCopy(data(c1))); + sign = isNeg(data(c1)), pos(data(c1)); + Push(c2, Nil); + for (;;) { + x = cdr(x), data(c2) = EVAL(car(x)); + if (isNil(data(c2))) { + drop(c1); + return Nil; + } + NeedNum(ex,data(c2)); + sign ^= isNeg(data(c2)); + if (!isCell(cdr(x))) + break; + data(c1) = bigMul(data(c1),data(c2)); + } + if (IsZero(data(c2))) + divErr(ex); + Push(c3, bigCopy(data(c2))); + digDiv2(data(c3)); + bigAdd(data(c1),data(c3)); + data(c2) = bigCopy(data(c2)); + data(c1) = bigDiv(data(c1),data(c2),NO); + if (sign && !IsZero(data(c1))) + neg(data(c1)); + return Pop(c1); +} + +// (/ 'num ..) -> num +any doDiv(any ex) { + any x; + bool sign; + cell c1, c2; + + x = cdr(ex); + if (isNil(data(c1) = EVAL(car(x)))) + return Nil; + NeedNum(ex,data(c1)); + Push(c1, bigCopy(data(c1))); + sign = isNeg(data(c1)), pos(data(c1)); + while (isCell(x = cdr(x))) { + Push(c2, EVAL(car(x))); + if (isNil(data(c2))) { + drop(c1); + return Nil; + } + NeedNum(ex,data(c2)); + sign ^= isNeg(data(c2)); + if (IsZero(data(c2))) + divErr(ex); + data(c2) = bigCopy(data(c2)); + data(c1) = bigDiv(data(c1),data(c2),NO); + drop(c2); + } + if (sign && !IsZero(data(c1))) + neg(data(c1)); + return Pop(c1); +} + +// (% 'num ..) -> num +any doRem(any ex) { + any x; + bool sign; + cell c1, c2; + + x = cdr(ex); + if (isNil(data(c1) = EVAL(car(x)))) + return Nil; + NeedNum(ex,data(c1)); + Push(c1, bigCopy(data(c1))); + sign = isNeg(data(c1)), pos(data(c1)); + while (isCell(x = cdr(x))) { + Push(c2, EVAL(car(x))); + if (isNil(data(c2))) { + drop(c1); + return Nil; + } + NeedNum(ex,data(c2)); + if (IsZero(data(c2))) + divErr(ex); + data(c2) = bigCopy(data(c2)); + bigDiv(data(c1),data(c2),YES); + drop(c2); + } + if (sign && !IsZero(data(c1))) + neg(data(c1)); + return Pop(c1); +} + +// (>> 'cnt 'num) -> num +any doShift(any ex) { + any x; + long n; + bool sign; + cell c1; + + x = cdr(ex), n = evCnt(ex,x); + x = cdr(x); + if (isNil(data(c1) = EVAL(car(x)))) + return Nil; + NeedNum(ex,data(c1)); + Push(c1, bigCopy(data(c1))); + sign = isNeg(data(c1)); + if (n > 0) { + do + digDiv2(data(c1)); + while (--n); + pos(data(c1)); + } + else if (n < 0) { + pos(data(c1)); + do + digMul2(data(c1)); + while (++n); + } + if (sign && !IsZero(data(c1))) + neg(data(c1)); + return Pop(c1); +} + +// (lt0 'any) -> num | NIL +any doLt0(any x) { + x = cdr(x); + return isNum(x = EVAL(car(x))) && isNeg(x)? x : Nil; +} + +// (ge0 'any) -> num | NIL +any doGe0(any x) { + x = cdr(x); + return isNum(x = EVAL(car(x))) && !isNeg(x)? x : Nil; +} + +// (gt0 'any) -> num | NIL +any doGt0(any x) { + x = cdr(x); + return isNum(x = EVAL(car(x))) && !isNeg(x) && !IsZero(x)? x : Nil; +} + +// (abs 'num) -> num +any doAbs(any ex) { + any x; + + x = cdr(ex); + if (isNil(x = EVAL(car(x)))) + return Nil; + NeedNum(ex,x); + if (!isNeg(x)) + return x; + return consNum(unDig(x) & ~1, cdr(numCell(x))); +} + +// (bit? 'num ..) -> num | NIL +any doBitQ(any ex) { + any x, y, z; + cell c1; + + x = cdr(ex), Push(c1, EVAL(car(x))); + NeedNum(ex,data(c1)); + while (isCell(x = cdr(x))) { + if (isNil(z = EVAL(car(x)))) { + drop(c1); + return Nil; + } + NeedNum(ex,z); + y = data(c1); + for (;;) { + if ((unDig(y) & unDig(z)) != unDig(y)) { + drop(c1); + return Nil; + } + if (!isNum(y = cdr(numCell(y)))) + break; + if (!isNum(z = cdr(numCell(z)))) { + drop(c1); + return Nil; + } + } + } + return Pop(c1); +} + +// (& 'num ..) -> num +any doBitAnd(any ex) { + any x, y, z; + cell c1; + + x = cdr(ex); + if (isNil(data(c1) = EVAL(car(x)))) + return Nil; + NeedNum(ex,data(c1)); + Push(c1, bigCopy(data(c1))); + while (isCell(x = cdr(x))) { + if (isNil(z = EVAL(car(x)))) { + drop(c1); + return Nil; + } + NeedNum(ex,z); + y = data(c1); + for (;;) { + setDig(y, unDig(y) & unDig(z)); + if (!isNum(z = cdr(numCell(z)))) { + cdr(numCell(y)) = Nil; + break; + } + if (!isNum(y = cdr(numCell(y)))) + break; + } + } + zapZero(data(c1)); + return Pop(c1); +} + +// (| 'num ..) -> num +any doBitOr(any ex) { + any x, y; + cell c1, c2; + + x = cdr(ex); + if (isNil(data(c1) = EVAL(car(x)))) + return Nil; + NeedNum(ex,data(c1)); + Push(c1, bigCopy(data(c1))); + while (isCell(x = cdr(x))) { + if (isNil(data(c2) = EVAL(car(x)))) { + drop(c1); + return Nil; + } + NeedNum(ex,data(c2)); + y = data(c1); + Save(c2); + for (;;) { + setDig(y, unDig(y) | unDig(data(c2))); + if (!isNum(data(c2) = cdr(numCell(data(c2))))) + break; + if (!isNum(cdr(numCell(y)))) + cdr(numCell(y)) = box(0); + y = cdr(numCell(y)); + } + drop(c2); + } + return Pop(c1); +} + +// (x| 'num ..) -> num +any doBitXor(any ex) { + any x, y; + cell c1, c2; + + x = cdr(ex); + if (isNil(data(c1) = EVAL(car(x)))) + return Nil; + NeedNum(ex,data(c1)); + Push(c1, bigCopy(data(c1))); + while (isCell(x = cdr(x))) { + if (isNil(data(c2) = EVAL(car(x)))) { + drop(c1); + return Nil; + } + NeedNum(ex,data(c2)); + y = data(c1); + Save(c2); + for (;;) { + setDig(y, unDig(y) ^ unDig(data(c2))); + if (!isNum(data(c2) = cdr(numCell(data(c2))))) + break; + if (!isNum(cdr(numCell(y)))) + cdr(numCell(y)) = box(0); + y = cdr(numCell(y)); + } + drop(c2); + } + zapZero(data(c1)); + return Pop(c1); +} + +/* Random numbers */ +static u_int64_t Seed; + +static u_int64_t initSeed(any x) { + u_int64_t n; + + for (n = 0; isCell(x); x = cdr(x)) + n += initSeed(car(x)); + if (!isNil(x)) { + if (isSym(x)) + x = name(x); + do + n += unDig(x); + while (isNum(x = cdr(numCell(x)))); + } + return n; +} + +// (seed 'any) -> cnt +any doSeed(any ex) { + return boxCnt( + hi(Seed = initSeed(EVAL(cadr(ex))) * 6364136223846793005LL + 1) ); +} + +// (rand ['cnt1 'cnt2] | ['T]) -> cnt | flg +any doRand(any ex) { + any x; + long n; + + x = cdr(ex); + Seed = Seed * 6364136223846793005LL + 1; + if (isNil(x = EVAL(car(x)))) + return boxCnt(hi(Seed)); + if (x == T) + return hi(Seed) & 1 ? T : Nil; + n = xCnt(ex,x); + return boxCnt(n + hi(Seed) % (evCnt(ex, cddr(ex)) + 1 - n)); +} diff --git a/src/ext.c b/src/ext.c @@ -0,0 +1,182 @@ +/* 21feb10abu + * (c) Software Lab. Alexander Burger + */ + +#include "pico.h" + +/*** Soundex Algorithm ***/ +static int SnxTab[] = { + '0', '1', '2', '3', '4', '5', '6', '7', // 48 + '8', '9', 0, 0, 0, 0, 0, 0, + 0, 0, 'F', 'S', 'T', 0, 'F', 'S', // 64 + 0, 0, 'S', 'S', 'L', 'N', 'N', 0, + 'F', 'S', 'R', 'S', 'T', 0, 'F', 'F', + 'S', 0, 'S', 0, 0, 0, 0, 0, + 0, 0, 'F', 'S', 'T', 0, 'F', 'S', // 96 + 0, 0, 'S', 'S', 'L', 'N', 'N', 0, + 'F', 'S', 'R', 'S', 'T', 0, 'F', 'F', + 'S', 0, 'S', 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, // 128 + 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, // 160 + 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 'S', // 192 + 0, 0, 0, 0, 0, 0, 0, 0, + 'T', 'N', 0, 0, 0, 0, 0, 'S', + 0, 0, 0, 0, 0, 0, 0, 'S', + 0, 0, 0, 0, 0, 0, 0, 'S', // 224 + 0, 0, 0, 0, 0, 0, 0, 0, + 0, 'N' + // ... +}; + +#define SNXBASE 48 +#define SNXSIZE ((int)(sizeof(SnxTab) / sizeof(int))) + + +// (ext:Snx 'any ['cnt]) -> sym +any Snx(any ex) { + int n, c, i, last; + any x, nm; + cell c1, c2; + + x = cdr(ex); + if (!isSym(x = EVAL(car(x))) || !(c = symChar(name(x)))) + return Nil; + while (c < SNXBASE) + if (!(c = symChar(NULL))) + return Nil; + Push(c1, x); + n = isCell(x = cddr(ex))? evCnt(ex,x) : 24; + if (c >= 'a' && c <= 'z' || c == 128 || c >= 224 && c < 255) + c &= ~0x20; + Push(c2, boxChar(last = c, &i, &nm)); + while (c = symChar(NULL)) + if (c > ' ') { + if ((c -= SNXBASE) < 0 || c >= SNXSIZE || !(c = SnxTab[c])) + last = 0; + else if (c != last) { + if (!--n) + break; + charSym(last = c, &i, &nm); + } + } + drop(c1); + return consStr(data(c2)); +} + + +/*** Math ***/ +// (ext:Exp 'x 'scale) -> num +any Exp(any ex) { + double x, n; + + x = evDouble(ex, cdr(ex)); + n = evDouble(ex, cddr(ex)); + return doubleToNum(n * exp(x / n)); +} + +// (ext:Log 'x 'scale) -> num +any Log(any ex) { + double x, n; + + x = evDouble(ex, cdr(ex)); + n = evDouble(ex, cddr(ex)); + return doubleToNum(n * log(x / n)); +} + +// (ext:Sin 'angle 'scale) -> num +any Sin(any ex) { + any x; + double a, n; + + a = evDouble(ex, x = cdr(ex)); + n = evDouble(ex, cdr(x)); + return doubleToNum(n * sin(a / n)); +} + +// (ext:Cos 'angle 'scale) -> num +any Cos(any ex) { + any x; + double a, n; + + a = evDouble(ex, x = cdr(ex)); + n = evDouble(ex, cdr(x)); + return doubleToNum(n * cos(a / n)); +} + +// (ext:Tan 'angle 'scale) -> num +any Tan(any ex) { + any x; + double a, n; + + a = evDouble(ex, x = cdr(ex)); + n = evDouble(ex, cdr(x)); + return doubleToNum(n * tan(a / n)); +} + +// (ext:Atan 'x 'y 'scale) -> num +any Atan(any ex) { + double x, y, n; + + x = evDouble(ex, cdr(ex)); + y = evDouble(ex, cddr(ex)); + n = evDouble(ex, cdddr(ex)); + return doubleToNum(n * atan2(x / n, y / n)); +} + + +/*** U-Law Encoding ***/ +#define BIAS 132 +#define CLIP (32767-BIAS) + +// (ext:Ulaw 'cnt) -> cnt # SEEEMMMM +any Ulaw(any ex) { + int val, sign, tmp, exp; + + val = (int)evCnt(ex,cdr(ex)); + sign = 0; + if (val < 0) + val = -val, sign = 0x80; + if (val > CLIP) + val = CLIP; + tmp = (val += BIAS) << 1; + for (exp = 7; exp > 0 && !(tmp & 0x8000); --exp, tmp <<= 1); + return boxCnt(~(sign | exp<<4 | val >> exp+3 & 0x000F) & 0xFF); +} + + +/*** Base64 Encoding ***/ +static unsigned char Chr64[] = + "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"; + +// (ext:Base64 'num1|NIL ['num2|NIL ['num3|NIL]]) -> flg +any Base64(any x) { + int c, d; + any y; + + x = cdr(x); + if (isNil(y = EVAL(car(x)))) + return Nil; + c = unDig(y) / 2; + Env.put(Chr64[c >> 2]); + x = cdr(x); + if (isNil(y = EVAL(car(x)))) { + Env.put(Chr64[(c & 3) << 4]), Env.put('='), Env.put('='); + return Nil; + } + d = unDig(y) / 2; + Env.put(Chr64[(c & 3) << 4 | d >> 4]); + x = cdr(x); + if (isNil(y = EVAL(car(x)))) { + Env.put(Chr64[(d & 15) << 2]), Env.put('='); + return Nil; + } + c = unDig(y) / 2; + Env.put(Chr64[(d & 15) << 2 | c >> 6]), Env.put(Chr64[c & 63]); + return T; +} diff --git a/src/flow.c b/src/flow.c @@ -0,0 +1,1688 @@ +/* 19apr10abu + * (c) Software Lab. Alexander Burger + */ + +#include "pico.h" + +static void redefMsg(any x, any y) { + outFile *oSave = OutFile; + void (*putSave)(int) = Env.put; + + OutFile = OutFiles[STDERR_FILENO], Env.put = putStdout; + outString("# "); + print(x); + if (y) + space(), print(y); + outString(" redefined\n"); + Env.put = putSave, OutFile = oSave; +} + +static void putSrc(any s, any k) { + if (!isNil(val(Dbg)) && !isExt(s) && InFile && InFile->name) { + any x, y; + cell c1; + + Push(c1, boxCnt(InFile->src)); + data(c1) = cons(data(c1), mkStr(InFile->name)); + x = get(s, Dbg); + if (!k) { + if (isNil(x)) + put(s, Dbg, cons(data(c1), Nil)); + else + car(x) = data(c1); + } + else if (isNil(x)) + put(s, Dbg, cons(Nil, cons(data(c1), Nil))); + else { + for (y = cdr(x); isCell(y); y = cdr(y)) + if (caar(y) == k) { + cdar(y) = data(c1); + drop(c1); + return; + } + cdr(x) = cons(cons(k, data(c1)), cdr(x)); + } + drop(c1); + } +} + +static void redefine(any ex, any s, any x) { + NeedSym(ex,s); + CheckVar(ex,s); + if (!isNil(val(s)) && s != val(s) && !equal(x,val(s))) + redefMsg(s, NULL); + val(s) = x; + putSrc(s, NULL); +} + +// (quote . any) -> any +any doQuote(any x) {return cdr(x);} + +// (as 'any1 . any2) -> any2 | NIL +any doAs(any x) { + x = cdr(x); + if (isNil(EVAL(car(x)))) + return Nil; + return cdr(x); +} + +// (pid 'pid|lst . exe) -> any +any doPid(any x) { + any y; + + x = cdr(x); + if (!isCell(y = EVAL(car(x)))) + return equal(y, val(Pid))? EVAL(cdr(x)) : Nil; + do + if (equal(car(y), val(Pid))) + return EVAL(cdr(x)); + while (isCell(y = cdr(y))); + return Nil; +} + +// (lit 'any) -> any +any doLit(any x) { + x = cadr(x); + if (isNum(x = EVAL(x)) || isNil(x) || x == T || isCell(x) && isNum(car(x))) + return x; + return cons(Quote, x); +} + +// (eval 'any ['cnt ['lst]]) -> any +any doEval(any x) { + any y; + cell c1; + bindFrame *p; + + x = cdr(x), Push(c1, EVAL(car(x))), x = cdr(x); + if (!isNum(y = EVAL(car(x))) || !(p = Env.bind)) + data(c1) = EVAL(data(c1)); + else { + int cnt, n, i, j; + struct { // bindFrame + struct bindFrame *link; + int i, cnt; + struct {any sym; any val;} bnd[length(x)]; + } f; + + x = cdr(x), x = EVAL(car(x)); + j = cnt = (int)unBox(y); + n = f.i = f.cnt = 0; + do { + ++n; + if ((i = p->i) <= 0 && (p->i -= cnt, i == 0)) { + for (i = 0; i < p->cnt; ++i) { + y = val(p->bnd[i].sym); + val(p->bnd[i].sym) = p->bnd[i].val; + p->bnd[i].val = y; + } + if (p->cnt && p->bnd[0].sym == At && !--j) + break; + } + } while (p = p->link); + while (isCell(x)) { + for (p = Env.bind, j = n; ; p = p->link) { + if (p->i < 0) + for (i = 0; i < p->cnt; ++i) { + if (p->bnd[i].sym == car(x)) { + f.bnd[f.cnt].val = val(f.bnd[f.cnt].sym = car(x)); + val(car(x)) = p->bnd[i].val; + ++f.cnt; + goto next; + } + } + if (!--j) + break; + } +next: x = cdr(x); + } + f.link = Env.bind, Env.bind = (bindFrame*)&f; + data(c1) = EVAL(data(c1)); + while (--f.cnt >= 0) + val(f.bnd[f.cnt].sym) = f.bnd[f.cnt].val; + Env.bind = f.link; + do { + for (p = Env.bind, i = n; --i; p = p->link); + if (p->i < 0 && (p->i += cnt) == 0) + for (i = p->cnt; --i >= 0;) { + y = val(p->bnd[i].sym); + val(p->bnd[i].sym) = p->bnd[i].val; + p->bnd[i].val = y; + } + } while (--n); + } + return Pop(c1); +} + +// (run 'any ['cnt ['lst]]) -> any +any doRun(any x) { + any y; + cell c1; + bindFrame *p; + + x = cdr(x), data(c1) = EVAL(car(x)), x = cdr(x); + if (!isNum(data(c1))) { + Save(c1); + if (!isNum(y = EVAL(car(x))) || !(p = Env.bind)) + data(c1) = isSym(data(c1))? val(data(c1)) : run(data(c1)); + else { + int cnt, n, i, j; + struct { // bindFrame + struct bindFrame *link; + int i, cnt; + struct {any sym; any val;} bnd[length(x)]; + } f; + + x = cdr(x), x = EVAL(car(x)); + j = cnt = (int)unBox(y); + n = f.i = f.cnt = 0; + do { + ++n; + if ((i = p->i) <= 0 && (p->i -= cnt, i == 0)) { + for (i = 0; i < p->cnt; ++i) { + y = val(p->bnd[i].sym); + val(p->bnd[i].sym) = p->bnd[i].val; + p->bnd[i].val = y; + } + if (p->cnt && p->bnd[0].sym == At && !--j) + break; + } + } while (p = p->link); + while (isCell(x)) { + for (p = Env.bind, j = n; ; p = p->link) { + if (p->i < 0) + for (i = 0; i < p->cnt; ++i) { + if (p->bnd[i].sym == car(x)) { + f.bnd[f.cnt].val = val(f.bnd[f.cnt].sym = car(x)); + val(car(x)) = p->bnd[i].val; + ++f.cnt; + goto next; + } + } + if (!--j) + break; + } +next: x = cdr(x); + } + f.link = Env.bind, Env.bind = (bindFrame*)&f; + data(c1) = isSym(data(c1))? val(data(c1)) : prog(data(c1)); + while (--f.cnt >= 0) + val(f.bnd[f.cnt].sym) = f.bnd[f.cnt].val; + Env.bind = f.link; + do { + for (p = Env.bind, i = n; --i; p = p->link); + if (p->i < 0 && (p->i += cnt) == 0) + for (i = p->cnt; --i >= 0;) { + y = val(p->bnd[i].sym); + val(p->bnd[i].sym) = p->bnd[i].val; + p->bnd[i].val = y; + } + } while (--n); + } + drop(c1); + } + return data(c1); +} + +// (def 'sym 'any) -> sym +// (def 'sym 'sym 'any) -> sym +any doDef(any ex) { + any x, y; + cell c1, c2, c3; + + x = cdr(ex), Push(c1, EVAL(car(x))); + NeedSym(ex,data(c1)); + CheckVar(ex,data(c1)); + Touch(ex,data(c1)); + x = cdr(x), Push(c2, EVAL(car(x))); + if (!isCell(cdr(x))) { + if (!isNil(y = val(data(c1))) && y != data(c1) && !equal(data(c2), y)) + redefMsg(data(c1), NULL); + val(data(c1)) = data(c2); + putSrc(data(c1), NULL); + } + else { + x = cdr(x), Push(c3, EVAL(car(x))); + if (!isNil(y = get(data(c1), data(c2))) && !equal(data(c3), y)) + redefMsg(data(c1), data(c2)); + put(data(c1), data(c2), data(c3)); + putSrc(data(c1), data(c2)); + } + return Pop(c1); +} + +// (de sym . any) -> sym +any doDe(any ex) { + redefine(ex, cadr(ex), cddr(ex)); + return cadr(ex); +} + +// (dm sym . fun|cls2) -> sym +// (dm (sym . cls) . fun|cls2) -> sym +// (dm (sym sym2 [. cls]) . fun|cls2) -> sym +any doDm(any ex) { + any x, y, msg, cls; + + x = cdr(ex); + if (!isCell(car(x))) + msg = car(x), cls = val(Class); + else { + msg = caar(x); + cls = !isCell(cdar(x))? cdar(x) : + get(isNil(cddar(x))? val(Class) : cddar(x), cadar(x)); + } + if (msg != T) + redefine(ex, msg, val(Meth)); + if (isSym(cdr(x))) { + y = val(cdr(x)); + for (;;) { + if (!isCell(y) || !isCell(car(y))) + err(ex, msg, "Bad message"); + if (caar(y) == msg) { + x = car(y); + break; + } + y = cdr(y); + } + } + for (y = val(cls); isCell(y) && isCell(car(y)); y = cdr(y)) + if (caar(y) == msg) { + if (!equal(cdr(x), cdar(y))) + redefMsg(msg, cls); + cdar(y) = cdr(x); + putSrc(cls, msg); + return msg; + } + if (!isCell(car(x))) + val(cls) = cons(x, val(cls)); + else + val(cls) = cons(cons(msg, cdr(x)), val(cls)); + putSrc(cls, msg); + return msg; +} + +/* Evaluate method invocation */ +static any evMethod(any o, any expr, any x) { + any y = car(expr); + methFrame m; + struct { // bindFrame + struct bindFrame *link; + int i, cnt; + struct {any sym; any val;} bnd[length(y)+3]; + } f; + + m.link = Env.meth; + m.key = TheKey; + m.cls = TheCls; + f.link = Env.bind, Env.bind = (bindFrame*)&f; + f.i = sizeof(f.bnd) / (2*sizeof(any)) - 2; + f.cnt = 1, f.bnd[0].sym = At, f.bnd[0].val = val(At); + while (isCell(y)) { + f.bnd[f.cnt].sym = car(y); + f.bnd[f.cnt].val = EVAL(car(x)); + ++f.cnt, x = cdr(x), y = cdr(y); + } + if (isNil(y)) { + while (--f.i > 0) { + x = val(f.bnd[f.i].sym); + val(f.bnd[f.i].sym) = f.bnd[f.i].val; + f.bnd[f.i].val = x; + } + f.bnd[f.cnt].sym = This, f.bnd[f.cnt++].val = val(This), val(This) = o; + Env.meth = &m; + x = prog(cdr(expr)); + } + else if (y != At) { + f.bnd[f.cnt].sym = y, f.bnd[f.cnt++].val = val(y), val(y) = x; + while (--f.i > 0) { + x = val(f.bnd[f.i].sym); + val(f.bnd[f.i].sym) = f.bnd[f.i].val; + f.bnd[f.i].val = x; + } + f.bnd[f.cnt].sym = This, f.bnd[f.cnt++].val = val(This), val(This) = o; + Env.meth = &m; + x = prog(cdr(expr)); + } + else { + int n, cnt; + cell *arg; + cell c[n = cnt = length(x)]; + + while (--n >= 0) + Push(c[n], EVAL(car(x))), x = cdr(x); + while (--f.i > 0) { + x = val(f.bnd[f.i].sym); + val(f.bnd[f.i].sym) = f.bnd[f.i].val; + f.bnd[f.i].val = x; + } + n = Env.next, Env.next = cnt; + arg = Env.arg, Env.arg = c; + f.bnd[f.cnt].sym = This, f.bnd[f.cnt++].val = val(This), val(This) = o; + Env.meth = &m; + x = prog(cdr(expr)); + if (cnt) + drop(c[cnt-1]); + Env.arg = arg, Env.next = n; + } + while (--f.cnt >= 0) + val(f.bnd[f.cnt].sym) = f.bnd[f.cnt].val; + Env.bind = f.link; + Env.meth = Env.meth->link; + return x; +} + +any method(any x) { + any y, z; + + if (isCell(y = val(x))) { + while (isCell(z = car(y))) { + if (car(z) == TheKey) + return cdr(z); + if (!isCell(y = cdr(y))) + return NULL; + } + do + if (x = method(car(TheCls = y))) + return x; + while (isCell(y = cdr(y))); + } + return NULL; +} + +// (box 'any) -> sym +any doBox(any x) { + x = cdr(x); + return consSym(EVAL(car(x)), Nil); +} + +// (new ['flg|num] ['typ ['any ..]]) -> obj +any doNew(any ex) { + any x, y, *h; + cell c1, c2; + + x = cdr(ex); + if (isCell(y = EVAL(car(x)))) + Push(c1, consSym(Nil,Nil)); + else { + if (isNil(y)) + data(c1) = consSym(Nil,Nil); + else { + y = newId(ex, isNum(y)? (int)unDig(y)/2 : 1); + if (data(c1) = findHash(y, h = Extern + ehash(y))) + tail(data(c1)) = y; + else + *h = cons(data(c1) = consSym(Nil,y), *h); + mkExt(data(c1)); + } + Save(c1); + x = cdr(x), y = EVAL(car(x)); + } + val(data(c1)) = y; + TheKey = T, TheCls = Nil; + if (y = method(data(c1))) + evMethod(data(c1), y, cdr(x)); + else { + Push(c2, Nil); + while (isCell(x = cdr(x))) { + data(c2) = EVAL(car(x)), x = cdr(x); + put(data(c1), data(c2), EVAL(car(x))); + } + } + return Pop(c1); +} + +// (type 'any) -> lst +any doType(any ex) { + any x, y, z; + + x = cdr(ex), x = EVAL(car(x)); + if (isSym(x)) { + Fetch(ex,x); + z = x = val(x); + while (isCell(x)) { + if (!isCell(car(x))) { + y = x; + while (isSym(car(x))) { + if (!isCell(x = cdr(x))) + return isNil(x)? y : Nil; + if (z == x) + return Nil; + } + return Nil; + } + if (z == (x = cdr(x))) + return Nil; + } + } + return Nil; +} + +static bool isa(any cls, any x) { + any z; + + z = x = val(x); + while (isCell(x)) { + if (!isCell(car(x))) { + while (isSym(car(x))) { + if (isExt(car(x))) + return NO; + if (cls == car(x) || isa(cls, car(x))) + return YES; + if (!isCell(x = cdr(x)) || z == x) + return NO; + } + return NO; + } + if (z == (x = cdr(x))) + return NO; + } + return NO; +} + +// (isa 'cls|typ 'any) -> obj | NIL +any doIsa(any ex) { + any x; + cell c1; + + x = cdr(ex), Push(c1, EVAL(car(x))); + x = cdr(x), x = EVAL(car(x)); + if (isSym(x)) { + Fetch(ex,x); + drop(c1); + if (isSym(data(c1))) + return isa(data(c1), x)? x : Nil; + while (isCell(data(c1))) { + if (!isa(car(data(c1)), x)) + return Nil; + data(c1) = cdr(data(c1)); + } + return x; + } + drop(c1); + return Nil; +} + +// (method 'msg 'obj) -> fun +any doMethod(any ex) { + any x; + cell c1; + + x = cdr(ex), Push(c1, EVAL(car(x))); + NeedSym(ex,data(c1)); + x = cdr(x), x = EVAL(car(x)); + NeedSym(ex,x); + Fetch(ex,x); + TheKey = Pop(c1); + return method(x)? : Nil; +} + +// (meth 'obj ..) -> any +any doMeth(any ex) { + any x, y; + cell c1; + + x = cdr(ex), Push(c1, EVAL(car(x))); + NeedSym(ex,data(c1)); + Fetch(ex,data(c1)); + for (TheKey = car(ex); ; TheKey = val(TheKey)) { + if (!isSym(TheKey)) + err(ex, TheKey, "Bad message"); + if (isNum(val(TheKey))) { + TheCls = Nil; + if (y = method(data(c1))) { + x = evMethod(data(c1), y, cdr(x)); + drop(c1); + return x; + } + err(ex, TheKey, "Bad message"); + } + } +} + +// (send 'msg 'obj ['any ..]) -> any +any doSend(any ex) { + any x, y; + cell c1, c2; + + x = cdr(ex), Push(c1, EVAL(car(x))); + NeedSym(ex,data(c1)); + x = cdr(x), Push(c2, EVAL(car(x))); + NeedSym(ex,data(c2)); + Fetch(ex,data(c2)); + TheKey = data(c1), TheCls = Nil; + if (y = method(data(c2))) { + x = evMethod(data(c2), y, cdr(x)); + drop(c1); + return x; + } + err(ex, TheKey, "Bad message"); +} + +// (try 'msg 'obj ['any ..]) -> any +any doTry(any ex) { + any x, y; + cell c1, c2; + + x = cdr(ex), Push(c1, EVAL(car(x))); + NeedSym(ex,data(c1)); + x = cdr(x), Push(c2, EVAL(car(x))); + if (isSym(data(c2))) { + if (isExt(data(c2))) { + if (!isLife(data(c2))) + return Nil; + db(ex,data(c2),1); + } + TheKey = data(c1), TheCls = Nil; + if (y = method(data(c2))) { + x = evMethod(data(c2), y, cdr(x)); + drop(c1); + return x; + } + } + drop(c1); + return Nil; +} + +// (super ['any ..]) -> any +any doSuper(any ex) { + any x, y; + methFrame m; + + m.key = TheKey = Env.meth->key; + x = val(isNil(Env.meth->cls)? val(This) : car(Env.meth->cls)); + while (isCell(car(x))) + x = cdr(x); + while (isCell(x)) { + if (y = method(car(TheCls = x))) { + m.cls = TheCls; + m.link = Env.meth, Env.meth = &m; + x = evExpr(y, cdr(ex)); + Env.meth = Env.meth->link; + return x; + } + x = cdr(x); + } + err(ex, TheKey, "Bad super"); +} + +static any extra(any x) { + any y; + + for (x = val(x); isCell(car(x)); x = cdr(x)); + while (isCell(x)) { + if (x == Env.meth->cls || !(y = extra(car(x)))) { + while (isCell(x = cdr(x))) + if (y = method(car(TheCls = x))) + return y; + return NULL; + } + if (y && num(y) != 1) + return y; + x = cdr(x); + } + return (any)1; +} + +// (extra ['any ..]) -> any +any doExtra(any ex) { + any x, y; + methFrame m; + + m.key = TheKey = Env.meth->key; + if ((y = extra(val(This))) && num(y) != 1) { + m.cls = TheCls; + m.link = Env.meth, Env.meth = &m; + x = evExpr(y, cdr(ex)); + Env.meth = Env.meth->link; + return x; + } + err(ex, TheKey, "Bad extra"); +} + +// (with 'sym . prg) -> any +any doWith(any ex) { + any x; + bindFrame f; + + x = cdr(ex); + if (isNil(x = EVAL(car(x)))) + return Nil; + NeedSym(ex,x); + Bind(This,f), val(This) = x; + x = prog(cddr(ex)); + Unbind(f); + return x; +} + +// (bind 'sym|lst . prg) -> any +any doBind(any ex) { + any x, y; + + x = cdr(ex); + if (isNum(y = EVAL(car(x)))) + argError(ex, y); + if (isNil(y)) + return prog(cdr(x)); + if (isSym(y)) { + bindFrame f; + + Bind(y,f); + x = prog(cdr(x)); + Unbind(f); + return x; + } + { + struct { // bindFrame + struct bindFrame *link; + int i, cnt; + struct {any sym; any val;} bnd[length(y)]; + } f; + + f.link = Env.bind, Env.bind = (bindFrame*)&f; + f.i = f.cnt = 0; + do { + if (isNum(car(y))) + argError(ex, car(y)); + if (isSym(car(y))) { + f.bnd[f.cnt].sym = car(y); + f.bnd[f.cnt].val = val(car(y)); + } + else { + f.bnd[f.cnt].sym = caar(y); + f.bnd[f.cnt].val = val(caar(y)); + val(caar(y)) = cdar(y); + } + ++f.cnt; + } while (isCell(y = cdr(y))); + x = prog(cdr(x)); + while (--f.cnt >= 0) + val(f.bnd[f.cnt].sym) = f.bnd[f.cnt].val; + Env.bind = f.link; + return x; + } +} + +// (job 'lst . prg) -> any +any doJob(any ex) { + any x = cdr(ex); + any y = EVAL(car(x)); + any z; + cell c1; + struct { // bindFrame + struct bindFrame *link; + int i, cnt; + struct {any sym; any val;} bnd[length(y)]; + } f; + + Push(c1,y); + f.link = Env.bind, Env.bind = (bindFrame*)&f; + f.i = f.cnt = 0; + while (isCell(y)) { + f.bnd[f.cnt].sym = caar(y); + f.bnd[f.cnt].val = val(caar(y)); + val(caar(y)) = cdar(y); + ++f.cnt, y = cdr(y); + } + z = prog(cdr(x)); + for (f.cnt = 0, y = Pop(c1); isCell(y); ++f.cnt, y = cdr(y)) { + cdar(y) = val(caar(y)); + val(caar(y)) = f.bnd[f.cnt].val; + } + Env.bind = f.link; + return z; +} + +// (let sym 'any . prg) -> any +// (let (sym 'any ..) . prg) -> any +any doLet(any x) { + any y; + + x = cdr(x); + if (isSym(y = car(x))) { + bindFrame f; + + x = cdr(x), Bind(y,f), val(y) = EVAL(car(x)); + x = prog(cdr(x)); + Unbind(f); + } + else { + struct { // bindFrame + struct bindFrame *link; + int i, cnt; + struct {any sym; any val;} bnd[(length(y)+1)/2]; + } f; + + f.link = Env.bind, Env.bind = (bindFrame*)&f; + f.i = f.cnt = 0; + do { + f.bnd[f.cnt].sym = car(y); + f.bnd[f.cnt].val = val(car(y)); + ++f.cnt; + val(car(y)) = EVAL(cadr(y)); + } while (isCell(y = cddr(y))); + x = prog(cdr(x)); + while (--f.cnt >= 0) + val(f.bnd[f.cnt].sym) = f.bnd[f.cnt].val; + Env.bind = f.link; + } + return x; +} + +// (let? sym 'any . prg) -> any +any doLetQ(any x) { + any y, z; + bindFrame f; + + x = cdr(x), y = car(x), x = cdr(x); + if (isNil(z = EVAL(car(x)))) + return Nil; + Bind(y,f), val(y) = z; + x = prog(cdr(x)); + Unbind(f); + return x; +} + +// (use sym . prg) -> any +// (use (sym ..) . prg) -> any +any doUse(any x) { + any y; + + x = cdr(x); + if (isSym(y = car(x))) { + bindFrame f; + + Bind(y,f); + x = prog(cdr(x)); + Unbind(f); + } + else { + struct { // bindFrame + struct bindFrame *link; + int i, cnt; + struct {any sym; any val;} bnd[length(y)]; + } f; + + f.link = Env.bind, Env.bind = (bindFrame*)&f; + f.i = f.cnt = 0; + do { + f.bnd[f.cnt].sym = car(y); + f.bnd[f.cnt].val = val(car(y)); + ++f.cnt; + } while (isCell(y = cdr(y))); + x = prog(cdr(x)); + while (--f.cnt >= 0) + val(f.bnd[f.cnt].sym) = f.bnd[f.cnt].val; + Env.bind = f.link; + } + return x; +} + +// (and 'any ..) -> any +any doAnd(any x) { + any a; + + x = cdr(x); + do { + if (isNil(a = EVAL(car(x)))) + return Nil; + val(At) = a; + } + while (isCell(x = cdr(x))); + return a; +} + +// (or 'any ..) -> any +any doOr(any x) { + any a; + + x = cdr(x); + do + if (!isNil(a = EVAL(car(x)))) + return val(At) = a; + while (isCell(x = cdr(x))); + return Nil; +} + +// (nand 'any ..) -> flg +any doNand(any x) { + any a; + + x = cdr(x); + do { + if (isNil(a = EVAL(car(x)))) + return T; + val(At) = a; + } + while (isCell(x = cdr(x))); + return Nil; +} + +// (nor 'any ..) -> flg +any doNor(any x) { + any a; + + x = cdr(x); + do { + if (!isNil(a = EVAL(car(x)))) { + val(At) = a; + return Nil; + } + } while (isCell(x = cdr(x))); + return T; +} + +// (xor 'any 'any) -> flg +any doXor(any x) { + bool f; + + x = cdr(x), f = isNil(EVAL(car(x))), x = cdr(x); + return f ^ isNil(EVAL(car(x)))? T : Nil; +} + +// (bool 'any) -> flg +any doBool(any x) {return isNil(EVAL(cadr(x)))? Nil : T;} + +// (not 'any) -> flg +any doNot(any x) { + any a; + + if (isNil(a = EVAL(cadr(x)))) + return T; + val(At) = a; + return Nil; +} + +// (nil . prg) -> NIL +any doNil(any x) { + while (isCell(x = cdr(x))) + if (isCell(car(x))) + evList(car(x)); + return Nil; +} + +// (t . prg) -> T +any doT(any x) { + while (isCell(x = cdr(x))) + if (isCell(car(x))) + evList(car(x)); + return T; +} + +// (prog . prg) -> any +any doProg(any x) {return prog(cdr(x));} + +// (prog1 'any1 . prg) -> any1 +any doProg1(any x) { + cell c1; + + x = cdr(x), Push(c1, val(At) = EVAL(car(x))); + while (isCell(x = cdr(x))) + if (isCell(car(x))) + evList(car(x)); + return Pop(c1); +} + +// (prog2 'any1 'any2 . prg) -> any2 +any doProg2(any x) { + cell c1; + + x = cdr(x), EVAL(car(x)); + x = cdr(x), Push(c1, val(At) = EVAL(car(x))); + while (isCell(x = cdr(x))) + if (isCell(car(x))) + evList(car(x)); + return Pop(c1); +} + +// (if 'any1 'any2 . prg) -> any +any doIf(any x) { + any a; + + x = cdr(x); + if (isNil(a = EVAL(car(x)))) + return prog(cddr(x)); + val(At) = a; + x = cdr(x); + return EVAL(car(x)); +} + +// (if2 'any1 'any2 'any3 'any4 'any5 . prg) -> any +any doIf2(any x) { + any a; + + x = cdr(x); + if (isNil(a = EVAL(car(x)))) { + x = cdr(x); + if (isNil(a = EVAL(car(x)))) + return prog(cddddr(x)); + val(At) = a; + x = cdddr(x); + return EVAL(car(x)); + } + val(At) = a; + x = cdr(x); + if (isNil(a = EVAL(car(x)))) { + x = cddr(x); + return EVAL(car(x)); + } + val(At) = a; + x = cdr(x); + return EVAL(car(x)); +} + +// (ifn 'any1 'any2 . prg) -> any +any doIfn(any x) { + any a; + + x = cdr(x); + if (!isNil(a = EVAL(car(x)))) { + val(At) = a; + return prog(cddr(x)); + } + x = cdr(x); + return EVAL(car(x)); +} + +// (when 'any . prg) -> any +any doWhen(any x) { + any a; + + x = cdr(x); + if (isNil(a = EVAL(car(x)))) + return Nil; + val(At) = a; + return prog(cdr(x)); +} + +// (unless 'any . prg) -> any +any doUnless(any x) { + any a; + + x = cdr(x); + if (!isNil(a = EVAL(car(x)))) { + val(At) = a; + return Nil; + } + return prog(cdr(x)); +} + +// (cond ('any1 . prg1) ('any2 . prg2) ..) -> any +any doCond(any x) { + any a; + + while (isCell(x = cdr(x))) { + if (!isNil(a = EVAL(caar(x)))) { + val(At) = a; + return prog(cdar(x)); + } + } + return Nil; +} + +// (nond ('any1 . prg1) ('any2 . prg2) ..) -> any +any doNond(any x) { + any a; + + while (isCell(x = cdr(x))) { + if (isNil(a = EVAL(caar(x)))) + return prog(cdar(x)); + val(At) = a; + } + return Nil; +} + +// (case 'any (any1 . prg1) (any2 . prg2) ..) -> any +any doCase(any x) { + any y, z; + + x = cdr(x), val(At) = EVAL(car(x)); + while (isCell(x = cdr(x))) { + y = car(x), z = car(y); + if (z == T || equal(val(At), z)) + return prog(cdr(y)); + if (isCell(z)) { + do + if (equal(val(At), car(z))) + return prog(cdr(y)); + while (isCell(z = cdr(z))); + } + } + return Nil; +} + +// (state 'var (sym|lst exe [. prg]) ..) -> any +any doState(any ex) { + any x, y, a; + cell c1; + + x = cdr(ex); + Push(c1, EVAL(car(x))); + NeedVar(ex,data(c1)); + CheckVar(ex,data(c1)); + while (isCell(x = cdr(x))) { + y = car(x); + if (car(y) == T || memq(val(data(c1)), car(y))) { + y = cdr(y); + if (!isNil(a = EVAL(car(y)))) { + val(At) = val(data(c1)) = a; + drop(c1); + return prog(cdr(y)); + } + } + } + drop(c1); + return Nil; +} + +// (while 'any . prg) -> any +any doWhile(any x) { + any cond, a; + cell c1; + + cond = car(x = cdr(x)), x = cdr(x); + Push(c1, Nil); + while (!isNil(a = EVAL(cond))) { + val(At) = a; + data(c1) = prog(x); + } + return Pop(c1); +} + +// (until 'any . prg) -> any +any doUntil(any x) { + any cond, a; + cell c1; + + cond = car(x = cdr(x)), x = cdr(x); + Push(c1, Nil); + while (isNil(a = EVAL(cond))) + data(c1) = prog(x); + val(At) = a; + return Pop(c1); +} + +// (loop ['any | (NIL 'any . prg) | (T 'any . prg) ..]) -> any +any doLoop(any ex) { + any x, y, a; + + for (;;) { + x = cdr(ex); + do { + if (isCell(y = car(x))) { + if (isNil(car(y))) { + y = cdr(y); + if (isNil(a = EVAL(car(y)))) + return prog(cdr(y)); + val(At) = a; + } + else if (car(y) == T) { + y = cdr(y); + if (!isNil(a = EVAL(car(y)))) { + val(At) = a; + return prog(cdr(y)); + } + } + else + evList(y); + } + } while (isCell(x = cdr(x))); + } +} + +// (do 'flg|num ['any | (NIL 'any . prg) | (T 'any . prg) ..]) -> any +any doDo(any x) { + any y, z, a; + cell c1; + + x = cdr(x); + if (isNil(data(c1) = EVAL(car(x)))) + return Nil; + Save(c1); + if (isNum(data(c1))) { + if (isNeg(data(c1))) { + drop(c1); + return Nil; + } + data(c1) = bigCopy(data(c1)); + } + x = cdr(x), z = Nil; + for (;;) { + if (isNum(data(c1))) { + if (IsZero(data(c1))) { + drop(c1); + return z; + } + digSub1(data(c1)); + } + y = x; + do { + if (!isNum(z = car(y))) { + if (isSym(z)) + z = val(z); + else if (isNil(car(z))) { + z = cdr(z); + if (isNil(a = EVAL(car(z)))) { + drop(c1); + return prog(cdr(z)); + } + val(At) = a; + z = Nil; + } + else if (car(z) == T) { + z = cdr(z); + if (!isNil(a = EVAL(car(z)))) { + val(At) = a; + drop(c1); + return prog(cdr(z)); + } + z = Nil; + } + else + z = evList(z); + } + } while (isCell(y = cdr(y))); + } +} + +// (at '(cnt1 . cnt2) . prg) -> any +any doAt(any ex) { + any x; + + x = cdr(ex), x = EVAL(car(x)); + NeedCell(ex,x); + NeedCnt(ex,car(x)); + NeedCnt(ex,cdr(x)); + if (num(setDig(car(x), unDig(car(x))+2)) < unDig(cdr(x))) + return Nil; + setDig(car(x), 0); + return prog(cddr(ex)); +} + +// (for sym 'num ['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 +any doFor(any x) { + any y, body, cond, a; + cell c1; + struct { // bindFrame + struct bindFrame *link; + int i, cnt; + struct {any sym; any val;} bnd[2]; + } f; + + f.link = Env.bind, Env.bind = (bindFrame*)&f; + f.i = 0; + if (!isCell(y = car(x = cdr(x))) || !isCell(cdr(y))) { + if (!isCell(y)) { + f.cnt = 1; + f.bnd[0].sym = y; + f.bnd[0].val = val(y); + } + else { + f.cnt = 2; + f.bnd[0].sym = cdr(y); + f.bnd[0].val = val(cdr(y)); + f.bnd[1].sym = car(y); + f.bnd[1].val = val(car(y)); + val(f.bnd[1].sym) = Zero; + } + y = Nil; + x = cdr(x), Push(c1, EVAL(car(x))); + if (isNum(data(c1))) + val(f.bnd[0].sym) = Zero; + body = x = cdr(x); + for (;;) { + if (isNum(data(c1))) { + val(f.bnd[0].sym) = bigCopy(val(f.bnd[0].sym)); + digAdd(val(f.bnd[0].sym), 2); + if (bigCompare(val(f.bnd[0].sym), data(c1)) > 0) + break; + } + else { + if (!isCell(data(c1))) + break; + val(f.bnd[0].sym) = car(data(c1)); + if (!isCell(data(c1) = cdr(data(c1)))) + data(c1) = Nil; + } + if (f.cnt == 2) { + val(f.bnd[1].sym) = bigCopy(val(f.bnd[1].sym)); + digAdd(val(f.bnd[1].sym), 2); + } + do { + if (!isNum(y = car(x))) { + if (isSym(y)) + y = val(y); + else if (isNil(car(y))) { + y = cdr(y); + if (isNil(a = EVAL(car(y)))) { + y = prog(cdr(y)); + goto for1; + } + val(At) = a; + y = Nil; + } + else if (car(y) == T) { + y = cdr(y); + if (!isNil(a = EVAL(car(y)))) { + val(At) = a; + y = prog(cdr(y)); + goto for1; + } + y = Nil; + } + else + y = evList(y); + } + } while (isCell(x = cdr(x))); + x = body; + } + for1: + drop(c1); + if (f.cnt == 2) + val(f.bnd[1].sym) = f.bnd[1].val; + val(f.bnd[0].sym) = f.bnd[0].val; + Env.bind = f.link; + return y; + } + if (!isCell(car(y))) { + f.cnt = 1; + f.bnd[0].sym = car(y); + f.bnd[0].val = val(car(y)); + } + else { + f.cnt = 2; + f.bnd[0].sym = cdar(y); + f.bnd[0].val = val(cdar(y)); + f.bnd[1].sym = caar(y); + f.bnd[1].val = val(caar(y)); + val(f.bnd[1].sym) = Zero; + } + y = cdr(y); + val(f.bnd[0].sym) = EVAL(car(y)); + y = cdr(y), cond = car(y), y = cdr(y); + Push(c1,Nil); + body = x = cdr(x); + while (!isNil(a = EVAL(cond))) { + val(At) = a; + if (f.cnt == 2) { + val(f.bnd[1].sym) = bigCopy(val(f.bnd[1].sym)); + digAdd(val(f.bnd[1].sym), 2); + } + do { + if (!isNum(data(c1) = car(x))) { + if (isSym(data(c1))) + data(c1) = val(data(c1)); + else if (isNil(car(data(c1)))) { + data(c1) = cdr(data(c1)); + if (isNil(a = EVAL(car(data(c1))))) { + data(c1) = prog(cdr(data(c1))); + goto for2; + } + val(At) = a; + data(c1) = Nil; + } + else if (car(data(c1)) == T) { + data(c1) = cdr(data(c1)); + if (!isNil(a = EVAL(car(data(c1))))) { + val(At) = a; + data(c1) = prog(cdr(data(c1))); + goto for2; + } + data(c1) = Nil; + } + else + data(c1) = evList(data(c1)); + } + } while (isCell(x = cdr(x))); + if (isCell(y)) + val(f.bnd[0].sym) = prog(y); + x = body; + } +for2: + if (f.cnt == 2) + val(f.bnd[1].sym) = f.bnd[1].val; + val(f.bnd[0].sym) = f.bnd[0].val; + Env.bind = f.link; + return Pop(c1); +} + +// (catch 'any . prg) -> any +any doCatch(any x) { + any y; + catchFrame f; + + x = cdr(x), f.tag = EVAL(car(x)), f.fin = Zero; + f.link = CatchPtr, CatchPtr = &f; + f.env = Env; + y = setjmp(f.rst)? Thrown : prog(cdr(x)); + CatchPtr = f.link; + return y; +} + +// (throw 'sym 'any) +any doThrow(any ex) { + any x, tag; + catchFrame *p; + + x = cdr(ex), tag = EVAL(car(x)); + x = cdr(x), Thrown = EVAL(car(x)); + for (p = CatchPtr; p; p = p->link) + if (p->tag == T || tag == p->tag) { + unwind(p); + longjmp(p->rst, 1); + } + err(ex, tag, "Tag not found"); +} + +// (finally exe . prg) -> any +any doFinally(any x) { + catchFrame f; + cell c1; + + x = cdr(x), f.tag = NULL, f.fin = car(x); + f.link = CatchPtr, CatchPtr = &f; + f.env = Env; + Push(c1, prog(cdr(x))); + EVAL(f.fin); + CatchPtr = f.link; + return Pop(c1); +} + +static outFrame Out; +static struct { // bindFrame + struct bindFrame *link; + int i, cnt; + struct {any sym; any val;} bnd[3]; // for 'Up', 'Run' and 'At' +} Brk; + +any brkLoad(any x) { + if (!Env.brk && isatty(STDIN_FILENO) && isatty(STDOUT_FILENO)) { + Env.brk = YES; + Brk.cnt = 3; + Brk.bnd[0].sym = Up, Brk.bnd[0].val = val(Up), val(Up) = x; + Brk.bnd[1].sym = Run, Brk.bnd[1].val = val(Run), val(Run) = Nil; + Brk.bnd[2].sym = At, Brk.bnd[2].val = val(At); + Brk.link = Env.bind, Env.bind = (bindFrame*)&Brk; + Out.pid = 0, Out.fd = STDOUT_FILENO, pushOutFiles(&Out); + print(x), newline(); + load(NULL, '!', Nil); + popOutFiles(); + val(At) = Brk.bnd[2].val; + val(Run) = Brk.bnd[1].val; + x = val(Up), val(Up) = Brk.bnd[0].val; + Env.bind = Brk.link; + Env.brk = NO; + } + return x; +} + +// (! . exe) -> any +any doBreak(any x) { + x = cdr(x); + if (!isNil(val(Dbg))) + x = brkLoad(x); + return EVAL(x); +} + +// (e . prg) -> any +any doE(any ex) { + any x; + inFrame *in; + cell c1, at, key; + + if (!Env.brk) + err(ex, NULL, "No Break"); + Push(c1,val(Dbg)), val(Dbg) = Nil; + Push(at, val(At)), val(At) = Brk.bnd[2].val; + Push(key, val(Run)), val(Run) = Brk.bnd[1].val; + in = Env.inFrames, popInFiles(); + popOutFiles(); + x = isCell(cdr(ex))? prog(cdr(ex)) : EVAL(val(Up)); + pushOutFiles(&Out); + pushInFiles(in); + val(Run) = data(key); + val(At) = data(at); + val(Dbg) = Pop(c1); + return x; +} + +static void traceIndent(int i, any x, char *s) { + if (i > 64) + i = 64; + while (--i >= 0) + Env.put(' '); + if (isSym(x)) + print(x); + else + print(car(x)), space(), print(cdr(x)), space(), print(val(This)); + outString(s); +} + +// ($ sym|lst lst . prg) -> any +any doTrace(any x) { + any foo, body; + outFile *oSave; + void (*putSave)(int); + cell c1; + + x = cdr(x); + if (isNil(val(Dbg))) + return prog(cddr(x)); + oSave = OutFile, putSave = Env.put; + OutFile = OutFiles[STDERR_FILENO], Env.put = putStdout; + foo = car(x); + x = cdr(x), body = cdr(x); + traceIndent(++Env.trace, foo, " :"); + for (x = car(x); isCell(x); x = cdr(x)) + space(), print(val(car(x))); + if (!isNil(x)) { + if (x != At) + space(), print(val(x)); + else { + int i = Env.next; + + while (--i >= 0) + space(), print(data(Env.arg[i])); + } + } + newline(); + Env.put = putSave, OutFile = oSave; + Push(c1, prog(body)); + OutFile = OutFiles[STDERR_FILENO], Env.put = putStdout; + traceIndent(Env.trace--, foo, " = "), print(data(c1)); + newline(); + Env.put = putSave, OutFile = oSave; + return Pop(c1); +} + +// (sys 'any ['any]) -> sym +any doSys(any x) { + any y; + + y = evSym(x = cdr(x)); + { + char nm[bufSize(y)]; + + bufString(y,nm); + if (!isCell(x = cdr(x))) + return mkStr(getenv(nm)); + y = evSym(x); + { + char val[bufSize(y)]; + + bufString(y,val); + return setenv(nm,val,1)? Nil : y; + } + } +} + +// (call 'any ..) -> flg +any doCall(any ex) { + pid_t pid; + any x, y; + int res, i, ac = length(x = cdr(ex)); + char *av[ac+1]; + + if (ac == 0) + return Nil; + av[0] = alloc(NULL, pathSize(y = evSym(x))), pathString(y, av[0]); + for (i = 1; isCell(x = cdr(x)); ++i) + av[i] = alloc(NULL, bufSize(y = evSym(x))), bufString(y, av[i]); + av[ac] = NULL; + flushAll(); + if ((pid = fork()) == 0) { + setpgid(0,0); + tcsetpgrp(0,getpgrp()); + execvp(av[0], av); + execError(av[0]); + } + i = 0; do + free(av[i]); + while (++i < ac); + if (pid < 0) + err(ex, NULL, "fork"); + setpgid(pid,0); + tcsetpgrp(0,pid); + for (;;) { + while (waitpid(pid, &res, WUNTRACED) < 0) { + if (errno != EINTR) + err(ex, NULL, "wait pid"); + if (Signal) + sighandler(ex); + } + tcsetpgrp(0,getpgrp()); + if (!WIFSTOPPED(res)) + return res == 0? T : Nil; + load(NULL, '+', Nil); + tcsetpgrp(0,pid); + kill(pid, SIGCONT); + } +} + +// (tick (cnt1 . cnt2) . prg) -> any +any doTick(any ex) { + any x; + clock_t n1, n2, save1, save2; + struct tms tim; + static clock_t ticks1, ticks2; + + save1 = ticks1, save2 = ticks2; + times(&tim), n1 = tim.tms_utime, n2 = tim.tms_stime; + x = prog(cddr(ex)); + times(&tim); + n1 = (tim.tms_utime - n1) - (ticks1 - save1); + n2 = (tim.tms_stime - n2) - (ticks2 - save2); + setDig(caadr(ex), unDig(caadr(ex)) + 2*n1); + setDig(cdadr(ex), unDig(cdadr(ex)) + 2*n2); + ticks1 += n1, ticks2 += n2; + return x; +} + +// (ipid) -> pid | NIL +any doIpid(any ex __attribute__((unused))) { + if (Env.inFrames && Env.inFrames->pid > 1) + return boxCnt((long)Env.inFrames->pid); + return Nil; +} + +// (opid) -> pid | NIL +any doOpid(any ex __attribute__((unused))) { + if (Env.outFrames && Env.outFrames->pid > 1) + return boxCnt((long)Env.outFrames->pid); + return Nil; +} + +// (kill 'pid ['cnt]) -> flg +any doKill(any ex) { + pid_t pid; + + pid = (pid_t)evCnt(ex,cdr(ex)); + return kill(pid, isCell(cddr(ex))? (int)evCnt(ex,cddr(ex)) : SIGTERM)? Nil : T; +} + +static void allocChildren(void) { + int i; + + Child = alloc(Child, (Children + 8) * sizeof(child)); + for (i = 0; i < 8; ++i) + Child[Children++].pid = 0; +} + +pid_t forkLisp(any ex) { + pid_t n; + int i, hear[2], tell[2]; + static int mic[2]; + + flushAll(); + if (!Spkr) { + if (pipe(mic) < 0) + pipeError(ex, "open"); + closeOnExec(ex, mic[0]), closeOnExec(ex, mic[1]); + Spkr = mic[0]; + } + if (pipe(hear) < 0 || pipe(tell) < 0) + pipeError(ex, "open"); + closeOnExec(ex, hear[0]), closeOnExec(ex, hear[1]); + closeOnExec(ex, tell[0]), closeOnExec(ex, tell[1]); + for (i = 0; i < Children; ++i) + if (!Child[i].pid) + break; + if ((n = fork()) < 0) + err(ex, NULL, "fork"); + if (n == 0) { + void *p; + + Slot = i; + Spkr = 0; + Mic = mic[1]; + close(hear[1]), close(tell[0]), close(mic[0]); + if (Hear) + close(Hear), closeInFile(Hear), closeOutFile(Hear); + initInFile(Hear = hear[0], NULL); + if (Tell) + close(Tell); + Tell = tell[1]; + for (i = 0; i < Children; ++i) + if (Child[i].pid) + close(Child[i].hear), close(Child[i].tell), free(Child[i].buf); + Children = 0, free(Child), Child = NULL; + for (p = Env.inFrames; p; p = ((inFrame*)p)->link) + ((inFrame*)p)->pid = 0; + for (p = Env.outFrames; p; p = ((outFrame*)p)->link) + ((outFrame*)p)->pid = 0; + for (p = CatchPtr; p; p = ((catchFrame*)p)->link) + ((catchFrame*)p)->fin = Zero; + free(Termio), Termio = NULL; + if (Repl) + ++Repl; + val(PPid) = val(Pid); + val(Pid) = boxCnt(getpid()); + run(val(Fork)); + val(Fork) = Nil; + return 0; + } + if (i == Children) + allocChildren(); + close(hear[0]), close(tell[1]); + Child[i].pid = n; + Child[i].hear = tell[0]; + nonblocking(Child[i].tell = hear[1]); + Child[i].ofs = Child[i].cnt = 0; + Child[i].buf = NULL; + return n; +} + +// (fork) -> pid | NIL +any doFork(any ex) { + int n; + + return (n = forkLisp(ex))? boxCnt(n) : Nil; +} + +// (bye 'cnt|NIL) +any doBye(any ex) { + any x = EVAL(cadr(ex)); + + bye(isNil(x)? 0 : xCnt(ex,x)); +} diff --git a/src/gc.c b/src/gc.c @@ -0,0 +1,185 @@ +/* 04may09abu + * (c) Software Lab. Alexander Burger + */ + +#include "pico.h" + +/* Mark data */ +static void mark(any x) { + cell *p; + + while (num((p = cellPtr(x))->cdr) & 1) { + *(word*)&cdr(p) &= ~1; + if (!isNum(x)) + mark(p->car); + x = p->cdr; + } +} + +/* Garbage collector */ +static void gc(long c) { + any p, *pp, x; + heap *h; + int i; + + val(DB) = Nil; + h = Heaps; + do { + p = h->cells + CELLS-1; + do + *(word*)&cdr(p) |= 1; + while (--p >= h->cells); + } while (h = h->next); + /* Mark */ + mark(Nil+1); + mark(Alarm), mark(Line), mark(Zero), mark(One); + for (i = 0; i < IHASH; ++i) + mark(Intern[i]), mark(Transient[i]); + mark(ApplyArgs), mark(ApplyBody); + for (p = Env.stack; p; p = cdr(p)) + mark(car(p)); + for (p = (any)Env.bind; p; p = (any)((bindFrame*)p)->link) + for (i = ((bindFrame*)p)->cnt; --i >= 0;) { + mark(((bindFrame*)p)->bnd[i].sym); + mark(((bindFrame*)p)->bnd[i].val); + } + for (p = (any)CatchPtr; p; p = (any)((catchFrame*)p)->link) { + if (((catchFrame*)p)->tag) + mark(((catchFrame*)p)->tag); + mark(((catchFrame*)p)->fin); + } + for (p = (any)Env.meth; p; p = (any)((methFrame*)p)->link) + mark(((methFrame*)p)->key), mark(((methFrame*)p)->cls); + for (i = 0; i < EHASH; ++i) + for (p = Extern[i]; isCell(p); p = (any)(num(p->cdr) & ~1)) + if (num(val(p->car)) & 1) { + for (x = tail1(p->car); !isSym(x); x = cdr(cellPtr(x))); + if ((x = (any)(num(x) & ~1)) == At2 || x == At3) + mark(p->car); // Keep if dirty or deleted + } + if (num(val(val(DB) = DbVal)) & 1) { + val(DbVal) = cdr(numCell(DbTail)) = Nil; + tail(DbVal) = ext(DbTail); + } + for (i = 0; i < EHASH; ++i) + for (pp = Extern + i; isCell(p = *pp);) + if (num(val(p->car)) & 1) + *pp = (cell*)(num(p->cdr) & ~1); + else + *(word*)(pp = &cdr(p)) &= ~1; + /* Sweep */ + Avail = NULL; + h = Heaps; + if (c) { + do { + p = h->cells + CELLS-1; + do + if (num(p->cdr) & 1) + Free(p), --c; + while (--p >= h->cells); + } while (h = h->next); + while (c >= 0) + heapAlloc(), c -= CELLS; + } + else { + heap **hp = &Heaps; + cell *av; + + do { + c = CELLS; + av = Avail; + p = h->cells + CELLS-1; + do + if (num(p->cdr) & 1) + Free(p), --c; + while (--p >= h->cells); + if (c) + hp = &h->next, h = h->next; + else + Avail = av, h = h->next, free(*hp), *hp = h; + } while (h); + } +} + +// (gc ['cnt]) -> cnt | NIL +any doGc(any x) { + x = cdr(x); + gc(isNum(x = EVAL(car(x)))? CELLS*unBox(x) : CELLS); + return x; +} + +/* Construct a cell */ +any cons(any x, any y) { + cell *p; + + if (!(p = Avail)) { + cell c1, c2; + + Push(c1,x); + Push(c2,y); + gc(CELLS); + drop(c1); + p = Avail; + } + Avail = p->car; + p->car = x; + p->cdr = y; + return p; +} + +/* Construct a symbol */ +any consSym(any v, any x) { + cell *p; + + if (!(p = Avail)) { + cell c1, c2; + + Push(c1,v); + Push(c2,x); + gc(CELLS); + drop(c1); + p = Avail; + } + Avail = p->car; + p = symPtr(p); + tail(p) = x; + val(p) = v; + return p; +} + +/* Construct a string */ +any consStr(any x) { + cell *p; + + if (!(p = Avail)) { + cell c1; + + Push(c1,x); + gc(CELLS); + drop(c1); + p = Avail; + } + Avail = p->car; + p = symPtr(p); + tail(p) = x; + val(p) = p; + return p; +} + +/* Construct a number cell */ +any consNum(word n, any x) { + cell *p; + + if (!(p = Avail)) { + cell c1; + + Push(c1,x); + gc(CELLS); + drop(c1); + p = Avail; + } + Avail = p->car; + p->car = (any)n; + p->cdr = x; + return numPtr(p); +} diff --git a/src/ht.c b/src/ht.c @@ -0,0 +1,368 @@ +/* 01apr10abu + * (c) Software Lab. Alexander Burger + */ + +#include "pico.h" + +static char *HtOK[] = { + "<b>", "</b>", + "<i>", "</i>", + "<u>", "</u>", + "<p>", "</p>", + "<pre>", "</pre>", + "<div ", "</div>", + "<br>", "<hr>", NULL +}; + +static bool findHtOK(char *s) { + char **p, *q, *t; + + for (p = HtOK; *p; ++p) + for (q = *p, t = s;;) { + if (*q != *t) + break; + if (*++q == '\0') + return YES; + if (*++t == '\0') + break; + } + return NO; +} + +// (ht:Prin 'sym ..) -> sym +any Prin(any x) { + any y = Nil; + + while (isCell(x = cdr(x))) { + if (isNum(y = EVAL(car(x))) || isCell(y) || isExt(y)) + prin(y); + else { + int c; + char *p, *q, nm[bufSize(y)]; + + bufString(y, nm); + for (p = nm; *p;) { + if (findHtOK(p) && (q = strchr(p,'>'))) + do + Env.put(*p++); + while (p <= q); + else { + switch (*(byte*)p) { + case '<': + outString("&lt;"); + break; + case '>': + outString("&gt;"); + break; + case '&': + outString("&amp;"); + break; + case '"': + outString("&quot;"); + break; + case 0xFF: + Env.put(0xEF); + Env.put(0xBF); + Env.put(0xBF); + break; + default: + Env.put(c = *p); + if ((c & 0x80) != 0) { + Env.put(*++p); + if ((c & 0x20) != 0) + Env.put(*++p); + } + } + ++p; + } + } + } + } + return y; +} + +static void putHex(int c) { + int n; + + Env.put('%'); + if ((n = c >> 4 & 0xF) > 9) + n += 7; + Env.put(n + '0'); + if ((n = c & 0xF) > 9) + n += 7; + Env.put(n + '0'); +} + +static void htEncode(char *p) { + int c; + + while (c = *p++) { + if (strchr(" \"#%&:;<=>?_", c)) + putHex(c); + else { + Env.put(c); + if ((c & 0x80) != 0) { + Env.put(*p++); + if ((c & 0x20) != 0) + Env.put(*p++); + } + } + } +} + +static void htFmt(any x) { + any y; + + if (isNum(x)) + Env.put('+'), prin(x); + else if (isCell(x)) + do + Env.put('_'), htFmt(car(x)); + while (isCell(x = cdr(x))); + else if (isNum(y = name(x))) { + char nm[bufSize(x)]; + + bufString(x, nm); + if (isExt(x)) + Env.put('-'), htEncode(nm); + else if (hashed(x, ihash(y), Intern)) + Env.put('$'), htEncode(nm); + else if (strchr("$+-", *nm)) { + putHex(*nm); + htEncode(nm+1); + } + else + htEncode(nm); + } +} + +// (ht:Fmt 'any ..) -> sym +any Fmt(any x) { + int n, i; + cell c[length(x = cdr(x))]; + + for (n = 0; isCell(x); ++n, x = cdr(x)) + Push(c[n], EVAL(car(x))); + begString(); + for (i = 0; i < n;) { + htFmt(data(c[i])); + if (++i != n) + Env.put('&'); + } + x = endString(); + if (n) + drop(c[0]); + return x; +} + +static int getHex(any *p) { + int n, m; + + n = firstByte(car(*p)), *p = cdr(*p); + if ((n -= '0') > 9) + n = (n & 0xDF) - 7; + m = firstByte(car(*p)), *p = cdr(*p); + if ((m -= '0') > 9) + m = (m & 0xDF) - 7; + return n << 4 | m; +} + +static bool head(char *s, any x) { + while (*s) { + if (*s++ != firstByte(car(x))) + return NO; + x = cdr(x); + } + return YES; +} + +static int getUnicode(any *p) { + int c, n = 0; + any x = cdr(*p); + + while ((c = firstByte(car(x))) >= '0' && c <= '9') { + n = n * 10 + c - '0'; + x = cdr(x); + } + if (n && c == ';') { + *p = cdr(x); + return n; + } + return 0; +} + +// (ht:Pack 'lst) -> sym +any Pack(any x) { + int c; + cell c1; + + x = EVAL(cadr(x)); + begString(); + Push(c1,x); + while (isCell(x)) { + if ((c = firstByte(car(x))) == '%') + x = cdr(x), Env.put(getHex(&x)); + else if (c != '&') + outName(car(x)), x = cdr(x); + else if (head("lt;", x = cdr(x))) + Env.put('<'), x = cdddr(x); + else if (head("gt;", x)) + Env.put('>'), x = cdddr(x); + else if (head("amp;", x)) + Env.put('&'), x = cddddr(x); + else if (head("quot;", x)) + Env.put('"'), x = cddr(cdddr(x)); + else if (head("nbsp;", x)) + Env.put(' '), x = cddr(cdddr(x)); + else if (firstByte(car(x)) == '#' && (c = getUnicode(&x))) + outName(mkChar(c)); + else + Env.put('&'); + } + return endString(); +} + +/*** Read content length bytes */ +// (ht:Read 'cnt) -> lst +any Read(any ex) { + any x; + int n, c; + cell c1; + + if ((n = evCnt(ex, cdr(ex))) <= 0) + return Nil; + if (!Chr) + Env.get(); + if (Chr < 0) + return Nil; + if ((c = getChar()) >= 128) { + --n; + if (c >= 2048) + --n; + } + if (--n < 0) + return Nil; + Push(c1, x = cons(mkChar(c), Nil)); + while (n) { + Env.get(); + if (Chr < 0) { + data(c1) = Nil; + break; + } + if ((c = getChar()) >= 128) { + --n; + if (c >= 2048) + --n; + } + if (--n < 0) { + data(c1) = Nil; + break; + } + x = cdr(x) = cons(mkChar(c), Nil); + } + Chr = 0; + return Pop(c1); +} + + +/*** Chunked Encoding ***/ +#define CHUNK 4000 +static int Cnt; +static void (*Get)(void); +static void (*Put)(int); +static char Chunk[CHUNK]; + +static int chrHex(void) { + if (Chr >= '0' && Chr <= '9') + return Chr - 48; + else if (Chr >= 'A' && Chr <= 'F') + return Chr - 55; + else if (Chr >= 'a' && Chr <= 'f') + return Chr - 87; + else + return -1; +} + +static void chunkSize(void) { + int n; + + if (!Chr) + Get(); + if ((Cnt = chrHex()) >= 0) { + while (Get(), (n = chrHex()) >= 0) + Cnt = Cnt << 4 | n; + while (Chr != '\n') { + if (Chr < 0) + return; + Get(); + } + Get(); + if (Cnt == 0) { + Get(); // Skip '\r' of empty line + Chr = 0; // Discard '\n' + } + } +} + +static void getChunked(void) { + if (Cnt <= 0) + Chr = -1; + else { + Get(); + if (--Cnt == 0) { + Get(), Get(); // Skip '\n', '\r' + chunkSize(); + } + } +} + +// (ht:In 'flg . prg) -> any +any In(any x) { + x = cdr(x); + if (isNil(EVAL(car(x)))) + return prog(cdr(x)); + Get = Env.get, Env.get = getChunked; + chunkSize(); + x = prog(cdr(x)); + Env.get = Get; + Chr = 0; + return x; +} + +static void wrChunk(void) { + int i; + char buf[BITS/2]; + + sprintf(buf, "%x\r\n", Cnt); + i = 0; + do + Put(buf[i]); + while (buf[++i]); + for (i = 0; i < Cnt; ++i) + Put(Chunk[i]); + Put('\r'), Put('\n'); +} + +static void putChunked(int c) { + Chunk[Cnt++] = c; + if (Cnt == CHUNK) + wrChunk(), Cnt = 0; +} + +// (ht:Out 'flg . prg) -> any +any Out(any x) { + x = cdr(x); + if (isNil(EVAL(car(x)))) + x = prog(cdr(x)); + else { + Cnt = 0; + Put = Env.put, Env.put = putChunked; + x = prog(cdr(x)); + if (Cnt) + wrChunk(); + Env.put = Put; + outString("0\r\n\r\n"); + } + flush(OutFile); + return x; +} diff --git a/src/httpGate.c b/src/httpGate.c @@ -0,0 +1,309 @@ +/* 20jul09abu + * (c) Software Lab. Alexander Burger + */ + +#include <stdio.h> +#include <stdlib.h> +#include <unistd.h> +#include <fcntl.h> +#include <errno.h> +#include <ctype.h> +#include <string.h> +#include <signal.h> +#include <netdb.h> +#include <time.h> +#include <sys/time.h> +#include <sys/stat.h> +#include <sys/socket.h> +#include <arpa/inet.h> +#include <netinet/tcp.h> +#include <netinet/in.h> + +#include <openssl/pem.h> +#include <openssl/ssl.h> +#include <openssl/err.h> + +typedef enum {NO,YES} bool; + +static int Http1; + +static char Head_410[] = + "HTTP/1.0 410 Gone\r\n" + "Server: PicoLisp\r\n" + "Content-Type: text/html; charset=utf-8\r\n" + "\r\n"; + +static void giveup(char *msg) { + fprintf(stderr, "httpGate: %s\n", msg); + exit(2); +} + +static inline bool pre(char *p, char *s) { + while (*s) + if (*p++ != *s++) + return NO; + return YES; +} + +static char *ses(char *buf, int port, int *len) { + int np; + char *p, *q; + + if (Http1 == 0) + return buf; + if (pre(buf, "GET /")) { + np = (int)strtol(buf+5, &q, 10); + if (q == buf+5 || *q != '/' || np < 1024 || np > 65535) + return buf; + p = q++ - 4; + do + if (*q < '0' || *q > '9') + return buf; + while (*++q != '~'); + if (np == port) { + p[0] = 'G', p[1] = 'E', p[2] = 'T', p[3] = ' '; + *len -= p - buf; + return p; + } + return NULL; + } + if (pre(buf, "POST /")) { + np = (int)strtol(buf+6, &q, 10); + if (q == buf+6 || *q != '/' || np < 1024 || np > 65535) + return buf; + p = q++ - 5; + do + if (*q < '0' || *q > '9') + return buf; + while (*++q != '~'); + if (np == port) { + p[0] = 'P', p[1] = 'O', p[2] = 'S', p[3] = 'T', p[4] = ' '; + *len -= p - buf; + return p; + } + return NULL; + } + return buf; +} + +static int slow(SSL *ssl, int fd, char *p, int cnt) { + int n; + + while ((n = ssl? SSL_read(ssl, p, cnt) : read(fd, p, cnt)) < 0) + if (errno != EINTR) + return 0; + return n; +} + +static void wrBytes(int fd, char *p, int cnt) { + int n; + + do + if ((n = write(fd, p, cnt)) >= 0) + p += n, cnt -= n; + else if (errno != EINTR) + exit(1); + while (cnt); +} + +static void sslWrite(SSL *ssl, void *p, int cnt) { + if (SSL_write(ssl, p, cnt) <= 0) + exit(1); +} + +static int gateSocket(void) { + int sd; + + if ((sd = socket(AF_INET, SOCK_STREAM, 0)) < 0) + exit(1); + return sd; +} + +static int gatePort(int port) { + int n, sd; + struct sockaddr_in addr; + + memset(&addr, 0, sizeof(addr)); + addr.sin_family = AF_INET; + addr.sin_addr.s_addr = htonl(INADDR_ANY); + addr.sin_port = htons((unsigned short)port); + n = 1, setsockopt(sd = gateSocket(), SOL_SOCKET, SO_REUSEADDR, &n, sizeof(n)); + if (bind(sd, (struct sockaddr*)&addr, sizeof(addr)) < 0) + exit(1); + if (listen(sd,5) < 0) + exit(1); + return sd; +} + +static int gateConnect(unsigned short port) { + int sd; + struct sockaddr_in addr; + + memset(&addr, 0, sizeof(addr)); + addr.sin_addr.s_addr = inet_addr("127.0.0.1"); + sd = gateSocket(); + addr.sin_family = AF_INET; + addr.sin_port = htons(port); + return connect(sd, (struct sockaddr*)&addr, sizeof(addr)) < 0? -1 : sd; +} + + +static pid_t Buddy; + +static void doSigAlarm(int n __attribute__((unused))) { + kill(Buddy, SIGTERM); + exit(0); +} + +static void doSigUsr1(int n __attribute__((unused))) { + alarm(420); +} + +int main(int ac, char *av[]) { + int cnt = ac>4? ac-3 : 1, ports[cnt], n, sd, cli, srv; + struct sockaddr_in addr; + char *gate; + SSL_CTX *ctx; + SSL *ssl; + + if (ac < 3) + giveup("port dflt [pem [alt ..]]"); + + sd = gatePort(atoi(av[1])); // e.g. 80 or 443 + ports[0] = atoi(av[2]); // e.g. 8080 + if (ac == 3 || *av[3] == '\0') + ssl = NULL, gate = "Gate: http %s\r\n"; + else { + SSL_library_init(); + SSL_load_error_strings(); + if (!(ctx = SSL_CTX_new(SSLv23_server_method())) || + !SSL_CTX_use_certificate_file(ctx, av[3], SSL_FILETYPE_PEM) || + !SSL_CTX_use_PrivateKey_file(ctx, av[3], SSL_FILETYPE_PEM) || + !SSL_CTX_check_private_key(ctx) ) { + ERR_print_errors_fp(stderr); + giveup("SSL init"); + } + ssl = SSL_new(ctx), gate = "Gate: https %s\r\n"; + } + for (n = 1; n < cnt; ++n) + ports[n] = atoi(av[n+3]); + + signal(SIGCHLD,SIG_IGN); /* Prevent zombies */ + if ((n = fork()) < 0) + giveup("detach"); + if (n) + return 0; + setsid(); + + for (;;) { + socklen_t len = sizeof(addr); + if ((cli = accept(sd, (struct sockaddr*)&addr, &len)) >= 0 && (n = fork()) >= 0) { + if (!n) { + int fd, port; + char *p, *q, buf[4096], buf2[64]; + + close(sd); + + alarm(420); + if (ssl) { + SSL_set_fd(ssl, cli); + if (SSL_accept(ssl) < 0) + return 1; + n = SSL_read(ssl, buf, sizeof(buf)); + } + else + n = read(cli, buf, sizeof(buf)); + alarm(0); + if (n < 6) + return 1; + + /* "GET /url HTTP/1.x" + * "GET /8080/url HTTP/1.x" + * "POST /url HTTP/1.x" + * "POST /8080/url HTTP/1.x" + */ + if (pre(buf, "GET /")) + p = buf + 5; + else if (pre(buf, "POST /")) + p = buf + 6; + else + return 1; + + port = (int)strtol(p, &q, 10); + if (q == p || *q != ' ' && *q != '/') + port = ports[0], q = p; + else if (port < cnt) + port = ports[port]; + else if (port < 1024) + return 1; + + if ((srv = gateConnect((unsigned short)port)) < 0) { + if (!memchr(q,'~', buf + n - q)) + return 1; + if ((fd = open("void", O_RDONLY)) < 0) + return 1; + alarm(420); + if (ssl) + sslWrite(ssl, Head_410, strlen(Head_410)); + else + wrBytes(cli, Head_410, strlen(Head_410)); + alarm(0); + while ((n = read(fd, buf, sizeof(buf))) > 0) { + alarm(420); + if (ssl) + sslWrite(ssl, buf, n); + else + wrBytes(cli, buf, n); + alarm(0); + } + return 0; + } + + Http1 = 0; + wrBytes(srv, buf, p - buf); + if (*q == '/') + ++q; + p = q; + while (*p++ != '\n') + if (p >= buf + n) + return 1; + wrBytes(srv, q, p - q); + if (pre(p-10, "HTTP/1.")) + Http1 = *(p-3) - '0'; + wrBytes(srv, buf2, sprintf(buf2, gate, inet_ntoa(addr.sin_addr))); + wrBytes(srv, p, buf + n - p); + + signal(SIGALRM, doSigAlarm); + signal(SIGUSR1, doSigUsr1); + if (Buddy = fork()) { + for (;;) { + alarm(420); + n = slow(ssl, cli, buf, sizeof(buf)); + alarm(0); + if (!n || !(p = ses(buf, port, &n))) + break; + wrBytes(srv, p, n); + } + shutdown(cli, SHUT_RD); + shutdown(srv, SHUT_WR); + } + else { + Buddy = getppid(); + while ((n = read(srv, buf, sizeof(buf))) > 0) { + kill(Buddy, SIGUSR1); + alarm(420); + if (ssl) + sslWrite(ssl, buf, n); + else + wrBytes(cli, buf, n); + alarm(0); + } + shutdown(srv, SHUT_RD); + shutdown(cli, SHUT_WR); + } + return 0; + } + close(cli); + } + } +} diff --git a/src/io.c b/src/io.c @@ -0,0 +1,3543 @@ +/* 14apr10abu + * (c) Software Lab. Alexander Burger + */ + +#include "pico.h" + +#ifdef __CYGWIN__ +#include <sys/file.h> +#define fcntl(fd,cmd,fl) 0 +#endif + +static any read0(bool); + +// I/O Tokens +enum {NIX, BEG, DOT, END}; +enum {NUMBER, INTERN, TRANSIENT, EXTERN}; + +static char Delim[] = " \t\n\r\"'(),[]`~{}"; +static int StrI; +static cell StrCell, *StrP; +static bool Sync; +static byte *PipeBuf, *PipePtr; +static void (*PutSave)(int); +static byte TBuf[] = {INTERN+4, 'T'}; + +static void openErr(any ex, char *s) {err(ex, NULL, "%s open: %s", s, strerror(errno));} +static void closeErr(void) {err(NULL, NULL, "Close error: %s", strerror(errno));} +static void eofErr(void) {err(NULL, NULL, "EOF Overrun");} +static void badFd(any ex, any x) {err(ex, x, "Bad FD");} +static void lockErr(void) {err(NULL, NULL, "File lock: %s", strerror(errno));} +static void writeErr(char *s) {err(NULL, NULL, "%s write: %s", s, strerror(errno));} +static void selectErr(any ex) {err(ex, NULL, "Select error: %s", strerror(errno));} + +static void lockFile(int fd, int cmd, int typ) { + struct flock fl; + + fl.l_type = typ; + fl.l_whence = SEEK_SET; + fl.l_start = 0; + fl.l_len = 0; + while (fcntl(fd, cmd, &fl) < 0 && typ != F_UNLCK) + if (errno != EINTR) + lockErr(); +} + +void closeOnExec(any ex, int fd) { + if (fcntl(fd, F_SETFD, FD_CLOEXEC) < 0) + err(ex, NULL, "SETFD %s", strerror(errno)); +} + +int nonblocking(int fd) { + int flg = fcntl(fd, F_GETFL, 0); + + fcntl(fd, F_SETFL, flg | O_NONBLOCK); + return flg; +} + +inFile *initInFile(int fd, char *nm) { + inFile *p; + + if (fd >= InFDs) { + int i = InFDs; + + InFiles = alloc(InFiles, (InFDs = fd + 1) * sizeof(inFile*)); + do + InFiles[i] = NULL; + while (++i < InFDs); + } + p = InFiles[fd] = alloc(InFiles[fd], sizeof(inFile)); + p->fd = fd; + p->ix = p->cnt = p->next = 0; + p->line = p->src = 1; + p->name = nm; + return p; +} + +outFile *initOutFile(int fd) { + outFile *p; + + if (fd >= OutFDs) { + int i = OutFDs; + + OutFiles = alloc(OutFiles, (OutFDs = fd + 1) * sizeof(outFile*)); + do + OutFiles[i] = NULL; + while (++i < OutFDs); + } + p = OutFiles[fd] = alloc(OutFiles[fd], sizeof(outFile)); + p->tty = isatty(p->fd = fd); + p->ix = 0; + return p; +} + +void closeInFile(int fd) { + inFile *p; + + if (fd < InFDs && (p = InFiles[fd])) { + if (p == InFile) + InFile = NULL; + free(p->name), free(p), InFiles[fd] = NULL; + } +} + +void closeOutFile(int fd) { + outFile *p; + + if (fd < OutFDs && (p = OutFiles[fd])) { + if (p == OutFile) + OutFile = NULL; + free(p), OutFiles[fd] = NULL; + } +} + +int slow(inFile *p, bool nb) { + int n, f; + + p->ix = p->cnt = 0; + for (;;) { + if (nb) + f = nonblocking(p->fd); + n = read(p->fd, p->buf, BUFSIZ); + if (nb) + fcntl(p->fd, F_SETFL, f); + if (n >= 0) + return p->cnt = n; + if (errno == EAGAIN) + return -1; + if (errno != EINTR) + return 0; + if (Signal) + sighandler(NULL); + } +} + +int rdBytes(int fd, byte *p, int cnt, bool nb) { + int n, f; + + for (;;) { + if (nb) + f = nonblocking(fd); + n = read(fd, p, cnt); + if (nb) + fcntl(fd, F_SETFL, f); + if (n > 0) { + for (;;) { + p += n; + if ((cnt -= n) == 0) + return 1; + while ((n = read(fd, p, cnt)) <= 0) { + if (!n || errno != EINTR) + return 0; + if (Signal) + sighandler(NULL); + } + } + } + if (n == 0) + return 0; + if (errno == EAGAIN) + return -1; + if (errno != EINTR) + return 0; + if (Signal) + sighandler(NULL); + } +} + +bool wrBytes(int fd, byte *p, int cnt) { + int n; + + do { + if ((n = write(fd, p, cnt)) >= 0) + p += n, cnt -= n; + else if (errno == EBADF || errno == EPIPE || errno == ECONNRESET) + return NO; + else if (errno != EINTR) + writeErr("bytes"); + if (Signal) + sighandler(NULL); + } while (cnt); + return YES; +} + +static void wrChild(int i, byte *p, int cnt) { + int n; + + if (Child[i].cnt == 0) { + for (;;) { + if ((n = write(Child[i].tell, p, cnt)) >= 0) { + if ((cnt -= n) == 0) + return; + p += n; + } + else if (errno == EAGAIN) + break; + else if (errno == EPIPE || errno == ECONNRESET) { + Child[i].pid = 0; + close(Child[i].hear), close(Child[i].tell); + free(Child[i].buf); + return; + } + else if (errno != EINTR) + writeErr("child"); + } + } + n = Child[i].cnt; + Child[i].buf = alloc(Child[i].buf, n + sizeof(int) + cnt); + *(int*)(Child[i].buf + n) = cnt; + memcpy(Child[i].buf + n + sizeof(int), p, cnt); + Child[i].cnt += sizeof(int) + cnt; +} + +bool flush(outFile *p) { + int n; + + if (p && (n = p->ix)) { + p->ix = 0; + return wrBytes(p->fd, p->buf, n); + } + return YES; +} + +void flushAll(void) { + int i; + + for (i = 0; i < OutFDs; ++i) + flush(OutFiles[i]); +} + +/*** Low level I/O ***/ +static int stdinByte(void) { + inFile *p; + + if (!(p = InFiles[STDIN_FILENO]) || p->ix == p->cnt && !slow(p,NO)) + return -1; + return p->buf[p->ix++]; +} + +static int getBinary(void) { + if (!InFile || InFile->ix == InFile->cnt && !slow(InFile,NO)) + return -1; + return InFile->buf[InFile->ix++]; +} + +static any rdNum(int cnt) { + int n, i; + any x; + cell c1; + + if ((n = getBin()) < 0) + return NULL; + i = 0, Push(c1, x = box(n)); + if (--cnt == 62) { + do { + do { + if ((n = getBin()) < 0) + return NULL; + byteSym(n, &i, &x); + } while (--cnt); + if ((cnt = getBin()) < 0) + return NULL; + } while (cnt == 255); + } + while (--cnt >= 0) { + if ((n = getBin()) < 0) + return NULL; + byteSym(n, &i, &x); + } + return Pop(c1); +} + +any binRead(int extn) { + int c; + any x, y, *h; + cell c1; + + if ((c = getBin()) < 0) + return NULL; + if ((c & ~3) == 0) { + if (c == NIX) + return Nil; + if (c == BEG) { + if ((x = binRead(extn)) == NULL) + return NULL; + Push(c1, x = cons(x,Nil)); + while ((y = binRead(extn)) != (any)END) { + if (y == NULL) { + drop(c1); + return NULL; + } + if (y == (any)DOT) { + if ((y = binRead(extn)) == NULL) { + drop(c1); + return NULL; + } + cdr(x) = y == (any)END? data(c1) : y; + break; + } + x = cdr(x) = cons(y,Nil); + } + return Pop(c1); + } + return (any)(long)c; // DOT or END + } + if ((y = rdNum(c / 4)) == NULL) + return NULL; + if ((c &= 3) == NUMBER) + return y; + if (c == TRANSIENT) + return consStr(y); + if (c == EXTERN) { + if (extn) + y = extOffs(extn, y); + if (x = findHash(y, h = Extern + ehash(y))) + return x; + mkExt(x = consSym(Nil,y)); + *h = cons(x,*h); + return x; + } + if (x = findHash(y, h = Intern + ihash(y))) + return x; + x = consSym(Nil,y); + *h = cons(x,*h); + return x; +} + +static void prDig(int t, word n) { + int i = 1; + word m = MASK; + + while (n & (m <<= 8)) + ++i; + putBin(i*4+t); + while (putBin(n), --i) + n >>= 8; +} + +static int numByte(any s) { + static int i; + static any x; + static word n; + + if (s) + i = 0, n = unDig(x = s); + else if (n >>= 8, (++i & sizeof(word)-1) == 0) + n = unDig(x = cdr(numCell(x))); + return n & 0xFF; +} + +static void prNum(int t, any x) { + int cnt, i; + + if (!isNum(cdr(numCell(x)))) + prDig(t, unDig(x)); + else if ((cnt = numBytes(x)) < 63) { + putBin(cnt*4+t); + putBin(numByte(x)); + while (--cnt) + putBin(numByte(NULL)); + } + else { + putBin(63*4+t); + putBin(numByte(x)); + for (i = 1; i < 63; ++i) + putBin(numByte(NULL)); + cnt -= 63; + while (cnt >= 255) { + putBin(255); + for (i = 0; i < 255; ++i) + putBin(numByte(NULL)); + cnt -= 255; + } + putBin(cnt); + while (--cnt >= 0) + putBin(numByte(NULL)); + } +} + +void binPrint(int extn, any x) { + any y; + + if (isNum(x)) + prNum(NUMBER, x); + else if (isNil(x)) + putBin(NIX); + else if (isSym(x)) { + if (!isNum(y = name(x))) + binPrint(extn, y); + else if (!isExt(x)) + prNum(hashed(x, ihash(y), Intern)? INTERN : TRANSIENT, y); + else + prNum(EXTERN, extn? extOffs(-extn, y) : y); + } + else { + y = x; + putBin(BEG); + while (binPrint(extn, car(x)), !isNil(x = cdr(x))) { + if (x == y) { + putBin(DOT); + break; + } + if (!isCell(x)) { + putBin(DOT); + binPrint(extn, x); + return; + } + } + putBin(END); + } +} + +void pr(int extn, any x) {putBin = putStdout, binPrint(extn, x);} + +void prn(long n) { + putBin = putStdout; + prDig(NUMBER, n >= 0? n * 2 : -n * 2 + 1); +} + +/* Family IPC */ +static void putTell(int c) { + *PipePtr++ = c; + if (PipePtr == PipeBuf + PIPE_BUF - 1) // END + err(NULL, NULL, "Tell PIPE_BUF"); +} + +static void tellBeg(ptr *pb, ptr *pp, ptr buf) { + *pb = PipeBuf, *pp = PipePtr; + PipePtr = (PipeBuf = buf) + sizeof(int); + *PipePtr++ = BEG; +} + +static void prTell(any x) {putBin = putTell, binPrint(0, x);} + +static void tellEnd(ptr *pb, ptr *pp) { + int i, n; + + *PipePtr++ = END; + *(int*)PipeBuf = n = PipePtr - PipeBuf - sizeof(int); + if (Tell && !wrBytes(Tell, PipeBuf, n+sizeof(int))) + close(Tell), Tell = 0; + for (i = 0; i < Children; ++i) + if (Child[i].pid) + wrChild(i, PipeBuf+sizeof(int), n); + PipePtr = *pp, PipeBuf = *pb; +} + +static any rdHear(void) { + any x; + inFile *iSave = InFile; + + InFile = InFiles[Hear]; + getBin = getBinary; + x = binRead(0); + InFile = iSave; + return x; +} + +/* Return next byte from symbol name */ +int symByte(any s) { + static any x; + static word n; + + if (s) { + if (!isNum(x = s)) + return 0; + n = unDig(x); + } + else if ((n >>= 8) == 0) { + if (!isNum(cdr(numCell(x)))) + return 0; + n = unDig(x = cdr(numCell(x))); + } + return n & 0xFF; +} + +/* Return next char from symbol name */ +int symChar(any s) { + int c = symByte(s); + + if (c == 0xFF) + return TOP; + if (c & 0x80) { + if ((c & 0x20) == 0) + c &= 0x1F; + else + c = (c & 0xF) << 6 | symByte(NULL) & 0x3F; + c = c << 6 | symByte(NULL) & 0x3F; + } + return c; +} + +int numBytes(any x) { + int cnt; + word n, m = MASK; + + for (cnt = 1; isNum(cdr(numCell(x))); cnt += WORD) + x = cdr(numCell(x)); + for (n = unDig(x); n & (m <<= 8); ++cnt); + return cnt; +} + +/* Buffer size */ +int bufSize(any x) {return isNum(x = name(x))? numBytes(x)+1 : 1;} + +int pathSize(any x) { + int c = firstByte(x); + + if (c != '@' && (c != '+' || secondByte(x) != '@')) + return bufSize(x); + if (!Home) + return numBytes(name(x)); + return strlen(Home) + numBytes(name(x)); +} + +void bufString(any x, char *p) { + int c = symByte(name(x)); + + while (*p++ = c) + c = symByte(NULL); +} + +void pathString(any x, char *p) { + int c; + char *h; + + if ((c = symByte(name(x))) == '+') + *p++ = c, c = symByte(NULL); + if (c != '@') + while (*p++ = c) + c = symByte(NULL); + else { + if (h = Home) + do + *p++ = *h++; + while (*h); + while (*p++ = symByte(NULL)); + } +} + +// (path 'any) -> sym +any doPath(any x) { + x = evSym(cdr(x)); + { + char nm[pathSize(x)]; + + pathString(x,nm); + return mkStr(nm); + } +} + +/* Add next byte to symbol name */ +void byteSym(int c, int *i, any *p) { + if ((*i += 8) < BITS) + setDig(*p, unDig(*p) | (c & 0xFF) << *i); + else + *i = 0, *p = cdr(numCell(*p)) = box(c & 0xFF); +} + +/* Box first char of symbol name */ +any boxChar(int c, int *i, any *p) { + *i = 0; + if (c < 0x80) + *p = box(c); + else if (c < 0x800) { + *p = box(0xC0 | c>>6 & 0x1F); + byteSym(0x80 | c & 0x3F, i, p); + } + else if (c == TOP) + *p = box(0xFF); + else { + *p = box(0xE0 | c>>12 & 0x0F); + byteSym(0x80 | c>>6 & 0x3F, i, p); + byteSym(0x80 | c & 0x3F, i, p); + } + return *p; +} + +/* Add next char to symbol name */ +void charSym(int c, int *i, any *p) { + if (c < 0x80) + byteSym(c, i, p); + else if (c < 0x800) { + byteSym(0xC0 | c>>6 & 0x1F, i, p); + byteSym(0x80 | c & 0x3F, i, p); + } + else if (c == TOP) + byteSym(0xFF, i, p); + else { + byteSym(0xE0 | c>>12 & 0x0F, i, p); + byteSym(0x80 | c>>6 & 0x3F, i, p); + byteSym(0x80 | c & 0x3F, i, p); + } +} + +static int currFd(any ex, char *p) { + if (!Env.inFrames && !Env.outFrames) + err(ex, NULL, "No current fd"); + if (!Env.inFrames) + return OutFile->fd; + if (!Env.outFrames) + return InFile->fd; + return labs((char*)Env.outFrames - p) > labs((char*)Env.inFrames - p)? + InFile->fd : OutFile->fd; +} + +void rdOpen(any ex, any x, inFrame *f) { + if (isNil(x)) + f->pid = 0, f->fd = STDIN_FILENO; + else if (isNum(x)) { + int n = (int)unBox(x); + + if (n < 0) { + inFrame *g = Env.inFrames; + + for (;;) { + if (!(g = g->link)) + badFd(ex,x); + if (!++n) { + n = g->fd; + break; + } + } + } + f->pid = 0, f->fd = n; + if (n >= InFDs || !InFiles[n]) + badFd(ex,x); + } + else if (isSym(x)) { + char nm[pathSize(x)]; + + f->pid = 1; + pathString(x,nm); + if (nm[0] == '+') { + while ((f->fd = open(nm+1, O_APPEND|O_CREAT|O_RDWR, 0666)) < 0) { + if (errno != EINTR) + openErr(ex, nm); + if (Signal) + sighandler(ex); + } + initInFile(f->fd, strdup(nm+1)); + } + else { + while ((f->fd = open(nm, O_RDONLY)) < 0) { + if (errno != EINTR) + openErr(ex, nm); + if (Signal) + sighandler(ex); + } + initInFile(f->fd, strdup(nm)); + } + closeOnExec(ex, f->fd); + } + else { + any y; + int i, pfd[2], ac = length(x); + char *av[ac+1]; + + if (pipe(pfd) < 0) + pipeError(ex, "read open"); + closeOnExec(ex, pfd[0]), closeOnExec(ex, pfd[1]); + av[0] = alloc(NULL, pathSize(y = xSym(car(x)))), pathString(y, av[0]); + for (i = 1; isCell(x = cdr(x)); ++i) + av[i] = alloc(NULL, bufSize(y = xSym(car(x)))), bufString(y, av[i]); + av[ac] = NULL; + if ((f->pid = fork()) == 0) { + setpgid(0,0); + close(pfd[0]); + if (pfd[1] != STDOUT_FILENO) + dup2(pfd[1], STDOUT_FILENO), close(pfd[1]); + execvp(av[0], av); + execError(av[0]); + } + i = 0; do + free(av[i]); + while (++i < ac); + if (f->pid < 0) + err(ex, NULL, "fork"); + setpgid(f->pid,0); + close(pfd[1]); + initInFile(f->fd = pfd[0], NULL); + } +} + +void wrOpen(any ex, any x, outFrame *f) { + if (isNil(x)) + f->pid = 0, f->fd = STDOUT_FILENO; + else if (isNum(x)) { + int n = (int)unBox(x); + + if (n < 0) { + outFrame *g = Env.outFrames; + + for (;;) { + if (!(g = g->link)) + badFd(ex,x); + if (!++n) { + n = g->fd; + break; + } + } + } + f->pid = 0, f->fd = n; + if (n >= OutFDs || !OutFiles[n]) + badFd(ex,x); + } + else if (isSym(x)) { + char nm[pathSize(x)]; + + f->pid = 1; + pathString(x,nm); + if (nm[0] == '+') { + while ((f->fd = open(nm+1, O_APPEND|O_CREAT|O_WRONLY, 0666)) < 0) { + if (errno != EINTR) + openErr(ex, nm); + if (Signal) + sighandler(ex); + } + } + else { + while ((f->fd = open(nm, O_CREAT|O_TRUNC|O_WRONLY, 0666)) < 0) { + if (errno != EINTR) + openErr(ex, nm); + if (Signal) + sighandler(ex); + } + } + closeOnExec(ex, f->fd); + initOutFile(f->fd); + } + else { + any y; + int i, pfd[2], ac = length(x); + char *av[ac+1]; + + if (pipe(pfd) < 0) + pipeError(ex, "write open"); + closeOnExec(ex, pfd[0]), closeOnExec(ex, pfd[1]); + av[0] = alloc(NULL, pathSize(y = xSym(car(x)))), pathString(y, av[0]); + for (i = 1; isCell(x = cdr(x)); ++i) + av[i] = alloc(NULL, bufSize(y = xSym(car(x)))), bufString(y, av[i]); + av[ac] = NULL; + if ((f->pid = fork()) == 0) { + setpgid(0,0); + close(pfd[1]); + if (pfd[0] != STDIN_FILENO) + dup2(pfd[0], STDIN_FILENO), close(pfd[0]); + execvp(av[0], av); + execError(av[0]); + } + i = 0; do + free(av[i]); + while (++i < ac); + if (f->pid < 0) + err(ex, NULL, "fork"); + setpgid(f->pid,0); + close(pfd[0]); + initOutFile(f->fd = pfd[1]); + } +} + +void ctOpen(any ex, any x, ctlFrame *f) { + NeedSym(ex,x); + if (isNil(x)) { + f->fd = -1; + lockFile(currFd(ex, (char*)f), F_SETLKW, F_RDLCK); + } + else if (x == T) { + f->fd = -1; + lockFile(currFd(ex, (char*)f), F_SETLKW, F_WRLCK); + } + else { + char nm[pathSize(x)]; + + pathString(x,nm); + if (nm[0] == '+') { + while ((f->fd = open(nm+1, O_CREAT|O_RDWR, 0666)) < 0) { + if (errno != EINTR) + openErr(ex, nm); + if (Signal) + sighandler(ex); + } + lockFile(f->fd, F_SETLKW, F_RDLCK); + } + else { + while ((f->fd = open(nm, O_CREAT|O_RDWR, 0666)) < 0) { + if (errno != EINTR) + openErr(ex, nm); + if (Signal) + sighandler(ex); + } + lockFile(f->fd, F_SETLKW, F_WRLCK); + } + closeOnExec(ex, f->fd); + } +} + +/*** Reading ***/ +void getStdin(void) { + if (!InFile) + Chr = -1; + else if (InFile != InFiles[STDIN_FILENO]) { + if (InFile->ix == InFile->cnt && !slow(InFile,NO)) { + Chr = -1; + return; + } + if ((Chr = InFile->buf[InFile->ix++]) == '\n') + ++InFile->line; + } + else if (!isCell(val(Led))) { + waitFd(NULL, STDIN_FILENO, -1); + Chr = stdinByte(); + } + else { + static word dig; + + if (!isNum(Line)) + dig = isNum(Line = name(run(val(Led))))? unDig(Line) : '\n'; + else if ((dig >>= 8) == 0) + dig = isNum(Line = cdr(numCell(Line)))? unDig(Line) : '\n'; + Chr = dig & 0xFF; + } +} + +static void getParse(void) { + if ((Chr = Env.parser->dig & 0xFF) == 0xFF) + Chr = -1; + else if ((Env.parser->dig >>= 8) == 0) { + Env.parser->dig = + isNum(Env.parser->name = cdr(numCell(Env.parser->name))) ? + unDig(Env.parser->name) : Env.parser->eof; + } +} + +void pushInFiles(inFrame *f) { + if (InFile) + InFile->next = Chr; + Chr = (InFile = InFiles[f->fd])? InFile->next : -1; + f->get = Env.get, Env.get = getStdin; + f->link = Env.inFrames, Env.inFrames = f; +} + +void pushOutFiles(outFrame *f) { + OutFile = OutFiles[f->fd]; + f->put = Env.put, Env.put = putStdout; + f->link = Env.outFrames, Env.outFrames = f; +} + +void pushCtlFiles(ctlFrame *f) { + f->link = Env.ctlFrames, Env.ctlFrames = f; +} + +void popInFiles(void) { + if (Env.inFrames->pid) { + close(Env.inFrames->fd), closeInFile(Env.inFrames->fd); + if (Env.inFrames->pid > 1) + while (waitpid(Env.inFrames->pid, NULL, 0) < 0) { + if (errno != EINTR) + closeErr(); + if (Signal) + sighandler(NULL); + } + } + Env.get = Env.inFrames->get; + Chr = + (InFile = InFiles[(Env.inFrames = Env.inFrames->link)? Env.inFrames->fd : STDIN_FILENO])? + InFile->next : -1; +} + +void popOutFiles(void) { + flush(OutFile); + if (Env.outFrames->pid) { + close(Env.outFrames->fd), closeOutFile(Env.outFrames->fd); + if (Env.outFrames->pid > 1) + while (waitpid(Env.outFrames->pid, NULL, 0) < 0) { + if (errno != EINTR) + closeErr(); + if (Signal) + sighandler(NULL); + } + } + Env.put = Env.outFrames->put; + OutFile = OutFiles[(Env.outFrames = Env.outFrames->link)? Env.outFrames->fd : STDOUT_FILENO]; +} + +void popCtlFiles(void) { + if (Env.ctlFrames->fd >= 0) + close(Env.ctlFrames->fd); + else + lockFile(currFd(NULL, (char*)Env.ctlFrames), F_SETLK, F_UNLCK); + Env.ctlFrames = Env.ctlFrames->link; +} + +/* Get full char from input channel */ +int getChar(void) { + int c; + + if ((c = Chr) == 0xFF) + return TOP; + if (c & 0x80) { + Env.get(); + if ((c & 0x20) == 0) + c &= 0x1F; + else + c = (c & 0xF) << 6 | Chr & 0x3F, Env.get(); + if (Chr < 0) + eofErr(); + c = c << 6 | Chr & 0x3F; + } + return c; +} + +/* Skip White Space and Comments */ +static int skip(int c) { + for (;;) { + if (Chr < 0) + return Chr; + while (Chr <= ' ') { + Env.get(); + if (Chr < 0) + return Chr; + } + if (Chr != c) + return Chr; + Env.get(); + if (c != '#' || Chr != '{') { + while (Chr != '\n') { + if (Chr < 0) + return Chr; + Env.get(); + } + } + else { + for (;;) { // #{block-comment}# from Kriangkrai Soatthiyanont + Env.get(); + if (Chr < 0) + return Chr; + if (Chr == '}' && (Env.get(), Chr == '#')) + break; + } + } + Env.get(); + } +} + +/* Test for escaped characters */ +static bool testEsc(void) { + for (;;) { + if (Chr < 0) + return NO; + if (Chr == '^') { + Env.get(); + if (Chr == '?') + Chr = 127; + else + Chr &= 0x1F; + return YES; + } + if (Chr != '\\') + return YES; + if (Env.get(), Chr != '\n') + return YES; + do + Env.get(); + while (Chr == ' ' || Chr == '\t'); + } +} + +/* Try for anonymous symbol */ +static any anonymous(any s) { + unsigned c; + unsigned long n; + heap *h; + + if ((c = symByte(s)) != '$') + return NULL; + n = 0; + while (c = symByte(NULL)) { + if (c < '0' || c > '9') + return NULL; + n = n * 10 + c - '0'; + } + n *= sizeof(cell); + h = Heaps; + do + if ((any)n >= h->cells && (any)n < h->cells + CELLS) + return symPtr((any)n); + while (h = h->next); + return NULL; +} + +/* Read an atom */ +static any rdAtom(int c) { + int i; + any x, y, *h; + cell c1; + + i = 0, Push(c1, y = box(c)); + while (Chr > 0 && !strchr(Delim, Chr)) { + if (Chr == '\\') + Env.get(); + byteSym(Chr, &i, &y); + Env.get(); + } + y = Pop(c1); + if (unDig(y) == ('L'<<16 | 'I'<<8 | 'N')) + return Nil; + if (x = symToNum(y, (int)unDig(val(Scl)) / 2, '.', 0)) + return x; + if (x = anonymous(y)) + return x; + if (x = findHash(y, h = Intern + ihash(y))) + return x; + x = consSym(Nil,y); + *h = cons(x,*h); + return x; +} + +/* Read a list */ +static any rdList(void) { + any x; + cell c1; + + Env.get(); + for (;;) { + if (skip('#') == ')') { + Env.get(); + return Nil; + } + if (Chr == ']') + return Nil; + if (Chr != '~') { + Push(c1, x = cons(read0(NO),Nil)); + break; + } + Env.get(); + Push(c1, read0(NO)); + if (isCell(x = data(c1) = EVAL(data(c1)))) { + while (isCell(cdr(x))) + x = cdr(x); + break; + } + drop(c1); + } + for (;;) { + if (skip('#') == ')') { + Env.get(); + break; + } + if (Chr == ']') + break; + if (Chr == '.') { + Env.get(); + if (strchr(Delim, Chr)) { + cdr(x) = skip('#')==')' || Chr==']'? data(c1) : read0(NO); + if (skip('#') == ')') + Env.get(); + else if (Chr != ']') + err(NULL, x, "Bad dotted pair"); + break; + } + x = cdr(x) = cons(rdAtom('.'), Nil); + } + else if (Chr != '~') + x = cdr(x) = cons(read0(NO), Nil); + else { + Env.get(); + cdr(x) = read0(NO); + cdr(x) = EVAL(cdr(x)); + while (isCell(cdr(x))) + x = cdr(x); + } + } + return Pop(c1); +} + +/* Read one expression */ +static any read0(bool top) { + int i; + any x, y, *h; + cell c1; + + if (skip('#') < 0) { + if (top) + return Nil; + eofErr(); + } + if (top && InFile) + InFile->src = InFile->line; + if (Chr == '(') { + x = rdList(); + if (top && Chr == ']') + Env.get(); + return x; + } + if (Chr == '[') { + x = rdList(); + if (Chr != ']') + err(NULL, x, "Super parentheses mismatch"); + Env.get(); + return x; + } + if (Chr == '\'') { + Env.get(); + return cons(Quote, read0(NO)); + } + if (Chr == ',') { + Env.get(); + Push(c1, x = read0(NO)); + if (isCell(y = idx(Uni, data(c1), 1))) + x = car(y); + drop(c1); + return x; + } + if (Chr == '`') { + Env.get(); + Push(c1, read0(NO)); + x = EVAL(data(c1)); + drop(c1); + return x; + } + if (Chr == '"') { + Env.get(); + if (Chr == '"') { + Env.get(); + return Nil; + } + if (!testEsc()) + eofErr(); + i = 0, Push(c1, y = box(Chr)); + while (Env.get(), Chr != '"') { + if (!testEsc()) + eofErr(); + byteSym(Chr, &i, &y); + } + y = Pop(c1), Env.get(); + if (x = findHash(y, h = Transient + ihash(y))) + return x; + x = consStr(y); + if (Env.get == getStdin) + *h = cons(x,*h); + return x; + } + if (Chr == '{') { + Env.get(); + if (Chr == '}') { + Env.get(); + return consSym(Nil,Nil); + } + i = 0, Push(c1, y = box(Chr)); + while (Env.get(), Chr != '}') { + if (Chr < 0) + eofErr(); + byteSym(Chr, &i, &y); + } + y = Pop(c1), Env.get(); + if (x = findHash(y, h = Extern + ehash(y))) + return x; + mkExt(x = consSym(Nil,y)); + *h = cons(x,*h); + return x; + } + if (Chr == ')' || Chr == ']' || Chr == '~') + err(NULL, NULL, "Bad input '%c' (%d)", isprint(Chr)? Chr:'?', Chr); + if (Chr == '\\') + Env.get(); + i = Chr; + Env.get(); + return rdAtom(i); +} + +any read1(int end) { + any x; + + if (!Chr) + Env.get(); + if (Chr == end) + return Nil; + x = read0(YES); + while (Chr > 0 && strchr(" \t)]", Chr)) + Env.get(); + return x; +} + +/* Read one token */ +any token(any x, int c) { + int i; + any y, *h; + cell c1; + + if (!Chr) + Env.get(); + if (skip(c) < 0) + return NULL; + if (Chr == '"') { + Env.get(); + if (Chr == '"') { + Env.get(); + return Nil; + } + if (!testEsc()) + return Nil; + i = 0, Push(c1, y = box(Chr)); + while (Env.get(), Chr != '"' && testEsc()) + byteSym(Chr, &i, &y); + Env.get(); + return consStr(y = Pop(c1)); + } + if (Chr >= '0' && Chr <= '9') { + i = 0, Push(c1, y = box(Chr)); + while (Env.get(), Chr >= '0' && Chr <= '9' || Chr == '.') + byteSym(Chr, &i, &y); + return symToNum(Pop(c1), (int)unDig(val(Scl)) / 2, '.', 0); + } + { + char nm[bufSize(x)]; + + bufString(x, nm); + if (Chr >= 'A' && Chr <= 'Z' || Chr == '\\' || Chr >= 'a' && Chr <= 'z' || strchr(nm,Chr)) { + if (Chr == '\\') + Env.get(); + i = 0, Push(c1, y = box(Chr)); + while (Env.get(), + Chr >= '0' && Chr <= '9' || Chr >= 'A' && Chr <= 'Z' || + Chr == '\\' || Chr >= 'a' && Chr <= 'z' || strchr(nm,Chr) ) { + if (Chr == '\\') + Env.get(); + byteSym(Chr, &i, &y); + } + y = Pop(c1); + if (x = findHash(y, h = Intern + ihash(y))) + return x; + x = consSym(Nil,y); + *h = cons(x,*h); + return x; + } + } + c = getChar(); + Env.get(); + return mkChar(c); +} + +// (read ['sym1 ['sym2]]) -> any +any doRead(any ex) { + any x; + + if (!isCell(x = cdr(ex))) + x = read1(0); + else { + cell c1; + + Push(c1, EVAL(car(x))); + NeedSym(ex, data(c1)); + x = cdr(x), x = EVAL(car(x)); + NeedSym(ex,x); + x = token(data(c1), symChar(name(x))) ?: Nil; + drop(c1); + } + if (InFile == InFiles[STDIN_FILENO] && Chr == '\n') + Chr = 0; + return x; +} + +static inline bool inReady(inFile *p) { + return p->ix < p->cnt; +} + +static bool isSet(int fd, fd_set *fds) { + inFile *p; + + if (fd >= InFDs || !(p = InFiles[fd])) + return FD_ISSET(fd, fds); + if (inReady(p)) + return YES; + return FD_ISSET(fd, fds) && slow(p,YES) >= 0; +} + +long waitFd(any ex, int fd, long ms) { + any x, taskSave; + cell c1, c2, c3; + int i, j, m, n; + long t; + bool flg; + fd_set rdSet, wrSet; + struct timeval *tp, tv; +#ifndef __linux__ + struct timeval tt; +#endif + + taskSave = Env.task; + Push(c1, val(At)); + Save(c2); + do { + if (ms >= 0) + t = ms, tp = &tv; + else + t = LONG_MAX, tp = NULL; + FD_ZERO(&rdSet); + FD_ZERO(&wrSet); + m = 0; + if (fd >= 0) { + if (fd < InFDs && InFiles[fd] && inReady(InFiles[fd])) + tp = &tv, t = 0; + else + FD_SET(m = fd, &rdSet); + } + for (x = data(c2) = Env.task = val(Run); isCell(x); x = cdr(x)) { + if (!memq(car(x), taskSave)) { + if (isNeg(caar(x))) { + if ((n = (int)unDig(cadar(x)) / 2) < t) + tp = &tv, t = n; + } + else if ((n = (int)unDig(caar(x)) / 2) != fd) { + if (n < InFDs && InFiles[n] && inReady(InFiles[n])) + tp = &tv, t = 0; + else { + FD_SET(n, &rdSet); + if (n > m) + m = n; + } + } + } + } + if (Hear && Hear != fd && InFiles[Hear]) { + if (inReady(InFiles[Hear])) + tp = &tv, t = 0; + else { + FD_SET(Hear, &rdSet); + if (Hear > m) + m = Hear; + } + } + if (Spkr) { + FD_SET(Spkr, &rdSet); + if (Spkr > m) + m = Spkr; + } + for (i = 0; i < Children; ++i) { + if (Child[i].pid) { + FD_SET(Child[i].hear, &rdSet); + if (Child[i].hear > m) + m = Child[i].hear; + if (Child[i].cnt) { + FD_SET(Child[i].tell, &wrSet); + if (Child[i].tell > m) + m = Child[i].tell; + } + } + } + if (tp) { + tv.tv_sec = t / 1000; + tv.tv_usec = t % 1000 * 1000; +#ifndef __linux__ + gettimeofday(&tt,NULL); + t = tt.tv_sec*1000 + tt.tv_usec/1000; +#endif + } + while (select(m+1, &rdSet, &wrSet, NULL, tp) < 0) { + if (errno != EINTR) { + val(Run) = Nil; + selectErr(ex); + } + if (Signal) + sighandler(ex); + } + if (tp) { +#ifdef __linux__ + t -= tv.tv_sec*1000 + tv.tv_usec/1000; +#else + gettimeofday(&tt,NULL); + t = tt.tv_sec*1000 + tt.tv_usec/1000 - t; +#endif + if (ms > 0 && (ms -= t) < 0) + ms = 0; + } + for (flg = NO, i = 0; i < Children; ++i) { + if (Child[i].pid) { + if (FD_ISSET(Child[i].hear, &rdSet)) { + if ((m = rdBytes(Child[i].hear, (byte*)&n, sizeof(int), YES)) >= 0) { + byte buf[PIPE_BUF - sizeof(int)]; + + if (m && rdBytes(Child[i].hear, buf, n, NO)) { + for (flg = YES, j = 0; j < Children; ++j) + if (j != i && Child[j].pid) + wrChild(j, buf, n); + } + else { + Child[i].pid = 0; + close(Child[i].hear), close(Child[i].tell); + free(Child[i].buf); + continue; + } + } + } + if (FD_ISSET(Child[i].tell, &wrSet)) { + n = *(int*)(Child[i].buf + Child[i].ofs); + if (wrBytes(Child[i].tell, Child[i].buf + Child[i].ofs + sizeof(int), n)) { + Child[i].ofs += sizeof(int) + n; + if (2 * Child[i].ofs >= Child[i].cnt) { + if (Child[i].cnt -= Child[i].ofs) { + memcpy(Child[i].buf, Child[i].buf + Child[i].ofs, Child[i].cnt); + Child[i].buf = alloc(Child[i].buf, Child[i].cnt); + } + Child[i].ofs = 0; + } + } + else { + Child[i].pid = 0; + close(Child[i].hear), close(Child[i].tell); + free(Child[i].buf); + } + } + } + } + if (!flg && Spkr && FD_ISSET(Spkr,&rdSet) && + rdBytes(Spkr, (byte*)&m, sizeof(int), YES) > 0 && Child[m].pid ) + wrChild(m, TBuf, sizeof(TBuf)); + if (Hear && Hear != fd && isSet(Hear, &rdSet)) { + if ((data(c3) = rdHear()) == NULL) + close(Hear), closeInFile(Hear), closeOutFile(Hear), Hear = 0; + else if (data(c3) == T) + Sync = YES; + else { + Save(c3); + evList(data(c3)); + drop(c3); + } + } + for (x = data(c2); isCell(x); x = cdr(x)) { + if (!memq(car(x), taskSave)) { + if (isNeg(caar(x))) { + if ((n = (int)(unDig(cadar(x)) / 2 - t)) > 0) + setDig(cadar(x), (long)2*n); + else { + setDig(cadar(x), unDig(caar(x))); + val(At) = caar(x); + prog(cddar(x)); + } + } + else if ((n = (int)unDig(caar(x)) / 2) != fd) { + if (isSet(n, &rdSet)) { + val(At) = caar(x); + prog(cdar(x)); + } + } + } + } + if (Signal) + sighandler(ex); + } while (ms && fd >= 0 && !isSet(fd, &rdSet)); + Env.task = taskSave; + val(At) = Pop(c1); + return ms; +} + +// (wait ['cnt] . prg) -> any +any doWait(any ex) { + any x, y; + long ms; + + x = cdr(ex); + ms = isNil(y = EVAL(car(x)))? -1 : xCnt(ex,y); + x = cdr(x); + while (isNil(y = prog(x))) + if (!(ms = waitFd(ex, -1, ms))) + return prog(x); + return y; +} + +// (sync) -> flg +any doSync(any ex) { + byte *p; + int n, cnt; + + if (!Mic || !Hear) + return Nil; + p = (byte*)&Slot; + cnt = sizeof(int); + do { + if ((n = write(Mic, p, cnt)) >= 0) + p += n, cnt -= n; + else if (errno != EINTR) + writeErr("sync"); + if (Signal) + sighandler(ex); + } while (cnt); + Sync = NO; + do + waitFd(ex, -1, -1); + while (!Sync); + return T; +} + +// (hear 'cnt) -> cnt +any doHear(any ex) { + any x; + int fd; + + x = cdr(ex), x = EVAL(car(x)); + if ((fd = (int)xCnt(ex,x)) < 0 || fd >= InFDs || !InFiles[fd]) + badFd(ex,x); + if (Hear) + close(Hear), closeInFile(Hear), closeOutFile(Hear); + Hear = fd; + return x; +} + +// (tell 'sym ['any ..]) -> any +any doTell(any x) { + any y; + ptr pbSave, ppSave; + byte buf[PIPE_BUF]; + + if (!Tell && !Children) + return Nil; + tellBeg(&pbSave, &ppSave, buf); + do + x = cdr(x), prTell(y = EVAL(car(x))); + while (isCell(cdr(x))); + tellEnd(&pbSave, &ppSave); + return y; +} + +// (poll 'cnt) -> cnt | NIL +any doPoll(any ex) { + any x; + int fd; + inFile *p; + fd_set fdSet; + struct timeval tv; + + x = cdr(ex), x = EVAL(car(x)); + if ((fd = (int)xCnt(ex,x)) < 0 || fd >= InFDs) + badFd(ex,x); + if (!(p = InFiles[fd])) + return Nil; + do { + if (inReady(p)) + return x; + FD_ZERO(&fdSet); + FD_SET(fd, &fdSet); + tv.tv_sec = tv.tv_usec = 0; + while (select(fd+1, &fdSet, NULL, NULL, &tv) < 0) + if (errno != EINTR) + selectErr(ex); + if (!FD_ISSET(fd, &fdSet)) + return Nil; + } while (slow(p,YES) < 0); + return x; +} + +// (key ['cnt]) -> sym +any doKey(any ex) { + any x; + int c, d, e; + + flushAll(); + setRaw(); + x = cdr(ex); + if (!waitFd(ex, STDIN_FILENO, isNil(x = EVAL(car(x)))? -1 : xCnt(ex,x))) + return Nil; + if ((c = stdinByte()) < 0) + return Nil; + if (c == 0xFF) + c = TOP; + else if (c & 0x80) { + if ((d = stdinByte()) < 0) + return Nil; + if ((c & 0x20) == 0) + c = (c & 0x1F) << 6 | d & 0x3F; + else { + if ((e = stdinByte()) < 0) + return Nil; + c = ((c & 0xF) << 6 | d & 0x3F) << 6 | e & 0x3F; + } + } + return mkChar(c); +} + +// (peek) -> sym +any doPeek(any ex __attribute__((unused))) { + if (!Chr) + Env.get(); + return Chr<0? Nil : mkChar(Chr); +} + +// (char) -> sym +// (char 'cnt) -> sym +// (char T) -> sym +// (char 'sym) -> cnt +any doChar(any ex) { + any x = cdr(ex); + if (!isCell(x)) { + if (!Chr) + Env.get(); + x = Chr<0? Nil : mkChar(getChar()); + Env.get(); + return x; + } + if (isNum(x = EVAL(car(x)))) + return IsZero(x)? Nil : mkChar(unDig(x) / 2); + if (isSym(x)) + return x == T? mkChar(TOP) : boxCnt(symChar(name(x))); + atomError(ex,x); +} + +// (skip ['any]) -> sym +any doSkip(any x) { + x = evSym(cdr(x)); + return skip(symChar(name(x)))<0? Nil : mkChar(Chr); +} + +// (eol) -> flg +any doEol(any ex __attribute__((unused))) { + return Chr=='\n' || Chr<=0? T : Nil; +} + +// (eof ['flg]) -> flg +any doEof(any x) { + x = cdr(x); + if (!isNil(EVAL(car(x)))) { + Chr = -1; + return T; + } + if (!Chr) + Env.get(); + return Chr < 0? T : Nil; +} + +// (from 'any ..) -> sym +any doFrom(any x) { + int i, j, ac = length(x = cdr(x)), p[ac]; + cell c[ac]; + char *av[ac]; + + if (ac == 0) + return Nil; + for (i = 0;;) { + Push(c[i], evSym(x)); + av[i] = alloc(NULL, bufSize(data(c[i]))), bufString(data(c[i]), av[i]); + p[i] = 0; + if (++i == ac) + break; + x = cdr(x); + } + if (!Chr) + Env.get(); + while (Chr >= 0) { + for (i = 0; i < ac; ++i) { + for (;;) { + if (av[i][p[i]] == (byte)Chr) { + if (av[i][++p[i]]) + break; + Env.get(); + x = data(c[i]); + goto done; + } + if (!p[i]) + break; + for (j = 1; --p[i]; ++j) + if (memcmp(av[i], av[i]+j, p[i]) == 0) + break; + } + } + Env.get(); + } + x = Nil; +done: + i = 0; do + free(av[i]); + while (++i < ac); + drop(c[0]); + return x; +} + +// (till 'any ['flg]) -> lst|sym +any doTill(any ex) { + any x; + int i; + cell c1; + + x = evSym(cdr(ex)); + { + char buf[bufSize(x)]; + + bufString(x, buf); + if (!Chr) + Env.get(); + if (Chr < 0 || strchr(buf,Chr)) + return Nil; + x = cddr(ex); + if (isNil(EVAL(car(x)))) { + Push(c1, x = cons(mkChar(getChar()), Nil)); + while (Env.get(), Chr > 0 && !strchr(buf,Chr)) + x = cdr(x) = cons(mkChar(getChar()), Nil); + return Pop(c1); + } + Push(c1, boxChar(getChar(), &i, &x)); + while (Env.get(), Chr > 0 && !strchr(buf,Chr)) + charSym(getChar(), &i, &x); + return consStr(Pop(c1)); + } +} + +bool eol(void) { + if (Chr < 0) + return YES; + if (Chr == '\n') { + Chr = 0; + return YES; + } + if (Chr == '\r') { + Env.get(); + if (Chr == '\n') + Chr = 0; + return YES; + } + return NO; +} + +// (line 'flg ['cnt ..]) -> lst|sym +any doLine(any ex) { + any x, y, z; + bool pack; + int i, n; + cell c1; + + if (!Chr) + Env.get(); + if (eol()) + return Nil; + x = cdr(ex); + if (pack = !isNil(EVAL(car(x)))) + Push(c1, boxChar(getChar(), &i, &z)); + else + Push(c1, cons(mkChar(getChar()), Nil)); + if (!isCell(x = cdr(x))) + y = data(c1); + else { + if (!pack) + z = data(c1); + data(c1) = y = cons(data(c1), Nil); + for (;;) { + n = (int)evCnt(ex,x); + while (--n) { + if (Env.get(), eol()) { + if (pack) + car(y) = consStr(car(y)); + return Pop(c1); + } + if (pack) + charSym(getChar(), &i, &z); + else + z = cdr(z) = cons(mkChar(getChar()), Nil); + } + if (pack) + car(y) = consStr(car(y)); + if (!isCell(x = cdr(x))) { + pack = NO; + break; + } + if (Env.get(), eol()) + return Pop(c1); + y = cdr(y) = cons( + pack? boxChar(getChar(), &i, &z) : (z = cons(mkChar(getChar()), Nil)), + Nil ); + } + } + for (;;) { + if (Env.get(), eol()) + return pack? consStr(Pop(c1)) : Pop(c1); + if (pack) + charSym(getChar(), &i, &z); + else + y = cdr(y) = cons(mkChar(getChar()), Nil); + } +} + +// (lines 'any ..) -> cnt +any doLines(any x) { + any y; + int c, cnt = 0; + bool flg = NO; + FILE *fp; + + for (x = cdr(x); isCell(x); x = cdr(x)) { + y = evSym(x); + { + char nm[pathSize(y)]; + + pathString(y, nm); + if (fp = fopen(nm, "r")) { + flg = YES; + while ((c = getc_unlocked(fp)) >= 0) + if (c == '\n') + ++cnt; + fclose(fp); + } + } + } + return flg? boxCnt(cnt) : Nil; +} + +static any parse(any x, bool skp, any s) { + int c; + parseFrame *save, parser; + void (*getSave)(void); + cell c1; + + save = Env.parser; + Env.parser = &parser; + parser.dig = unDig(parser.name = name(x)); + parser.eof = s? 0xFF : 0xFF5D0A; + getSave = Env.get, Env.get = getParse, c = Chr, Chr = 0; + Push(c1, Env.parser->name); + if (skp) + getParse(); + if (!s) + x = rdList(); + else { + any y; + cell c2; + + if (!(x = token(s,0))) + return Nil; + Push(c2, y = cons(x,Nil)); + while (x = token(s,0)) + y = cdr(y) = cons(x,Nil); + x = Pop(c2); + } + drop(c1); + Chr = c, Env.get = getSave, Env.parser = save; + return x; +} + +static void putString(int c) { + if (StrP) + byteSym(c, &StrI, &StrP); + else + StrI = 0, data(StrCell) = StrP = box(c & 0xFF); +} + +void begString(void) { + StrP = NULL; + Push(StrCell,Nil); + PutSave = Env.put, Env.put = putString; +} + +any endString(void) { + Env.put = PutSave; + drop(StrCell); + return StrP? consStr(data(StrCell)) : Nil; +} + +// (any 'sym) -> any +any doAny(any ex) { + any x; + + x = cdr(ex), x = EVAL(car(x)); + NeedSym(ex,x); + if (!isNil(x)) { + int c; + parseFrame *save, parser; + void (*getSave)(void); + cell c1; + + save = Env.parser; + Env.parser = &parser; + parser.dig = unDig(parser.name = name(x)); + parser.eof = 0xFF20; + getSave = Env.get, Env.get = getParse, c = Chr, Chr = 0; + Push(c1, Env.parser->name); + getParse(); + x = read0(YES); + drop(c1); + Chr = c, Env.get = getSave, Env.parser = save; + } + return x; +} + +// (sym 'any) -> sym +any doSym(any x) { + x = EVAL(cadr(x)); + begString(); + print(x); + return endString(); +} + +// (str 'sym ['sym1]) -> lst +// (str 'lst) -> sym +any doStr(any ex) { + any x; + cell c1, c2; + + x = cdr(ex); + if (isNil(x = EVAL(car(x)))) + return Nil; + if (isNum(x)) + argError(ex,x); + if (isSym(x)) { + if (!isCell(cddr(ex))) + return parse(x, NO, NULL); + Push(c1, x); + Push(c2, evSym(cddr(ex))); + x = parse(x, NO, data(c2)); + drop(c1); + return x; + } + begString(); + while (print(car(x)), isCell(x = cdr(x))) + space(); + return endString(); +} + +any load(any ex, int pr, any x) { + cell c1, c2; + inFrame f; + + if (isSym(x) && firstByte(x) == '-') { + Push(c1, parse(x, YES, NULL)); + x = evList(data(c1)); + drop(c1); + return x; + } + rdOpen(ex, x, &f); + doHide(Nil); + pushInFiles(&f); + x = Nil; + for (;;) { + if (InFile != InFiles[STDIN_FILENO]) + data(c1) = read1(0); + else { + if (pr && !Chr) + Env.put(pr), space(), flushAll(); + data(c1) = read1(isatty(STDIN_FILENO)? '\n' : 0); + if (Chr == '\n') + Chr = 0; + } + if (isNil(data(c1))) + break; + Save(c1); + if (InFile != InFiles[STDIN_FILENO] || Chr || !pr) + x = EVAL(data(c1)); + else { + flushAll(); + Push(c2, val(At)); + x = val(At) = EVAL(data(c1)); + val(At3) = val(At2), val(At2) = data(c2); + outString("-> "), flushAll(), print1(x), newline(); + } + drop(c1); + } + popInFiles(); + doHide(Nil); + return x; +} + +// (load 'any ..) -> any +any doLoad(any ex) { + any x, y; + + x = cdr(ex); + do { + if ((y = EVAL(car(x))) != T) + y = load(ex, '>', y); + else + y = loadAll(ex); + } while (isCell(x = cdr(x))); + return y; +} + +// (in 'any . prg) -> any +any doIn(any ex) { + any x; + inFrame f; + + x = cdr(ex), x = EVAL(car(x)); + rdOpen(ex, x, &f); + pushInFiles(&f); + x = prog(cddr(ex)); + popInFiles(); + return x; +} + +// (out 'any . prg) -> any +any doOut(any ex) { + any x; + outFrame f; + + x = cdr(ex), x = EVAL(car(x)); + wrOpen(ex, x, &f); + pushOutFiles(&f); + x = prog(cddr(ex)); + popOutFiles(); + return x; +} + +// (pipe exe) -> cnt +// (pipe exe . prg) -> any +any doPipe(any ex) { + any x; + union { + inFrame in; + outFrame out; + } f; + int pfd[2]; + + if (pipe(pfd) < 0) + err(ex, NULL, "Can't pipe"); + closeOnExec(ex, pfd[0]), closeOnExec(ex, pfd[1]); + if ((f.in.pid = forkLisp(ex)) == 0) { + if (isCell(cddr(ex))) + setpgid(0,0); + close(pfd[0]); + if (pfd[1] != STDOUT_FILENO) + dup2(pfd[1], STDOUT_FILENO), close(pfd[1]); + wrOpen(ex, Nil, &f.out); + pushOutFiles(&f.out); + val(Run) = Nil; + EVAL(cadr(ex)); + bye(0); + } + close(pfd[1]); + initInFile(f.in.fd = pfd[0], NULL); + if (!isCell(cddr(ex))) + return boxCnt(pfd[0]); + setpgid(f.in.pid,0); + pushInFiles(&f.in); + x = prog(cddr(ex)); + popInFiles(); + return x; +} + +// (ctl 'sym . prg) -> any +any doCtl(any ex) { + any x; + ctlFrame f; + + x = cdr(ex), x = EVAL(car(x)); + ctOpen(ex,x,&f); + pushCtlFiles(&f); + x = prog(cddr(ex)); + popCtlFiles(); + return x; +} + +// (open 'any) -> cnt | NIL +any doOpen(any ex) { + any x = evSym(cdr(ex)); + char nm[pathSize(x)]; + int fd; + + pathString(x, nm); + while ((fd = open(nm, O_CREAT|O_RDWR, 0666)) < 0) { + if (errno != EINTR) + return Nil; + if (Signal) + sighandler(ex); + } + closeOnExec(ex, fd); + initInFile(fd, strdup(nm)), initOutFile(fd); + return boxCnt(fd); +} + +// (close 'cnt) -> cnt | NIL +any doClose(any ex) { + any x; + int fd; + + x = cdr(ex), x = EVAL(car(x)); + if (close(fd = (int)xCnt(ex,x))) + return Nil; + closeInFile(fd), closeOutFile(fd); + return x; +} + +// (echo ['cnt ['cnt]] | ['sym ..]) -> sym +any doEcho(any ex) { + any x, y; + long cnt; + + x = cdr(ex), y = EVAL(car(x)); + if (!Chr) + Env.get(); + if (isNil(y) && !isCell(cdr(x))) { + while (Chr >= 0) + Env.put(Chr), Env.get(); + return T; + } + if (isSym(y)) { + int m, n, i, j, ac = length(x), p[ac], om, op; + cell c[ac]; + char *av[ac]; + + for (i = 0;;) { + Push(c[i], y); + av[i] = alloc(NULL, bufSize(y)), bufString(y, av[i]); + p[i] = 0; + if (++i == ac) + break; + y = evSym(x = cdr(x)); + } + m = -1; + while (Chr >= 0) { + if ((om = m) >= 0) + op = p[m]; + for (i = 0; i < ac; ++i) { + for (;;) { + if (av[i][p[i]] == (byte)Chr) { + if (av[i][++p[i]]) { + if (m < 0 || p[i] > p[m]) + m = i; + break; + } + if (om >= 0) + for (j = 0, n = op-p[i]; j <= n; ++j) + Env.put(av[om][j]); + Env.get(); + x = data(c[i]); + goto done; + } + if (!p[i]) + break; + for (j = 1; --p[i]; ++j) + if (memcmp(av[i], av[i]+j, p[i]) == 0) + break; + if (m == i) + for (m = -1, j = 0; j < ac; ++j) + if (p[j] && (m < 0 || p[j] > p[m])) + m = j; + } + } + if (m < 0) { + if (om >= 0) + for (i = 0; i < op; ++i) + Env.put(av[om][i]); + Env.put(Chr); + } + else if (om >= 0) + for (i = 0, n = op-p[m]; i <= n; ++i) + Env.put(av[om][i]); + Env.get(); + } + x = Nil; + done: + i = 0; do + free(av[i]); + while (++i < ac); + drop(c[0]); + return x; + } + if (isCell(x = cdr(x))) { + for (cnt = xCnt(ex,y), y = EVAL(car(x)); --cnt >= 0; Env.get()) + if (Chr < 0) + return Nil; + } + for (cnt = xCnt(ex,y); --cnt >= 0; Env.get()) { + if (Chr < 0) + return Nil; + Env.put(Chr); + } + return T; +} + +/*** Printing ***/ +void putStdout(int c) { + if (OutFile) { + if (OutFile->ix == BUFSIZ) { + OutFile->ix = 0; + wrBytes(OutFile->fd, OutFile->buf, BUFSIZ); + } + if ((OutFile->buf[OutFile->ix++] = c) == '\n' && OutFile->tty) { + int n = OutFile->ix; + + OutFile->ix = 0; + wrBytes(OutFile->fd, OutFile->buf, n); + } + } +} + +void newline(void) {Env.put('\n');} +void space(void) {Env.put(' ');} + +void outWord(word n) { + if (n > 9) + outWord(n / 10); + Env.put('0' + n % 10); +} + +void outString(char *s) { + while (*s) + Env.put(*s++); +} + +static void outSym(int c) { + do + Env.put(c); + while (c = symByte(NULL)); +} + +void outName(any s) {outSym(symByte(name(s)));} + +void outNum(any x) { + if (isNum(cdr(numCell(x)))) + outName(numToSym(x, 0, 0, 0)); + else { + char *p, buf[BITS/2]; + + sprintf(p = buf, "%ld", unBox(x)); + do + Env.put(*p++); + while (*p); + } +} + +/* Print one expression */ +void print(any x) { + cell c1; + + Push(c1,x); + print1(x); + drop(c1); +} + +void print1(any x) { + if (Signal) + sighandler(NULL); + if (isNum(x)) + outNum(x); + else if (isNil(x)) + outString("NIL"); + else if (isSym(x)) { + int c, d; + + if (!(c = symByte(name(x)))) + Env.put('$'), outWord(num(x)/sizeof(cell)); + else if (isExt(x)) + Env.put('{'), outSym(c), Env.put('}'); + else if (hashed(x, ihash(name(x)), Intern)) { + do { + d = symByte(NULL); + if (strchr(Delim, c) || c == '.' && !d) + Env.put('\\'); + Env.put(c); + } while (c = d); + } + else { + bool tsm = isCell(val(Tsm)) && Env.put == putStdout && OutFile->tty; + + if (!tsm) + Env.put('"'); + else { + outName(car(val(Tsm))); + c = symByte(name(x)); + } + do { + if (c == '\\' || c == '^' || !tsm && c == '"') + Env.put('\\'); + else if (c == 127) + Env.put('^'), c = '?'; + else if (c < ' ') + Env.put('^'), c |= 0x40; + Env.put(c); + } while (c = symByte(NULL)); + if (!tsm) + Env.put('"'); + else + outName(cdr(val(Tsm))); + } + } + else if (car(x) == Quote && x != cdr(x)) + Env.put('\''), print1(cdr(x)); + else { + any y = x; + Env.put('('); + while (print1(car(x)), !isNil(x = cdr(x))) { + if (x == y) { + outString(" ."); + break; + } + if (!isCell(x)) { + outString(" . "); + print1(x); + break; + } + space(); + } + Env.put(')'); + } +} + +void prin(any x) { + cell c1; + + Push(c1,x); + prin1(x); + drop(c1); +} + +void prin1(any x) { + if (Signal) + sighandler(NULL); + if (!isNil(x)) { + if (isNum(x)) + outNum(x); + else if (isSym(x)) { + if (isExt(x)) + Env.put('{'); + outName(x); + if (isExt(x)) + Env.put('}'); + } + else { + while (prin1(car(x)), !isNil(x = cdr(x))) { + if (!isCell(x)) { + prin1(x); + break; + } + } + } + } +} + +// (prin 'any ..) -> any +any doPrin(any x) { + any y = Nil; + + while (isCell(x = cdr(x))) + prin(y = EVAL(car(x))); + return y; +} + +// (prinl 'any ..) -> any +any doPrinl(any x) { + any y = Nil; + + while (isCell(x = cdr(x))) + prin(y = EVAL(car(x))); + newline(); + return y; +} + +// (space ['cnt]) -> cnt +any doSpace(any ex) { + any x; + int n; + + if (isNil(x = EVAL(cadr(ex)))) { + Env.put(' '); + return One; + } + for (n = xCnt(ex,x); n > 0; --n) + Env.put(' '); + return x; +} + +// (print 'any ..) -> any +any doPrint(any x) { + any y; + + x = cdr(x), print(y = EVAL(car(x))); + while (isCell(x = cdr(x))) + space(), print(y = EVAL(car(x))); + return y; +} + +// (printsp 'any ..) -> any +any doPrintsp(any x) { + any y; + + x = cdr(x); + do + print(y = EVAL(car(x))), space(); + while (isCell(x = cdr(x))); + return y; +} + +// (println 'any ..) -> any +any doPrintln(any x) { + any y; + + x = cdr(x), print(y = EVAL(car(x))); + while (isCell(x = cdr(x))) + space(), print(y = EVAL(car(x))); + newline(); + return y; +} + +// (flush) -> flg +any doFlush(any ex __attribute__((unused))) { + return flush(OutFile)? T : Nil; +} + +// (rewind) -> flg +any doRewind(any ex __attribute__((unused))) { + if (!OutFile) + return Nil; + OutFile->ix = 0; + return lseek(OutFile->fd, 0L, SEEK_SET) || ftruncate(OutFile->fd, 0)? Nil : T; +} + +// (ext 'cnt . prg) -> any +any doExt(any ex) { + int extn; + any x; + + x = cdr(ex); + extn = ExtN, ExtN = (int)evCnt(ex,x); + x = prog(cddr(ex)); + ExtN = extn; + return x; +} + +// (rd ['sym]) -> any +// (rd 'cnt) -> num | NIL +any doRd(any x) { + int i, j; + long cnt; + word n; + cell c1; + + x = cdr(x), x = EVAL(car(x)); + if (!isNum(x)) { + Push(c1,x); + getBin = getBinary; + x = binRead(ExtN) ?: data(c1); + drop(c1); + return x; + } + if (!InFile) + return Nil; + if ((cnt = unBox(x)) < 0) { + byte buf[cnt = -cnt]; + + if (!rdBytes(InFile->fd, buf, cnt, NO)) // Little Endian + return Nil; + if (cnt % sizeof(word) == 0) + Push(c1, Nil); + else { + n = buf[--cnt]; + + while (cnt % sizeof(word)) + n = n << 8 | buf[--cnt]; + Push(c1, box(n)); + } + while ((cnt -= WORD) >= 0) { + n = buf[cnt + WORD-1]; + i = WORD-2; + do + n = n << 8 | buf[cnt + i]; + while (--i >= 0); + data(c1) = consNum(n, data(c1)); + } + } + else { + byte buf[cnt]; + + if (!rdBytes(InFile->fd, buf, cnt, NO)) + return Nil; + if (cnt % sizeof(word) == 0) { + i = 0; + Push(c1, Nil); + } + else { + n = buf[0]; + + for (i = 1; i < (int)(cnt % sizeof(word)); ++i) + n = n << 8 | buf[i]; + Push(c1, box(n)); + } + while (i < cnt) { + n = buf[i++]; + j = 1; + do + n = n << 8 | buf[i++]; + while (++j < WORD); + data(c1) = consNum(n, data(c1)); + } + } + zapZero(data(c1)); + digMul2(data(c1)); + return Pop(c1); +} + +// (pr 'any ..) -> any +any doPr(any x) { + any y; + + x = cdr(x); + do + pr(ExtN, y = EVAL(car(x))); + while (isCell(x = cdr(x))); + return y; +} + +// (wr 'cnt ..) -> cnt +any doWr(any x) { + any y; + + x = cdr(x); + do + putStdout(unDig(y = EVAL(car(x))) / 2); + while (isCell(x = cdr(x))); + return y; +} + +static void putChar(int c) {putchar_unlocked(c);} + +// (rpc 'sym ['any ..]) -> flg +any doRpc(any x) { + any y; + + x = cdr(x); + putChar(BEG); + do + y = EVAL(car(x)), putBin = putChar, binPrint(ExtN, y); + while (isCell(x = cdr(x))); + putChar(END); + return fflush(stdout)? Nil : T; +} + +/*** DB-I/O ***/ +#define BLKSIZE 64 // DB block unit size +#define BLK 6 +#define TAGMASK (BLKSIZE-1) +#define BLKMASK (~TAGMASK) +#define EXTERN64 65536 + +static int F, Files, *BlkShift, *BlkFile, *BlkSize, *Fluse, MaxBlkSize; +static FILE *Jnl, *Log; +static adr BlkIndex, BlkLink; +static adr *Marks; +static byte *Locks, *Ptr, **Mark; +static byte *Block, *IniBlk; // 01 00 00 00 00 00 NIL 0 + +static adr getAdr(byte *p) { + return (adr)p[0] | (adr)p[1]<<8 | (adr)p[2]<<16 | + (adr)p[3]<<24 | (adr)p[4]<<32 | (adr)p[5]<<40; +} + +static void setAdr(adr n, byte *p) { + p[0] = (byte)n, p[1] = (byte)(n >> 8), p[2] = (byte)(n >> 16); + p[3] = (byte)(n >> 24), p[4] = (byte)(n >> 32), p[5] = (byte)(n >> 40); +} + +static void dbfErr(any ex) {err(ex, NULL, "Bad DB file");} +static void dbErr(char *s) {err(NULL, NULL, "DB %s: %s", s, strerror(errno));} +static void jnlErr(any ex) {err(ex, NULL, "Bad Journal");} +static void fsyncErr(any ex, char *s) {err(ex, NULL, "%s fsync error: %s", s, strerror(errno));} +static void truncErr(any ex) {err(ex, NULL, "Log truncate error: %s", strerror(errno));} +static void ignLog(void) {fprintf(stderr, "Discarding incomplete transaction.\n");} + +any new64(adr n, any x) { + int c, i; + adr w = 0; + + do { + if ((c = n & 0x3F) > 11) + c += 5; + if (c > 42) + c += 6; + w = w << 8 | c + '0'; + } while (n >>= 6); + if (i = F) { + ++i; + w = w << 8 | '-'; + do { + if ((c = i & 0x3F) > 11) + c += 5; + if (c > 42) + c += 6; + w = w << 8 | c + '0'; + } while (i >>= 6); + } + return hi(w)? consNum(num(w), consNum(hi(w), x)) : consNum(num(w), x); +} + +adr blk64(any x) { + int c; + adr n, w; + + F = 0; + n = 0; + if (isNum(x)) { + w = unDig(x); + if (isNum(x = cdr(numCell(x)))) + w |= (adr)unDig(x) << BITS; + do { + if ((c = w & 0xFF) == '-') + F = n-1, n = 0; + else { + if ((c -= '0') > 42) + c -= 6; + if (c > 11) + c -= 5; + n = n << 6 | c; + } + } while (w >>= 8); + } + return n; +} + +any extOffs(int offs, any x) { + int f = F; + adr n = blk64(x); + + if (offs != -EXTERN64) { + if ((F += offs) < 0) + err(NULL, NULL, "%d: Bad DB offset", F); + x = new64(n, Nil); + } + else { // Undocumented 64-bit DB export + adr w = n & 0xFFFFF | (F & 0xFF) << 20; + + w |= ((n >>= 20) & 0xFFF) << 28; + w |= (adr)(F >> 8) << 40 | (n >> 12) << 48; + x = hi(w)? consNum(num(w), consNum(hi(w), Nil)) : consNum(num(w), Nil); + } + F = f; + return x; +} + +/* DB Record Locking */ +static void dbLock(int cmd, int typ, int f, off_t len) { + struct flock fl; + + fl.l_type = typ; + fl.l_whence = SEEK_SET; + fl.l_start = 0; + fl.l_len = len; + while (fcntl(BlkFile[f], cmd, &fl) < 0 && typ != F_UNLCK) + if (errno != EINTR) + lockErr(); +} + +static inline void rdLock(void) { + if (val(Solo) != T) + dbLock(F_SETLKW, F_RDLCK, 0, 1); +} + +static inline void wrLock(void) { + if (val(Solo) != T) + dbLock(F_SETLKW, F_WRLCK, 0, 1); +} + +static inline void rwUnlock(off_t len) { + if (val(Solo) != T) { + if (len == 0) { + int f; + + for (f = 1; f < Files; ++f) + if (Locks[f]) + dbLock(F_SETLK, F_UNLCK, f, 0), Locks[f] = 0; + val(Solo) = Zero; + } + dbLock(F_SETLK, F_UNLCK, 0, len); + } +} + +static pid_t tryLock(off_t n, off_t len) { + struct flock fl; + + for (;;) { + fl.l_type = F_WRLCK; + fl.l_whence = SEEK_SET; + fl.l_start = n; + fl.l_len = len; + if (fcntl(BlkFile[F], F_SETLK, &fl) >= 0) { + Locks[F] = 1; + if (!n) + val(Solo) = T; + else if (val(Solo) != T) + val(Solo) = Nil; + return 0; + } + if (errno != EINTR && errno != EACCES && errno != EAGAIN) + lockErr(); + fl.l_type = F_WRLCK; //?? + fl.l_whence = SEEK_SET; + fl.l_start = n; + fl.l_len = len; + while (fcntl(BlkFile[F], F_GETLK, &fl) < 0) + if (errno != EINTR) + lockErr(); + if (fl.l_type != F_UNLCK) + return fl.l_pid; + } +} + +static void blkPeek(off_t pos, void *buf, int siz) { + if (pread(BlkFile[F], buf, siz, pos) != (ssize_t)siz) + dbErr("read"); +} + +static void blkPoke(off_t pos, void *buf, int siz) { + if (pwrite(BlkFile[F], buf, siz, pos) != (ssize_t)siz) + dbErr("write"); + if (Jnl) { + byte a[BLK+2]; + + putc_unlocked(siz == BlkSize[F]? BLKSIZE : siz, Jnl); + a[0] = (byte)F, a[1] = (byte)(F >> 8), setAdr(pos >> BlkShift[F], a+2); + if (fwrite(a, BLK+2, 1, Jnl) != 1 || fwrite(buf, siz, 1, Jnl) != 1) + writeErr("Journal"); + } +} + +static void rdBlock(adr n) { + blkPeek((BlkIndex = n) << BlkShift[F], Block, BlkSize[F]); + BlkLink = getAdr(Block) & BLKMASK; + Ptr = Block + BLK; +} + +static void logBlock(void) { + byte a[BLK+2]; + + a[0] = (byte)F, a[1] = (byte)(F >> 8), setAdr(BlkIndex, a+2); + if (fwrite(a, BLK+2, 1, Log) != 1 || fwrite(Block, BlkSize[F], 1, Log) != 1) + writeErr("Log"); +} + +static void wrBlock(void) {blkPoke(BlkIndex << BlkShift[F], Block, BlkSize[F]);} + +static adr newBlock(void) { + adr n; + byte buf[2*BLK]; + + blkPeek(0, buf, 2*BLK); // Get Free, Next + if ((n = getAdr(buf)) && Fluse[F]) { + blkPeek(n << BlkShift[F], buf, BLK); // Get free link + --Fluse[F]; + } + else if ((n = getAdr(buf+BLK)) != 281474976710592LL) + setAdr(n + BLKSIZE, buf+BLK); // Increment next + else + err(NULL, NULL, "DB Oversize"); + blkPoke(0, buf, 2*BLK); + setAdr(0, IniBlk), blkPoke(n << BlkShift[F], IniBlk, BlkSize[F]); + return n; +} + +any newId(any ex, int i) { + adr n; + + if ((F = i-1) >= Files) + dbfErr(ex); + if (!Log) + ++Env.protect; + wrLock(); + if (Jnl) + lockFile(fileno(Jnl), F_SETLKW, F_WRLCK); + n = newBlock(); + if (Jnl) + fflush(Jnl), lockFile(fileno(Jnl), F_SETLK, F_UNLCK); + rwUnlock(1); + if (!Log) + --Env.protect; + return new64(n/BLKSIZE, At2); // dirty +} + +bool isLife(any x) { + adr n; + byte buf[2*BLK]; + + if (n = blk64(name(x))*BLKSIZE) { + if (F < Files) { + for (x = tail1(x); !isSym(x); x = cdr(cellPtr(x))); + if (x == At || x == At2) + return YES; + if (x != At3) { + blkPeek(0, buf, 2*BLK); // Get Next + if (n < getAdr(buf+BLK)) { + blkPeek(n << BlkShift[F], buf, BLK); + if ((buf[0] & TAGMASK) == 1) + return YES; + } + } + } + else if (!isNil(val(Ext))) + return YES; + } + return NO; +} + +static void cleanUp(adr n) { + adr p, fr; + byte buf[BLK]; + + blkPeek(0, buf, BLK), fr = getAdr(buf); // Get Free + setAdr(n, buf), blkPoke(0, buf, BLK); // Set new + for (;;) { + p = n << BlkShift[F]; + blkPeek(p, buf, BLK); // Get block link + buf[0] &= BLKMASK; // Clear Tag + if ((n = getAdr(buf)) == 0) + break; + blkPoke(p, buf, BLK); + } + setAdr(fr, buf), blkPoke(p, buf, BLK); // Append old free list +} + +static int getBlock(void) { + if (Ptr == Block+BlkSize[F]) { + if (!BlkLink) + return 0; + rdBlock(BlkLink); + } + return *Ptr++; +} + +static void putBlock(int c) { + if (Ptr == Block+BlkSize[F]) { + if (BlkLink) + wrBlock(), rdBlock(BlkLink); + else { + adr n = newBlock(); + int cnt = Block[0]; // Link must be 0 + + setAdr(n | cnt, Block); + wrBlock(); + BlkIndex = n; + if (cnt < TAGMASK) + ++cnt; + setAdr(cnt, Block); + Ptr = Block + BLK; + } + } + *Ptr++ = (byte)c; +} + +// Test for existing transaction +static bool transaction(void) { + byte a[BLK]; + + fseek(Log, 0L, SEEK_SET); + if (fread(a, 2, 1, Log) == 0) { + if (!feof(Log)) + ignLog(); + return NO; + } + for (;;) { + if (a[0] == 0xFF && a[1] == 0xFF) + return YES; + if ((F = a[0] | a[1]<<8) >= Files || + fread(a, BLK, 1, Log) != 1 || + fseek(Log, BlkSize[F], SEEK_CUR) != 0 || + fread(a, 2, 1, Log) != 1 ) { + ignLog(); + return NO; + } + } +} + +static void restore(any ex) { + byte dirty[Files], a[BLK], buf[MaxBlkSize]; + + fprintf(stderr, "Last transaction not completed: Rollback\n"); + fseek(Log, 0L, SEEK_SET); + for (F = 0; F < Files; ++F) + dirty[F] = 0; + for (;;) { + if (fread(a, 2, 1, Log) == 0) + jnlErr(ex); + if (a[0] == 0xFF && a[1] == 0xFF) + break; + if ((F = a[0] | a[1]<<8) >= Files || + fread(a, BLK, 1, Log) != 1 || + fread(buf, BlkSize[F], 1, Log) != 1 ) + jnlErr(ex); + if (pwrite(BlkFile[F], buf, BlkSize[F], getAdr(a) << BlkShift[F]) != (ssize_t)BlkSize[F]) + dbErr("write"); + dirty[F] = 1; + } + for (F = 0; F < Files; ++F) + if (dirty[F] && fsync(BlkFile[F]) < 0) + fsyncErr(ex, "DB"); +} + +// (pool ['sym1 ['lst] ['sym2] ['sym3]]) -> T +any doPool(any ex) { + any x; + byte buf[2*BLK+1]; + cell c1, c2, c3, c4; + + x = cdr(ex), Push(c1, evSym(x)); // db + x = cdr(x), Push(c2, EVAL(car(x))); // lst + NeedLst(ex,data(c2)); + x = cdr(x), Push(c3, evSym(x)); // sym2 + Push(c4, evSym(cdr(x))); // sym3 + val(Solo) = Zero; + if (Files) { + doRollback(Nil); + for (F = 0; F < Files; ++F) { + if (Marks) + free(Mark[F]); + if (close(BlkFile[F]) < 0) + closeErr(); + } + free(Mark), Mark = NULL, free(Marks), Marks = NULL; + Files = 0; + if (Jnl) + fclose(Jnl), Jnl = NULL; + if (Log) + fclose(Log), Log = NULL; + } + if (!isNil(data(c1))) { + x = data(c2); + Files = length(x) ?: 1; + BlkShift = alloc(BlkShift, Files * sizeof(int)); + BlkFile = alloc(BlkFile, Files * sizeof(int)); + BlkSize = alloc(BlkSize, Files * sizeof(int)); + Fluse = alloc(Fluse, Files * sizeof(int)); + Locks = alloc(Locks, Files), memset(Locks, 0, Files); + MaxBlkSize = 0; + for (F = 0; F < Files; ++F) { + char nm[pathSize(data(c1)) + 8]; + + pathString(data(c1), nm); + if (isCell(x)) + sprintf(nm + strlen(nm), "%d", F+1); + BlkShift[F] = isNum(car(x))? (int)unDig(car(x))/2 : 2; + if ((BlkFile[F] = open(nm, O_RDWR)) >= 0) { + blkPeek(0, buf, 2*BLK+1); // Get block shift + BlkSize[F] = BLKSIZE << (BlkShift[F] = (int)buf[2*BLK]); + } + else { + if (errno != ENOENT || + (BlkFile[F] = open(nm, O_CREAT|O_EXCL|O_RDWR, 0666)) < 0) { + Files = F; + openErr(ex, nm); + } + BlkSize[F] = BLKSIZE << BlkShift[F]; + setAdr(0, buf); // Free + if (F) + setAdr(BLKSIZE, buf+BLK); // Next + else { + byte blk[BlkSize[0]]; + + setAdr(2*BLKSIZE, buf+BLK); // Next + memset(blk, 0, BlkSize[0]); + setAdr(1, blk), blkPoke(BlkSize[0], blk, BlkSize[0]); + } + buf[2*BLK] = (byte)BlkShift[F]; + blkPoke(0, buf, 2*BLK+1); + } + closeOnExec(ex, BlkFile[F]); + if (BlkSize[F] > MaxBlkSize) + MaxBlkSize = BlkSize[F]; + Fluse[F] = -1; + x = cdr(x); + } + Block = alloc(Block, MaxBlkSize); + IniBlk = alloc(IniBlk, MaxBlkSize); + memset(IniBlk, 0, MaxBlkSize); + if (!isNil(data(c3))) { + char nm[pathSize(data(c3))]; + + pathString(data(c3), nm); + if (!(Jnl = fopen(nm, "a"))) + openErr(ex, nm); + closeOnExec(ex, fileno(Jnl)); + } + if (!isNil(data(c4))) { + char nm[pathSize(data(c4))]; + + pathString(data(c4), nm); + if (!(Log = fopen(nm, "a+"))) + openErr(ex, nm); + closeOnExec(ex, fileno(Log)); + if (transaction()) + restore(ex); + fseek(Log, 0L, SEEK_SET); + if (ftruncate(fileno(Log), 0)) + truncErr(ex); + } + } + drop(c1); + return T; +} + +// (journal 'any ..) -> T +any doJournal(any ex) { + any x, y; + int siz; + FILE *fp; + byte a[BLK], buf[MaxBlkSize]; + + for (x = cdr(ex); isCell(x); x = cdr(x)) { + y = evSym(x); + { + char nm[pathSize(y)]; + + pathString(y, nm); + if (!(fp = fopen(nm, "r"))) + openErr(ex, nm); + while ((siz = getc_unlocked(fp)) >= 0) { + if (fread(a, 2, 1, fp) != 1) + jnlErr(ex); + if ((F = a[0] | a[1]<<8) >= Files) + dbfErr(ex); + if (siz == BLKSIZE) + siz = BlkSize[F]; + if (fread(a, BLK, 1, fp) != 1 || fread(buf, siz, 1, fp) != 1) + jnlErr(ex); + blkPoke(getAdr(a) << BlkShift[F], buf, siz); + } + fclose(fp); + } + } + return T; +} + +static any mkId(adr n) { + any x, y, *h; + + x = new64(n, Nil); + if (y = findHash(x, h = Extern + ehash(x))) + return y; + mkExt(y = consSym(Nil,x)); + *h = cons(y,*h); + return y; +} + +// (id 'num ['num]) -> sym +// (id 'sym [NIL]) -> num +// (id 'sym T) -> (num . num) +any doId(any ex) { + any x, y; + adr n; + cell c1; + + x = cdr(ex); + if (isNum(y = EVAL(car(x)))) { + x = cdr(x); + if (isNil(x = EVAL(car(x)))) { + F = 0; + return mkId(unBoxWord2(y)); + } + F = (int)unDig(y)/2 - 1; + NeedNum(ex,x); + return mkId(unBoxWord2(x)); + } + NeedExt(ex,y); + n = blk64(name(y)); + x = cdr(x); + if (isNil(EVAL(car(x)))) + return boxWord2(n); + Push(c1, boxWord2(n)); + data(c1) = cons(box((F + 1) * 2), data(c1)); + return Pop(c1); +} + +// (seq 'cnt|sym1) -> sym | NIL +any doSeq(any ex) { + any x; + adr n, next; + byte buf[2*BLK]; + + x = cdr(ex); + if (isNum(x = EVAL(car(x)))) { + F = (int)unDig(x)/2 - 1; + n = 0; + } + else { + NeedExt(ex,x); + n = blk64(name(x))*BLKSIZE; + } + if (F >= Files) + dbfErr(ex); + rdLock(); + blkPeek(0, buf, 2*BLK), next = getAdr(buf+BLK); // Get Next + while ((n += BLKSIZE) < next) { + blkPeek(n << BlkShift[F], buf, BLK); + if ((buf[0] & TAGMASK) == 1) { + rwUnlock(1); + return mkId(n/BLKSIZE); + } + } + rwUnlock(1); + return Nil; +} + +// (lieu 'any) -> sym | NIL +any doLieu(any x) { + any y; + + x = cdr(x); + if (!isSym(x = EVAL(car(x))) || !isExt(x)) + return Nil; + for (y = tail1(x); !isSym(y); y = cdr(cellPtr(y))); + return y == At || y == At2? x : Nil; +} + +// (lock ['sym]) -> cnt | NIL +any doLock(any ex) { + any x; + pid_t n; + off_t blk; + + x = cdr(ex); + if (isNil(x = EVAL(car(x)))) + F = 0, n = tryLock(0,0); + else { + NeedExt(ex,x); + blk = blk64(name(x)); + if (F >= Files) + dbfErr(ex); + n = tryLock(blk * BlkSize[F], 1); + } + return n? boxCnt(n) : Nil; +} + +static int binSize(any x) { + if (isNum(x)) { + int n = numBytes(x); + + if (n < 63) + return n + 1; + return n + 2 + (n - 63) / 255; + } + else if (isNil(x)) + return 1; + else if (isSym(x)) + return binSize(name(x)); + else { + any y = x; + int n = 2; + + while (n += binSize(car(x)), !isNil(x = cdr(x))) { + if (x == y) + return n + 1; + if (!isCell(x)) + return n + binSize(x); + } + return n; + } +} + +int dbSize(any ex, any x) { + int n; + + db(ex,x,1); + n = BLK + 1 + binSize(val(x)); + for (x = tail1(x); isCell(x); x = cdr(x)) { + if (isSym(car(x))) + n += binSize(car(x)) + 2; + else + n += binSize(cdar(x)) + binSize(caar(x)); + } + return n; +} + + +void db(any ex, any s, int a) { + any x, y, *p; + + if (!isNum(x = tail1(s))) { + if (a == 1) + return; + while (!isNum(x = cdr(x))); + } + p = &cdr(numCell(x)); + while (isNum(*p)) + p = &cdr(numCell(*p)); + if (!isSym(*p)) + p = &car(*p); + if (*p != At3) { // not deleted + if (*p == At2) { // dirty + if (a == 3) { + *p = At3; // deleted + val(s) = Nil; + tail(s) = ext(x); + } + } + else if (isNil(*p) || a > 1) { + if (a == 3) { + *p = At3; // deleted + val(s) = Nil; + tail(s) = ext(x); + } + else if (*p == At) + *p = At2; // loaded -> dirty + else { // NIL & 1 | 2 + adr n; + cell c[1]; + + Push(c[0],s); + n = blk64(x); + if (F < Files) { + rdLock(); + rdBlock(n*BLKSIZE); + if ((Block[0] & TAGMASK) != 1) + err(ex, s, "Bad ID"); + *p = a == 1? At : At2; // loaded : dirty + getBin = getBlock; + val(s) = binRead(0); + if (!isNil(y = binRead(0))) { + tail(s) = ext(x = cons(y,x)); + if ((y = binRead(0)) != T) + car(x) = cons(y,car(x)); + while (!isNil(y = binRead(0))) { + cdr(x) = cons(y,cdr(x)); + if ((y = binRead(0)) != T) + cadr(x) = cons(y,cadr(x)); + x = cdr(x); + } + } + rwUnlock(1); + } + else { + if (!isCell(y = val(Ext)) || F < unBox(caar(y))) + dbfErr(ex); + while (isCell(cdr(y)) && F >= unBox(caadr(y))) + y = cdr(y); + y = apply(ex, cdar(y), NO, 1, c); // ((Obj) ..) + *p = At; // loaded + val(s) = car(y); + if (!isCell(y = cdr(y))) + tail(s) = ext(x); + else { + tail(s) = ext(y); + while (isCell(cdr(y))) + y = cdr(y); + cdr(y) = x; + } + } + drop(c[0]); + } + } + } +} + +// (commit ['any] [exe1] [exe2]) -> flg +any doCommit(any ex) { + bool note; + int i, extn; + adr n; + cell c1; + any x, y, z; + ptr pbSave, ppSave; + byte dirty[Files], buf[PIPE_BUF]; + + x = cdr(ex), Push(c1, EVAL(car(x))); + if (!Log) + ++Env.protect; + wrLock(); + if (Jnl) + lockFile(fileno(Jnl), F_SETLKW, F_WRLCK); + if (Log) { + for (F = 0; F < Files; ++F) + dirty[F] = 0, Fluse[F] = 0; + for (i = 0; i < EHASH; ++i) { // Save objects + for (x = Extern[i]; isCell(x); x = cdr(x)) { + for (y = tail1(car(x)); isCell(y); y = cdr(y)); + z = numCell(y); + while (isNum(cdr(z))) + z = numCell(cdr(z)); + if (cdr(z) == At2 || cdr(z) == At3) { // dirty or deleted + n = blk64(y); + if (F < Files) { + rdBlock(n*BLKSIZE); + while (logBlock(), BlkLink) + rdBlock(BlkLink); + dirty[F] = 1; + if (cdr(z) != At3) + ++Fluse[F]; + } + } + } + } + for (F = 0; F < Files; ++F) { + if (i = Fluse[F]) { + rdBlock(0); // Save Block 0 + while (logBlock(), BlkLink && --i >= 0) // and free list + rdBlock(BlkLink); + } + } + putc_unlocked(0xFF, Log), putc_unlocked(0xFF, Log); + fflush(Log); + if (fsync(fileno(Log)) < 0) + fsyncErr(ex, "Transaction"); + } + x = cddr(ex), EVAL(car(x)); + if (data(c1) == T) + note = NO, extn = EXTERN64; // Undocumented 64-bit DB export + else { + extn = 0; + if (note = !isNil(data(c1)) && (Tell || Children)) + tellBeg(&pbSave, &ppSave, buf), prTell(data(c1)); + } + for (i = 0; i < EHASH; ++i) { + for (x = Extern[i]; isCell(x); x = cdr(x)) { + for (y = tail1(car(x)); isCell(y); y = cdr(y)); + z = numCell(y); + while (isNum(cdr(z))) + z = numCell(cdr(z)); + if (cdr(z) == At2) { // dirty + n = blk64(y); + if (F < Files) { + rdBlock(n*BLKSIZE); + Block[0] |= 1; // Might be new + putBin = putBlock; + binPrint(extn, val(y = car(x))); + for (y = tail1(y); isCell(y); y = cdr(y)) { + if (isCell(car(y))) + binPrint(extn, cdar(y)), binPrint(extn, caar(y)); + else + binPrint(extn, car(y)), binPrint(extn, T); + } + putBlock(NIX); + setAdr(Block[0] & TAGMASK, Block); // Clear Link + wrBlock(); + if (BlkLink) + cleanUp(BlkLink); + cdr(z) = At; // loaded + if (note) { + if (PipePtr >= PipeBuf + PIPE_BUF - 12) { // EXTERN <2+1+7> END + tellEnd(&pbSave, &ppSave); + tellBeg(&pbSave, &ppSave, buf), prTell(data(c1)); + } + prTell(car(x)); + } + } + } + else if (cdr(z) == At3) { // deleted + n = blk64(y); + if (F < Files) { + cleanUp(n*BLKSIZE); + if (note) { + if (PipePtr >= PipeBuf + PIPE_BUF - 12) { // EXTERN <2+1+7> END + tellEnd(&pbSave, &ppSave); + tellBeg(&pbSave, &ppSave, buf), prTell(data(c1)); + } + prTell(car(x)); + } + } + cdr(z) = Nil; + } + } + } + if (note) + tellEnd(&pbSave, &ppSave); + x = cdddr(ex), EVAL(car(x)); + if (Jnl) + fflush(Jnl), lockFile(fileno(Jnl), F_SETLK, F_UNLCK); + if (isCell(x = val(Zap))) { + outFile f, *oSave; + char nm[pathSize(y = cdr(x))]; + + pathString(y, nm); + if ((f.fd = open(nm, O_APPEND|O_CREAT|O_WRONLY, 0666)) < 0) + openErr(ex, nm); + f.ix = 0; + f.tty = NO; + putBin = putStdout; + oSave = OutFile, OutFile = &f; + for (y = car(x); isCell(y); y = cdr(y)) + binPrint(0, car(y)); + flush(&f); + close(f.fd); + car(x) = Nil; + OutFile = oSave; + } + if (Log) { + for (F = 0; F < Files; ++F) + if (dirty[F] && fsync(BlkFile[F]) < 0) + fsyncErr(ex, "DB"); + fseek(Log, 0L, SEEK_SET); + if (ftruncate(fileno(Log), 0)) + truncErr(ex); + } + rwUnlock(0); // Unlock all + if (!Log) + --Env.protect; + for (F = 0; F < Files; ++F) + Fluse[F] = -1; + drop(c1); + return T; +} + +// (rollback) -> T +any doRollback(any x) { + int i; + any y, z; + + for (i = 0; i < EHASH; ++i) { + for (x = Extern[i]; isCell(x); x = cdr(x)) { + val(y = car(x)) = Nil; + for (z = tail1(y); isCell(z); z = cdr(z)); + tail(y) = ext(z); + z = numCell(z); + while (isNum(cdr(z))) + z = numCell(cdr(z)); + cdr(z) = Nil; + } + } + if (isCell(x = val(Zap))) + car(x) = Nil; + rwUnlock(0); // Unlock all + return T; +} + +// (mark 'sym|0 ['NIL | 'T | '0]) -> flg +any doMark(any ex) { + any x, y; + adr n, m; + int b; + byte *p; + + x = cdr(ex); + if (isNum(y = EVAL(car(x)))) { + if (Marks) { + for (F = 0; F < Files; ++F) + free(Mark[F]); + free(Mark), Mark = NULL, free(Marks), Marks = NULL; + } + return Nil; + } + NeedExt(ex,y); + n = blk64(name(y)); + if (F >= Files) + dbfErr(ex); + if (!Marks) { + Marks = alloc(Marks, Files * sizeof(adr)); + memset(Marks, 0, Files * sizeof(adr)); + Mark = alloc(Mark, Files * sizeof(byte*)); + memset(Mark, 0, Files * sizeof(byte*)); + } + b = 1 << (n & 7); + if ((n >>= 3) >= Marks[F]) { + m = Marks[F], Marks[F] = n + 1; + Mark[F] = alloc(Mark[F], Marks[F]); + memset(Mark[F] + m, 0, Marks[F] - m); + } + p = Mark[F] + n; + x = cdr(x); + y = *p & b? T : Nil; // Old value + if (!isNil(x = EVAL(car(x)))) { + if (isNum(x)) + *p &= ~b; // Clear mark + else + *p |= b; // Set mark + } + return y; +} + +// (free 'cnt) -> (sym . lst) +any doFree(any x) { + byte buf[2*BLK]; + cell c1; + + if ((F = (int)evCnt(x, cdr(x)) - 1) >= Files) + dbfErr(x); + rdLock(); + blkPeek(0, buf, 2*BLK); // Get Free, Next + Push(c1, x = cons(mkId(getAdr(buf+BLK)/BLKSIZE), Nil)); // Next + BlkLink = getAdr(buf); // Free + while (BlkLink) { + x = cdr(x) = cons(mkId(BlkLink/BLKSIZE), Nil); + rdBlock(BlkLink); + } + rwUnlock(1); + return Pop(c1); +} + +// (dbck ['cnt] 'flg) -> any +any doDbck(any ex) { + any x, y; + bool flg; + int i; + adr next, p, cnt; + word2 blks, syms; + byte buf[2*BLK]; + cell c1; + + F = 0; + x = cdr(ex); + if (isNum(y = EVAL(car(x)))) { + if ((F = (int)unDig(y)/2 - 1) >= Files) + dbfErr(ex); + x = cdr(x), y = EVAL(car(x)); + } + flg = !isNil(y); + cnt = BLKSIZE; + blks = syms = 0; + ++Env.protect; + wrLock(); + if (Jnl) + lockFile(fileno(Jnl), F_SETLKW, F_WRLCK); + blkPeek(0, buf, 2*BLK); // Get Free, Next + BlkLink = getAdr(buf); + next = getAdr(buf+BLK); + while (BlkLink) { // Check free list + rdBlock(BlkLink); + if ((cnt += BLKSIZE) > next) { + x = mkStr("Circular free list"); + goto done; + } + Block[0] |= TAGMASK, wrBlock(); // Mark free list + } + for (p = BLKSIZE; p != next; p += BLKSIZE) { // Check all chains + if (rdBlock(p), (Block[0] & TAGMASK) == 0) { + cnt += BLKSIZE; + memcpy(Block, buf, BLK); // Insert into free list + wrBlock(); + setAdr(p, buf), blkPoke(0, buf, BLK); + } + else if ((Block[0] & TAGMASK) == 1) { + ++blks, ++syms; + cnt += BLKSIZE; + for (i = 2; BlkLink; cnt += BLKSIZE) { + ++blks; + rdBlock(BlkLink); + if ((Block[0] & TAGMASK) != i) { + x = mkStr("Bad chain"); + goto done; + } + if (i < TAGMASK) + ++i; + } + } + } + BlkLink = getAdr(buf); // Unmark free list + while (BlkLink) { + rdBlock(BlkLink); + if (Block[0] & TAGMASK) + Block[0] &= BLKMASK, wrBlock(); + } + if (cnt != next) + x = mkStr("Bad count"); + else if (!flg) + x = Nil; + else { + Push(c1, boxWord2(syms)); + data(c1) = cons(boxWord2(blks), data(c1)); + x = Pop(c1); + } +done: + if (Jnl) + fflush(Jnl), lockFile(fileno(Jnl), F_SETLK, F_UNLCK); + rwUnlock(1); + --Env.protect; + return x; +} diff --git a/src/lat1.c b/src/lat1.c @@ -0,0 +1,75 @@ +/* lat1.c + * 31mar05abu + * Convert stdin (UTF-8, 2-Byte) to process or file (ISO-8859-15) + */ + +#include <stdio.h> +#include <stdlib.h> +#include <unistd.h> +#include <errno.h> +#include <signal.h> +#include <sys/wait.h> + +// lat1 [-<cmd> [<arg> ..]] +// lat1 [[+]<Outfile/ISO-8859-15>] +int main(int ac, char *av[]) { + int c; + pid_t pid = 0; + FILE *fp = stdout; + + if (ac > 1) { + char *mode = "w"; + + if (*av[1] == '-') { + int pfd[2]; + + if (pipe(pfd) < 0) { + fprintf(stderr, "lat1: Pipe error\n"); + return 1; + } + if ((pid = fork()) == 0) { + close(pfd[1]); + if (pfd[0] != STDIN_FILENO) + dup2(pfd[0], STDIN_FILENO), close(pfd[0]); + execvp(av[1]+1, av+1); + } + if (pid < 0) { + fprintf(stderr, "lat1: Fork error\n"); + return 1; + } + close(pfd[0]); + if (!(fp = fdopen(pfd[1], mode))) { + fprintf(stderr, "lat1: Pipe open error\n"); + return 1; + } + } + else { + if (*av[1] == '+') + mode = "a", ++av[1]; + if (!(fp = fopen(av[1], mode))) { + fprintf(stderr, "lat1: '%s' open error\n", av[1]); + return 1; + } + } + } + while ((c = getchar_unlocked()) != EOF) { + if ((c & 0x80) == 0) + putc_unlocked(c,fp); + else if ((c & 0x20) == 0) + putc_unlocked((c & 0x1F) << 6 | getchar_unlocked() & 0x3F, fp); + else { + getchar_unlocked(); // 0x82 + getchar_unlocked(); // 0xAC + putc_unlocked(0xA4, fp); + } + } + if (pid) { + fclose(fp); + while (waitpid(pid, NULL, 0) < 0) + if (errno != EINTR) { + fprintf(stderr, "lat1: Pipe close error\n"); + return 1; + } + } + return 0; +} diff --git a/src/main.c b/src/main.c @@ -0,0 +1,1140 @@ +/* 22apr10abu + * (c) Software Lab. Alexander Burger + */ + +#include "pico.h" + +/* Globals */ +int Signal, Repl, Chr, Slot, Spkr, Mic, Hear, Tell, Children, ExtN; +char **AV, *AV0, *Home; +child *Child; +heap *Heaps; +cell *Avail; +stkEnv Env; +catchFrame *CatchPtr; +struct termios OrgTermio, *Termio; +int InFDs, OutFDs; +inFile *InFile, **InFiles; +outFile *OutFile, **OutFiles; +int (*getBin)(void); +void (*putBin)(int); +any TheKey, TheCls, Thrown; +any Alarm, Line, Zero, One, Intern[IHASH], Transient[IHASH], Extern[EHASH]; +any ApplyArgs, ApplyBody, DbVal, DbTail; +any Nil, DB, Meth, Quote, T; +any Solo, PPid, Pid, At, At2, At3, This, Dbg, Zap, Ext, Scl, Class; +any Run, Hup, Sig1, Sig2, Up, Err, Msg, Uni, Led, Tsm, Adr, Fork, Bye; + +static int TtyPid; +static word2 USec; +static struct timeval Tv; +static bool Tio, Jam; +static jmp_buf ErrRst; +static void finish(int) __attribute__ ((noreturn)); +static struct rlimit ULim = {RLIM_INFINITY, RLIM_INFINITY}; + + +/*** System ***/ +static void finish(int n) { + setCooked(); + exit(n); +} + +void giveup(char *msg) { + fprintf(stderr, "%d %s\n", (int)getpid(), msg); + finish(1); +} + +void bye(int n) { + static bool flg; + + if (!flg) { + flg = YES; + unwind(NULL); + prog(val(Bye)); + } + flushAll(); + finish(n); +} + +void execError(char *s) { + fprintf(stderr, "%s: can't exec\n", s); + exit(127); +} + +/* Install interrupting signal */ +static void iSignal(int n, void (*foo)(int)) { + struct sigaction act, old; + + act.sa_handler = foo; + sigemptyset(&act.sa_mask); + act.sa_flags = 0; + sigaction(n, &act, &old); +} + +/* Signal handler */ +void sighandler(any ex) { + int i; + bool flg; + + if (!Env.protect) { + Env.protect = 1; + switch (Signal) { + case SIGHUP: + Signal = 0, run(val(Hup)); + break; + case SIGINT: + Signal = 0; + if (Repl < 2) + brkLoad(ex ?: Nil); + break; + case SIGUSR1: + Signal = 0, run(val(Sig1)); + break; + case SIGUSR2: + Signal = 0, run(val(Sig2)); + break; + case SIGALRM: + Signal = 0, run(Alarm); + break; + case SIGTERM: + for (flg = NO, i = 0; i < Children; ++i) + if (Child[i].pid && kill(Child[i].pid, SIGTERM) == 0) + flg = YES; + if (!flg) + Signal = 0, bye(0); + break; + } + Env.protect = 0; + } +} + +static void sig(int n) { + if (TtyPid) + kill(TtyPid, n); + else + Signal = n; +} + +static void sigTerm(int n) { + if (TtyPid) + kill(TtyPid, n); + else + Signal = SIGTERM; +} + +static void sigChld(int n __attribute__((unused))) { + int e, stat; + pid_t pid; + + e = errno; + while ((pid = waitpid(0, &stat, WNOHANG)) > 0) + if (WIFSIGNALED(stat)) + fprintf(stderr, "%d SIG-%d\n", (int)pid, WTERMSIG(stat)); + errno = e; +} + +static void tcSet(struct termios *p) { + if (Termio) + while (tcsetattr(STDIN_FILENO, TCSADRAIN, p) && errno == EINTR); +} + +static void sigTermStop(int n __attribute__((unused))) { + sigset_t mask; + + tcSet(&OrgTermio); + sigemptyset(&mask); + sigaddset(&mask, SIGTSTP); + sigprocmask(SIG_UNBLOCK, &mask, NULL); + signal(SIGTSTP, SIG_DFL), raise(SIGTSTP), signal(SIGTSTP, sigTermStop); + tcSet(Termio); +} + +void setRaw(void) { + if (Tio && !Termio) { + *(Termio = malloc(sizeof(struct termios))) = OrgTermio; + Termio->c_iflag = 0; + Termio->c_lflag = ISIG; + Termio->c_cc[VMIN] = 1; + Termio->c_cc[VTIME] = 0; + tcSet(Termio); + if (signal(SIGTSTP,SIG_IGN) == SIG_DFL) + signal(SIGTSTP, sigTermStop); + } +} + +void setCooked(void) { + tcSet(&OrgTermio); + free(Termio), Termio = NULL; +} + +// (raw ['flg]) -> flg +any doRaw(any x) { + if (!isCell(x = cdr(x))) + return Termio? T : Nil; + if (isNil(EVAL(car(x)))) { + setCooked(); + return Nil; + } + setRaw(); + return T; +} + +// (alarm 'cnt . prg) -> cnt +any doAlarm(any x) { + int n = alarm((int)evCnt(x,cdr(x))); + Alarm = cddr(x); + return boxCnt(n); +} + +// (protect . prg) -> any +any doProtect(any x) { + ++Env.protect; + x = prog(cdr(x)); + --Env.protect; + return x; +} + +/* Allocate memory */ +void *alloc(void *p, size_t siz) { + if (!(p = realloc(p,siz))) + giveup("No memory"); + return p; +} + +/* Allocate cell heap */ +void heapAlloc(void) { + heap *h; + cell *p; + + h = (heap*)alloc(NULL, sizeof(heap)); + h->next = Heaps, Heaps = h; + p = h->cells + CELLS-1; + do + Free(p); + while (--p >= h->cells); +} + +// (heap 'flg) -> cnt +any doHeap(any x) { + long n = 0; + + x = cdr(x); + if (isNil(EVAL(car(x)))) { + heap *h = Heaps; + do + ++n; + while (h = h->next); + return boxCnt(n); + } + for (x = Avail; x; x = car(x)) + ++n; + return boxCnt(n / CELLS); +} + +// (env ['lst] | ['sym 'val] ..) -> lst +any doEnv(any x) { + int i; + bindFrame *p; + cell c1, c2; + + Push(c1, Nil); + if (!isCell(x = cdr(x))) { + for (p = Env.bind; p; p = p->link) { + if (p->i == 0) { + for (i = p->cnt; --i >= 0;) { + for (x = data(c1); ; x = cdr(x)) { + if (!isCell(x)) { + data(c1) = cons(cons(p->bnd[i].sym, val(p->bnd[i].sym)), data(c1)); + break; + } + if (caar(x) == p->bnd[i].sym) + break; + } + } + } + } + } + else { + do { + Push(c2, EVAL(car(x))); + if (isCell(data(c2))) { + do + data(c1) = cons(cons(car(data(c2)), val(car(data(c2)))), data(c1)); + while (isCell(data(c2) = cdr(data(c2)))); + } + else if (!isNil(data(c2))) { + x = cdr(x); + data(c1) = cons(cons(data(c2), EVAL(car(x))), data(c1)); + } + drop(c2); + } + while (isCell(x = cdr(x))); + } + return Pop(c1); +} + +// (up [cnt] sym ['val]) -> any +any doUp(any x) { + any y, *val; + int cnt, i; + bindFrame *p; + + x = cdr(x); + if (!isNum(y = car(x))) + cnt = 1; + else + cnt = (int)unBox(y), x = cdr(x), y = car(x); + for (p = Env.bind, val = &val(y); p; p = p->link) { + if (p->i <= 0) { + for (i = 0; i < p->cnt; ++i) + if (p->bnd[i].sym == y) { + if (!--cnt) { + if (isCell(x = cdr(x))) + return p->bnd[i].val = EVAL(car(x)); + return p->bnd[i].val; + } + val = &p->bnd[i].val; + } + } + } + if (isCell(x = cdr(x))) + return *val = EVAL(car(x)); + return *val; +} + +/*** Primitives ***/ +/* Comparisons */ +bool equal(any x, any y) { + for (;;) { + if (x == y) + return YES; + if (isNum(x)) { + if (!isNum(y) || unDig(x) != unDig(y)) + return NO; + x = cdr(numCell(x)), y = cdr(numCell(y)); + } + else if (isSym(x)) { + if (!isSym(y) || !isNum(x = name(x)) || !isNum(y = name(y))) + return NO; + } + else { + any a, b; + + if (!isCell(y)) + return NO; + while (car(x) == Quote) { + if (car(y) != Quote) + return NO; + if (x == cdr(x)) + return y == cdr(y); + if (y == cdr(y)) + return NO; + if (!isCell(x = cdr(x))) + return equal(x, cdr(y)); + if (!isCell(y = cdr(y))) + return NO; + } + a = x, b = y; + for (;;) { + if (!equal(car(x), car(y))) + return NO; + if (!isCell(x = cdr(x))) + return equal(x, cdr(y)); + if (!isCell(y = cdr(y))) + return NO; + if (x == a && y == b) + return YES; + } + } + } +} + +int compare(any x, any y) { + any a, b; + + if (x == y) + return 0; + if (isNil(x)) + return -1; + if (x == T) + return +1; + if (isNum(x)) { + if (!isNum(y)) + return isNil(y)? +1 : -1; + return bigCompare(x,y); + } + if (isSym(x)) { + int b1, b2; + word n1, n2; + + if (isNum(y) || isNil(y)) + return +1; + if (isCell(y) || y == T) + return -1; + if (!isNum(a = name(x))) + return !isNum(name(y))? 1664525*(int32_t)(long)x - 1664525*(int32_t)(long)y : -1; + if (!isNum(b = name(y))) + return +1; + n1 = unDig(a), n2 = unDig(b); + for (;;) { + if ((b1 = n1 & 0xFF) != (b2 = n2 & 0xFF)) + return b1 - b2; + if ((n1 >>= 8) == 0) { + if ((n2 >>= 8) != 0) + return -1; + if (!isNum(a = cdr(numCell(a)))) + return !isNum(b = cdr(numCell(b)))? 0 : -1; + if (!isNum(b = cdr(numCell(b)))) + return +1; + n1 = unDig(a), n2 = unDig(b); + } + else if ((n2 >>= 8) == 0) + return +1; + } + } + if (!isCell(y)) + return y == T? -1 : +1; + a = x, b = y; + for (;;) { + int n; + + if (n = compare(car(x),car(y))) + return n; + if (!isCell(x = cdr(x))) + return compare(x, cdr(y)); + if (!isCell(y = cdr(y))) + return y == T? -1 : +1; + if (x == a && y == b) + return 0; + } +} + +/*** Error handling ***/ +void err(any ex, any x, char *fmt, ...) { + va_list ap; + char msg[240]; + outFrame f; + + va_start(ap,fmt); + vsnprintf(msg, sizeof(msg), fmt, ap); + va_end(ap); + val(Up) = ex ?: Nil; + if (msg[0]) { + any y; + catchFrame *p; + + val(Msg) = mkStr(msg); + for (p = CatchPtr; p; p = p->link) + if (y = p->tag) + while (isCell(y)) { + if (subStr(car(y), val(Msg))) { + Thrown = isNil(car(y))? val(Msg) : car(y); + unwind(p); + longjmp(p->rst, 1); + } + y = cdr(y); + } + } + Chr = ExtN = 0; + Env.brk = NO; + Alarm = Line = Nil; + f.pid = 0, f.fd = STDERR_FILENO, pushOutFiles(&f); + if (InFile && InFile->name) { + Env.put('['); + outString(InFile->name), Env.put(':'), outWord(InFile->src); + Env.put(']'), space(); + } + if (ex) + outString("!? "), print(ex), newline(); + if (x) + print(x), outString(" -- "); + if (msg[0]) { + outString(msg), newline(); + if (!isNil(val(Err)) && !Jam) + Jam = YES, prog(val(Err)), Jam = NO; + if (!isatty(STDIN_FILENO) || !isatty(STDOUT_FILENO)) + bye(1); + load(NULL, '?', Nil); + } + unwind(NULL); + Env.stack = NULL; + Env.meth = NULL; + Env.protect = Env.trace = 0; + Env.next = -1; + Env.task = Nil; + Env.make = Env.yoke = NULL; + Env.parser = NULL; + longjmp(ErrRst, +1); +} + +// (quit ['any ['any]]) +any doQuit(any x) { + any y; + + x = cdr(x), y = evSym(x); + { + char msg[bufSize(y)]; + + bufString(y, msg); + x = isCell(x = cdr(x))? EVAL(car(x)) : NULL; + err(NULL, x, "%s", msg); + } +} + +void argError(any ex, any x) {err(ex, x, "Bad argument");} +void numError(any ex, any x) {err(ex, x, "Number expected");} +void cntError(any ex, any x) {err(ex, x, "Small number expected");} +void symError(any ex, any x) {err(ex, x, "Symbol expected");} +void extError(any ex, any x) {err(ex, x, "External symbol expected");} +void cellError(any ex, any x) {err(ex, x, "Cell expected");} +void atomError(any ex, any x) {err(ex, x, "Atom expected");} +void lstError(any ex, any x) {err(ex, x, "List expected");} +void varError(any ex, any x) {err(ex, x, "Variable expected");} +void protError(any ex, any x) {err(ex, x, "Protected symbol");} + +void pipeError(any ex, char *s) {err(ex, NULL, "Pipe %s error", s);} + +void unwind(catchFrame *catch) { + any x; + int i, j, n; + bindFrame *p; + catchFrame *q; + + while (q = CatchPtr) { + while (p = Env.bind) { + if ((i = Env.bind->i) < 0) { + j = i, n = 0; + while (++n, ++j && (p = p->link)) + if (p->i >= 0 || p->i < i) + --j; + do { + for (p = Env.bind, j = n; --j; p = p->link); + if (p->i < 0 && ((p->i -= i) > 0? (p->i = 0) : p->i) == 0) + for (j = p->cnt; --j >= 0;) { + x = val(p->bnd[j].sym); + val(p->bnd[j].sym) = p->bnd[j].val; + p->bnd[j].val = x; + } + } while (--n); + } + if (Env.bind == q->env.bind) + break; + if (Env.bind->i == 0) + for (i = Env.bind->cnt; --i >= 0;) + val(Env.bind->bnd[i].sym) = Env.bind->bnd[i].val; + Env.bind = Env.bind->link; + } + while (Env.inFrames != q->env.inFrames) + popInFiles(); + while (Env.outFrames != q->env.outFrames) + popOutFiles(); + while (Env.ctlFrames != q->env.ctlFrames) + popCtlFiles(); + Env = q->env; + EVAL(q->fin); + CatchPtr = q->link; + if (q == catch) + return; + } + while (Env.bind) { + if (Env.bind->i == 0) + for (i = Env.bind->cnt; --i >= 0;) + val(Env.bind->bnd[i].sym) = Env.bind->bnd[i].val; + Env.bind = Env.bind->link; + } + while (Env.inFrames) + popInFiles(); + while (Env.outFrames) + popOutFiles(); + while (Env.ctlFrames) + popCtlFiles(); +} + +/*** Evaluation ***/ +any evExpr(any expr, any x) { + any y = car(expr); + struct { // bindFrame + struct bindFrame *link; + int i, cnt; + struct {any sym; any val;} bnd[length(y)+2]; + } f; + + f.link = Env.bind, Env.bind = (bindFrame*)&f; + f.i = sizeof(f.bnd) / (2*sizeof(any)) - 1; + f.cnt = 1, f.bnd[0].sym = At, f.bnd[0].val = val(At); + while (isCell(y)) { + f.bnd[f.cnt].sym = car(y); + f.bnd[f.cnt].val = EVAL(car(x)); + ++f.cnt, x = cdr(x), y = cdr(y); + } + if (isNil(y)) { + while (--f.i > 0) { + x = val(f.bnd[f.i].sym); + val(f.bnd[f.i].sym) = f.bnd[f.i].val; + f.bnd[f.i].val = x; + } + x = prog(cdr(expr)); + } + else if (y != At) { + f.bnd[f.cnt].sym = y, f.bnd[f.cnt++].val = val(y), val(y) = x; + while (--f.i > 0) { + x = val(f.bnd[f.i].sym); + val(f.bnd[f.i].sym) = f.bnd[f.i].val; + f.bnd[f.i].val = x; + } + x = prog(cdr(expr)); + } + else { + int n, cnt; + cell *arg; + cell c[n = cnt = length(x)]; + + while (--n >= 0) + Push(c[n], EVAL(car(x))), x = cdr(x); + while (--f.i > 0) { + x = val(f.bnd[f.i].sym); + val(f.bnd[f.i].sym) = f.bnd[f.i].val; + f.bnd[f.i].val = x; + } + n = Env.next, Env.next = cnt; + arg = Env.arg, Env.arg = c; + x = prog(cdr(expr)); + if (cnt) + drop(c[cnt-1]); + Env.arg = arg, Env.next = n; + } + while (--f.cnt >= 0) + val(f.bnd[f.cnt].sym) = f.bnd[f.cnt].val; + Env.bind = f.link; + return x; +} + +any funq(any x) { + any y; + + if (isSym(x)) + return Nil; + if (isNum(x)) + return (unDig(x)&3) || isNum(cdr(numCell(x)))? Nil : x; + for (y = cdr(x); isCell(y); y = cdr(y)) { + if (y == x) + return Nil; + if (isCell(car(y))) { + if (isNum(caar(y))) { + if (isCell(cdr(y))) + return Nil; + } + else if (isNil(caar(y)) || caar(y) == T) + return Nil; + } + else if (!isNil(cdr(y))) + return Nil; + } + if (!isNil(y)) + return Nil; + if (isNil(x = car(x))) + return T; + for (y = x; isCell(y);) + if (isNum(car(y)) || isCell(car(y)) || isNil(car(y)) || car(y)==T || x==(y=cdr(y))) + return Nil; + return isNum(y) || y==T? Nil : x; +} + +bool sharedLib(any x) { + void *h; + char *p, nm[bufSize(x)]; + + bufString(x, nm); + if (!(p = strchr(nm,':')) || p == nm || p[1] == '\0') + return NO; + *p++ = '\0'; + { + int n = Home? strlen(Home) : 0; +#ifndef __CYGWIN__ + char buf[n + strlen(nm) + 4 + 1]; +#else + char buf[n + strlen(nm) + 4 + 4 + 1]; +#endif + + if (strchr(nm,'/')) + strcpy(buf, nm); + else { + if (n) + memcpy(buf, Home, n); + strcpy(buf + n, "lib/"), strcpy(buf + n + 4, nm); +#ifdef __CYGWIN__ + strcpy(buf + n + 4 + strlen(nm), ".dll"); +#endif + } + if (!(h = dlopen(buf, RTLD_LAZY | RTLD_GLOBAL)) || !(h = dlsym(h,p))) + return NO; + val(x) = box(num(h)); + } + return YES; +} + +void undefined(any x, any ex) { + if (!sharedLib(x)) + err(ex, x, "Undefined"); +} + +static any evList2(any foo, any ex) { + cell c1; + + Push(c1, foo); + if (isCell(foo)) { + foo = evExpr(foo, cdr(ex)); + drop(c1); + return foo; + } + for (;;) { + if (isNil(val(foo))) + undefined(foo,ex); + if (Signal) + sighandler(ex); + if (isNum(foo = val(foo))) { + foo = evSubr(foo,ex); + drop(c1); + return foo; + } + if (isCell(foo)) { + foo = evExpr(foo, cdr(ex)); + drop(c1); + return foo; + } + } +} + +/* Evaluate a list */ +any evList(any ex) { + any foo; + + if (!isSym(foo = car(ex))) { + if (isNum(foo)) + return ex; + if (Signal) + sighandler(ex); + if (isNum(foo = evList(foo))) + return evSubr(foo,ex); + return evList2(foo,ex); + } + for (;;) { + if (isNil(val(foo))) + undefined(foo,ex); + if (Signal) + sighandler(ex); + if (isNum(foo = val(foo))) + return evSubr(foo,ex); + if (isCell(foo)) + return evExpr(foo, cdr(ex)); + } +} + +/* Evaluate any to sym */ +any evSym(any x) {return xSym(EVAL(car(x)));} + +any xSym(any x) { + int i; + any nm; + cell c1, c2; + + if (isSym(x)) + return x; + Push(c1,x); + nm = NULL, pack(x, &i, &nm, &c2); + drop(c1); + return nm? consStr(data(c2)) : Nil; +} + +/* Evaluate count */ +long evCnt(any ex, any x) {return xCnt(ex, EVAL(car(x)));} + +long xCnt(any ex, any x) { + NeedCnt(ex,x); + return unBox(x); +} + +/* Evaluate double */ +double evDouble(any ex, any x) { + x = EVAL(car(x)); + NeedNum(ex,x); + return numToDouble(x); +} + +// (args) -> flg +any doArgs(any ex __attribute__((unused))) { + return Env.next > 0? T : Nil; +} + +// (next) -> any +any doNext(any ex __attribute__((unused))) { + if (Env.next > 0) + return data(Env.arg[--Env.next]); + if (Env.next == 0) + Env.next = -1; + return Nil; +} + +// (arg ['cnt]) -> any +any doArg(any ex) { + long n; + + if (Env.next < 0) + return Nil; + if (!isCell(cdr(ex))) + return data(Env.arg[Env.next]); + if ((n = evCnt(ex,cdr(ex))) > 0 && n <= Env.next) + return data(Env.arg[Env.next - n]); + return Nil; +} + +// (rest) -> lst +any doRest(any x) { + int i; + cell c1; + + if ((i = Env.next) <= 0) + return Nil; + Push(c1, x = cons(data(Env.arg[--i]), Nil)); + while (i) + x = cdr(x) = cons(data(Env.arg[--i]), Nil); + return Pop(c1); +} + +static struct tm *TM; + +any mkDat(int y, int m, int d) { + int n; + static char mon[13] = {31,31,28,31,30,31,30,31,31,30,31,30,31}; + + if (m<1 || m>12 || d<1 || d>mon[m] && (m!=2 || d!=29 || y%4 || !(y%100) && y%400)) + return Nil; + n = (12*y + m - 3) / 12; + return boxCnt((4404*y+367*m-1094)/12 - 2*n + n/4 - n/100 + n/400 + d); +} + +// (date ['T]) -> dat +// (date 'dat) -> (y m d) +// (date 'y 'm 'd) -> dat | NIL +// (date '(y m d)) -> dat | NIL +any doDate(any ex) { + any x, z; + int y, m, d, n; + cell c1; + time_t tim; + + if (!isCell(x = cdr(ex))) { + time(&tim); + TM = localtime(&tim); + return mkDat(TM->tm_year+1900, TM->tm_mon+1, TM->tm_mday); + } + if ((z = EVAL(car(x))) == T) { + time(&tim); + TM = gmtime(&tim); + return mkDat(TM->tm_year+1900, TM->tm_mon+1, TM->tm_mday); + } + if (isNil(z)) + return Nil; + if (isCell(z)) + return mkDat(xCnt(ex, car(z)), xCnt(ex, cadr(z)), xCnt(ex, caddr(z))); + if (!isCell(x = cdr(x))) { + n = xCnt(ex,z); + y = (100*n - 20) / 3652425; + n += (y - y/4); + y = (100*n - 20) / 36525; + n -= 36525*y / 100; + m = (10*n - 5) / 306; + d = (10*n - 306*m + 5) / 10; + if (m < 10) + m += 3; + else + ++y, m -= 9; + Push(c1, cons(boxCnt(d), Nil)); + data(c1) = cons(boxCnt(m), data(c1)); + data(c1) = cons(boxCnt(y), data(c1)); + return Pop(c1); + } + y = xCnt(ex,z); + m = evCnt(ex,x); + return mkDat(y, m, evCnt(ex,cdr(x))); +} + +any mkTime(int h, int m, int s) { + if (h < 0 || h > 23 || m < 0 || m > 59 || s < 0 || s > 60) + return Nil; + return boxCnt(h * 3600 + m * 60 + s); +} + +// (time ['T]) -> tim +// (time 'tim) -> (h m s) +// (time 'h 'm ['s]) -> tim | NIL +// (time '(h m [s])) -> tim | NIL +any doTime(any ex) { + any x, z; + int h, m, s; + cell c1; + time_t tim; + struct tm *p; + + if (!isCell(x = cdr(ex))) { + time(&tim); + p = localtime(&tim); + return boxCnt(p->tm_hour * 3600 + p->tm_min * 60 + p->tm_sec); + } + if ((z = EVAL(car(x))) == T) + return TM? boxCnt(TM->tm_hour * 3600 + TM->tm_min * 60 + TM->tm_sec) : Nil; + if (isNil(z)) + return Nil; + if (isCell(z)) + return mkTime(xCnt(ex, car(z)), xCnt(ex, cadr(z)), isCell(cddr(z))? xCnt(ex, caddr(z)) : 0); + if (!isCell(x = cdr(x))) { + s = xCnt(ex,z); + Push(c1, cons(boxCnt(s % 60), Nil)); + data(c1) = cons(boxCnt(s / 60 % 60), data(c1)); + data(c1) = cons(boxCnt(s / 3600), data(c1)); + return Pop(c1); + } + h = xCnt(ex, z); + m = evCnt(ex, x); + return mkTime(h, m, isCell(cdr(x))? evCnt(ex, cdr(x)) : 0); +} + +// (usec) -> num +any doUsec(any ex __attribute__((unused))) { + gettimeofday(&Tv,NULL); + return boxWord2((word2)Tv.tv_sec*1000000 + Tv.tv_usec - USec); +} + +// (pwd) -> sym +any doPwd(any x) { + char *p; + + if ((p = getcwd(NULL,0)) == NULL) + return Nil; + x = mkStr(p); + free(p); + return x; +} + +// (cd 'any) -> sym +any doCd(any x) { + x = evSym(cdr(x)); + { + char *p, path[pathSize(x)]; + + pathString(x, path); + if ((p = getcwd(NULL,0)) == NULL || path[0] && chdir(path) < 0) + return Nil; + x = mkStr(p); + free(p); + return x; + } +} + +// (ctty 'sym|pid) -> flg +any doCtty(any ex) { + any x; + + if (isNum(x = EVAL(cadr(ex)))) + TtyPid = unDig(x) / 2; + else { + if (!isSym(x)) + argError(ex,x); + { + char tty[bufSize(x)]; + + bufString(x, tty); + if (!freopen(tty,"r",stdin) || !freopen(tty,"w",stdout) || !freopen(tty,"w",stderr)) + return Nil; + OutFiles[STDOUT_FILENO]->tty = YES; + } + } + return T; +} + +// (info 'any) -> (cnt|T dat . tim) +any doInfo(any x) { + cell c1; + struct tm *p; + struct stat st; + + x = evSym(cdr(x)); + { + char nm[pathSize(x)]; + + pathString(x, nm); + if (stat(nm, &st) < 0) + return Nil; + p = gmtime(&st.st_mtime); + Push(c1, boxCnt(p->tm_hour * 3600 + p->tm_min * 60 + p->tm_sec)); + data(c1) = cons(mkDat(p->tm_year+1900, p->tm_mon+1, p->tm_mday), data(c1)); + data(c1) = cons(S_ISDIR(st.st_mode)? T : boxWord2((word2)st.st_size), data(c1)); + return Pop(c1); + } +} + +// (file) -> (sym1 sym2 . num) | NIL +any doFile(any ex __attribute__((unused))) { + char *s, *p; + cell c1; + + if (!InFile || !InFile->name) + return Nil; + Push(c1, boxCnt(InFile->src)); + s = strdup(InFile->name); + if (p = strrchr(s, '/')) { + data(c1) = cons(mkStr(p+1), data(c1)); + *(p+1) = '\0'; + data(c1) = cons(mkStr(s), data(c1)); + } + else { + data(c1) = cons(mkStr(s), data(c1)); + data(c1) = cons(mkStr("./"), data(c1)); + } + free(s); + return Pop(c1); +} + +// (dir ['any]) -> lst +any doDir(any x) { + any y; + DIR *dp; + struct dirent *p; + cell c1; + + if (isNil(x = evSym(cdr(x)))) + dp = opendir("."); + else { + char nm[pathSize(x)]; + + pathString(x, nm); + dp = opendir(nm); + } + if (!dp) + return Nil; + do { + if (!(p = readdir(dp))) { + closedir(dp); + return Nil; + } + } while (p->d_name[0] == '.'); + Push(c1, y = cons(mkStr(p->d_name), Nil)); + while (p = readdir(dp)) + if (p->d_name[0] != '.') + y = cdr(y) = cons(mkStr(p->d_name), Nil); + closedir(dp); + return Pop(c1); +} + +// (cmd ['any]) -> sym +any doCmd(any x) { + if (isNil(x = evSym(cdr(x)))) + return mkStr(AV0); + bufString(x, AV0); + return x; +} + +// (argv [var ..] [. sym]) -> lst|sym +any doArgv(any ex) { + any x, y; + char **p; + cell c1; + + if (*(p = AV) && strcmp(*p,"-") == 0) + ++p; + if (isNil(x = cdr(ex))) { + if (!*p) + return Nil; + Push(c1, x = cons(mkStr(*p++), Nil)); + while (*p) + x = cdr(x) = cons(mkStr(*p++), Nil); + return Pop(c1); + } + do { + if (!isCell(x)) { + NeedSym(ex,x); + CheckVar(ex,x); + if (!*p) + return val(x) = Nil; + Push(c1, y = cons(mkStr(*p++), Nil)); + while (*p) + y = cdr(y) = cons(mkStr(*p++), Nil); + return val(x) = Pop(c1); + } + y = car(x); + NeedVar(ex,y); + CheckVar(ex,y); + val(y) = *p? mkStr(*p++) : Nil; + } while (!isNil(x = cdr(x))); + return val(y); +} + +// (opt) -> sym +any doOpt(any ex __attribute__((unused))) { + return *AV && strcmp(*AV,"-")? mkStr(*AV++) : Nil; +} + +any loadAll(any ex) { + any x = Nil; + + while (*AV && strcmp(*AV,"-") != 0) + x = load(ex, 0, mkStr(*AV++)); + return x; +} + +/*** Main ***/ +static void init(int ac, char *av[]) { + int i; + char *p; + sigset_t sigs; + + for (i = 1; i < ac; ++i) + if (*av[i] != '-') { + if ((p = strrchr(av[i], '/')) && !(p == av[i]+1 && *av[i] == '.')) { + Home = malloc(p - av[i] + 2); + memcpy(Home, av[i], p - av[i] + 1); + Home[p - av[i] + 1] = '\0'; + } + break; + } + AV0 = *av++; + AV = av; + heapAlloc(); + initSymbols(); + Env.get = getStdin; + InFile = initInFile(STDIN_FILENO, NULL); + Env.put = putStdout; + initOutFile(STDERR_FILENO); + OutFile = initOutFile(STDOUT_FILENO); + Env.task = Alarm = Line = Nil; + setrlimit(RLIMIT_STACK, &ULim); + Tio = tcgetattr(STDIN_FILENO, &OrgTermio) == 0; + ApplyArgs = cons(cons(consSym(Nil,Nil), Nil), Nil); + ApplyBody = cons(Nil,Nil); + sigfillset(&sigs); + sigprocmask(SIG_UNBLOCK, &sigs, NULL); + iSignal(SIGHUP, sig); + iSignal(SIGINT, sigTerm); + iSignal(SIGUSR1, sig); + iSignal(SIGUSR2, sig); + iSignal(SIGALRM, sig); + iSignal(SIGTERM, sig); + signal(SIGCHLD, sigChld); + signal(SIGPIPE, SIG_IGN); + signal(SIGTTIN, SIG_IGN); + signal(SIGTTOU, SIG_IGN); + gettimeofday(&Tv,NULL); + USec = (word2)Tv.tv_sec*1000000 + Tv.tv_usec; +} + +int MAIN(int ac, char *av[]) { + init(ac,av); + if (!setjmp(ErrRst)) { + loadAll(NULL); + ++Repl; + iSignal(SIGINT, sig); + } + load(NULL, ':', Nil); + bye(0); +} diff --git a/src/net.c b/src/net.c @@ -0,0 +1,204 @@ +/* 08oct09abu + * (c) Software Lab. Alexander Burger + */ + +#include "pico.h" + +#include <netdb.h> +#include <sys/socket.h> +#include <arpa/inet.h> +#include <netinet/tcp.h> +#include <netinet/in.h> + +static void ipErr(any ex, char *s) { + err(ex, NULL, "IP %s error: %s", s, strerror(errno)); +} + +// (port ['T] 'cnt|(cnt . cnt) ['var]) -> cnt +any doPort(any ex) { + any x, y; + int type, n, sd; + unsigned short port; + struct sockaddr_in addr; + + x = cdr(ex); + type = SOCK_STREAM; + if ((y = EVAL(car(x))) == T) + type = SOCK_DGRAM, x = cdr(x), y = EVAL(car(x)); + if ((sd = socket(AF_INET, type, 0)) < 0) + ipErr(ex, "socket"); + closeOnExec(ex, sd); + memset(&addr, 0, sizeof(addr)); + addr.sin_family = AF_INET; + addr.sin_addr.s_addr = htonl(INADDR_ANY); + if (isNum(y)) { + if ((port = (unsigned short)xCnt(ex,y)) != 0) { + n = 1; + if (setsockopt(sd, SOL_SOCKET, SO_REUSEADDR, &n, sizeof(n)) < 0) + ipErr(ex, "setsockopt"); + } + } + else if (isCell(y)) + port = (unsigned short)xCnt(ex,car(y)); + else + argError(ex,y); + for (;;) { + addr.sin_port = htons(port); + if (bind(sd, (struct sockaddr*)&addr, sizeof(addr)) >= 0) + break; + if (!isCell(y) || ++port > xCnt(ex,cdr(y))) + close(sd), ipErr(ex, "bind"); + } + if (type == SOCK_STREAM && listen(sd,5) < 0) + close(sd), ipErr(ex, "listen"); + if (!isNil(y = EVAL(cadr(x)))) { + socklen_t len = sizeof(addr); + if (getsockname(sd, (struct sockaddr*)&addr, &len) < 0) + close(sd), ipErr(ex, "getsockname"); + NeedVar(ex,y); + CheckVar(ex,y); + val(y) = boxCnt(ntohs(addr.sin_port)); + } + return boxCnt(sd); +} + +static any tcpAccept(int sd) { + int i, f, sd2; + struct sockaddr_in addr; + + f = nonblocking(sd); + i = 200; do { + socklen_t len = sizeof(addr); + if ((sd2 = accept(sd, (struct sockaddr*)&addr, &len)) >= 0) { + fcntl(sd, F_SETFL, f); + val(Adr) = mkStr(inet_ntoa(addr.sin_addr)); + initInFile(sd2,NULL), initOutFile(sd2); + return boxCnt(sd2); + } + usleep(100000); // 100 ms + } while (errno == EAGAIN && --i >= 0); + fcntl(sd, F_SETFL, f); + return NULL; +} + +// (accept 'cnt) -> cnt | NIL +any doAccept(any ex) { + return tcpAccept((int)evCnt(ex, cdr(ex))) ?: Nil; +} + +// (listen 'cnt1 ['cnt2]) -> cnt | NIL +any doListen(any ex) { + any x; + int sd; + long ms; + + sd = (int)evCnt(ex, x = cdr(ex)); + x = cdr(x); + ms = isNil(x = EVAL(car(x)))? -1 : xCnt(ex,x); + for (;;) { + if (!waitFd(ex, sd, ms)) + return Nil; + if (x = tcpAccept(sd)) + return x; + } +} + +// (host 'any) -> sym +any doHost(any x) { + struct in_addr in; + struct hostent *p; + + x = evSym(cdr(x)); + { + char nm[bufSize(x)]; + + bufString(x, nm); + if (inet_aton(nm, &in) && (p = gethostbyaddr((char*)&in, sizeof(in), AF_INET))) + return mkStr(p->h_name); + return Nil; + } +} + +static bool server(any host, unsigned short port, struct sockaddr_in *addr) { + struct hostent *p; + char nm[bufSize(host)]; + + memset(addr, 0, sizeof(struct sockaddr_in)); + addr->sin_port = htons(port); + addr->sin_family = AF_INET; + bufString(host, nm); + if (!inet_aton(nm, &addr->sin_addr)) { + if (!(p = gethostbyname(nm)) || p->h_length == 0) + return NO; + addr->sin_addr.s_addr = ((struct in_addr*)p->h_addr_list[0])->s_addr; + } + return YES; +} + +// (connect 'any 'cnt) -> cnt | NIL +any doConnect(any ex) { + int sd, port; + cell c1; + struct sockaddr_in addr; + + Push(c1, evSym(cdr(ex))); + port = evCnt(ex, cddr(ex)); + if (!server(Pop(c1), (unsigned short)port, &addr)) + return Nil; + if ((sd = socket(AF_INET, SOCK_STREAM, 0)) < 0) + ipErr(ex, "socket"); + closeOnExec(ex, sd); + if (connect(sd, (struct sockaddr*)&addr, sizeof(addr)) < 0) { + close(sd); + return Nil; + } + initInFile(sd,NULL), initOutFile(sd); + return boxCnt(sd); +} + +/*** UDP send/receive ***/ +#define UDPMAX 4096 +static byte *UdpBuf, *UdpPtr; + +static void putUdp(int c) { + if (UdpPtr == UdpBuf + UDPMAX) + err(NULL, NULL, "UDP overflow"); + *UdpPtr++ = c; +} + +static int getUdp(void) { + if (UdpPtr == UdpBuf + UDPMAX) + return -1; + return *UdpPtr++; +} + +// (udp 'any1 'cnt 'any2) -> any +// (udp 'cnt) -> any +any doUdp(any ex) { + any x; + int sd; + cell c1; + struct sockaddr_in addr; + byte buf[UDPMAX]; + + x = cdr(ex), data(c1) = EVAL(car(x)); + if (!isCell(x = cdr(x))) { + if (recv((int)xCnt(ex, data(c1)), buf, UDPMAX, 0) < 0) + return Nil; + getBin = getUdp, UdpPtr = UdpBuf = buf; + return binRead(ExtN) ?: Nil; + } + Save(c1); + if (!server(xSym(data(c1)), (unsigned short)evCnt(ex,x), &addr)) + x = Nil; + else { + x = cdr(x), x = EVAL(car(x)); + putBin = putUdp, UdpPtr = UdpBuf = buf, binPrint(ExtN, x); + if ((sd = socket(AF_INET, SOCK_DGRAM, 0)) < 0) + ipErr(ex, "socket"); + sendto(sd, buf, UdpPtr-buf, 0, (struct sockaddr*)&addr, sizeof(struct sockaddr_in)); + close(sd); + } + drop(c1); + return x; +} diff --git a/src/pico.h b/src/pico.h @@ -0,0 +1,852 @@ +/* 17mar10abu + * (c) Software Lab. Alexander Burger + */ + +#include <stdio.h> +#include <stdlib.h> +#include <stdarg.h> +#include <unistd.h> +#include <limits.h> +#include <ctype.h> +#include <string.h> +#include <math.h> +#include <errno.h> +#include <fcntl.h> +#include <dirent.h> +#include <termios.h> +#include <setjmp.h> +#include <signal.h> +#include <dlfcn.h> +#include <time.h> +#include <sys/types.h> +#include <sys/time.h> +#include <sys/times.h> +#include <sys/stat.h> +#include <sys/resource.h> +#ifndef NOWAIT +#include <sys/wait.h> // tcc doen't like it +#endif + +#ifndef __CYGWIN__ +#define MAIN main +#else +#define MAIN main2 +#endif + +#define WORD ((int)sizeof(long)) +#define BITS (8*WORD) +#define MASK ((word)-1) +#define CELLS (1024*1024/sizeof(cell)) // Heap allocation unit 1MB +#define IHASH 4999 // Internal hash table size (should be prime) +#define EHASH 49999 // External hash table size (should be prime) +#define TOP 0x10000 // Character Top + +typedef unsigned long word; +typedef unsigned char byte; +typedef unsigned char *ptr; +typedef unsigned long long word2; +typedef long long adr; + +#undef bool +typedef enum {NO,YES} bool; + +typedef struct cell { // PicoLisp primary data type + struct cell *car; + struct cell *cdr; +} cell, *any; + +typedef any (*fun)(any); + +typedef struct heap { + cell cells[CELLS]; + struct heap *next; +} heap; + +typedef struct child { + int pid; + int hear, tell; + int ofs, cnt; + byte *buf; +} child; + +typedef struct bindFrame { + struct bindFrame *link; + int i, cnt; + struct {any sym; any val;} bnd[1]; +} bindFrame; + +typedef struct methFrame { + struct methFrame *link; + any key, cls; +} methFrame; + +typedef struct inFile { + int fd, ix, cnt, next; + int line, src; + char *name; + byte buf[BUFSIZ]; +} inFile; + +typedef struct outFile { + int fd, ix; + bool tty; + byte buf[BUFSIZ]; +} outFile; + +typedef struct inFrame { + struct inFrame *link; + void (*get)(void); + pid_t pid; + int fd; +} inFrame; + +typedef struct outFrame { + struct outFrame *link; + void (*put)(int); + pid_t pid; + int fd; +} outFrame; + +typedef struct ctlFrame { + struct ctlFrame *link; + int fd; +} ctlFrame; + +typedef struct parseFrame { + any name; + word dig, eof; +} parseFrame; + +typedef struct stkEnv { + cell *stack, *arg; + bindFrame *bind; + methFrame *meth; + int next, protect, trace; + any task, *make, *yoke; + inFrame *inFrames; + outFrame *outFrames; + ctlFrame *ctlFrames; + parseFrame *parser; + void (*get)(void); + void (*put)(int); + bool brk; +} stkEnv; + +typedef struct catchFrame { + struct catchFrame *link; + any tag, fin; + stkEnv env; + jmp_buf rst; +} catchFrame; + +/*** Macros ***/ +#define Free(p) ((p)->car=Avail, Avail=(p)) +#define cellPtr(x) ((any)((word)(x) & ~(2*WORD-1))) + +/* Number access */ +#define num(x) ((word)(x)) +#define numPtr(x) ((any)(num(x)+(WORD/2))) +#define numCell(n) ((any)(num(n)-(WORD/2))) +#define box(n) (consNum(n,Nil)) +#define unDig(x) num(car(numCell(x))) +#define setDig(x,v) (car(numCell(x))=(any)(v)) +#define isNeg(x) (unDig(x) & 1) +#define pos(x) (car(numCell(x)) = (any)(unDig(x) & ~1)) +#define neg(x) (car(numCell(x)) = (any)(unDig(x) ^ 1)) +#define lo(w) num((w)&MASK) +#define hi(w) num((w)>>BITS) + +/* Symbol access */ +#define symPtr(x) ((any)&(x)->cdr) +#define val(x) ((x)->car) +#define tail(s) (((s)-1)->cdr) +#define tail1(s) ((any)(num(tail(s)) & ~1)) +#define Tail(s,v) (tail(s) = (any)(num(v) | num(tail(s)) & 1)) +#define ext(x) ((any)(num(x) | 1)) +#define mkExt(s) (*(word*)&tail(s) |= 1) + +/* Cell access */ +#define car(x) ((x)->car) +#define cdr(x) ((x)->cdr) +#define caar(x) (car(car(x))) +#define cadr(x) (car(cdr(x))) +#define cdar(x) (cdr(car(x))) +#define cddr(x) (cdr(cdr(x))) +#define caaar(x) (car(car(car(x)))) +#define caadr(x) (car(car(cdr(x)))) +#define cadar(x) (car(cdr(car(x)))) +#define caddr(x) (car(cdr(cdr(x)))) +#define cdaar(x) (cdr(car(car(x)))) +#define cdadr(x) (cdr(car(cdr(x)))) +#define cddar(x) (cdr(cdr(car(x)))) +#define cdddr(x) (cdr(cdr(cdr(x)))) +#define caaaar(x) (car(car(car(car(x))))) +#define caaadr(x) (car(car(car(cdr(x))))) +#define caadar(x) (car(car(cdr(car(x))))) +#define caaddr(x) (car(car(cdr(cdr(x))))) +#define cadaar(x) (car(cdr(car(car(x))))) +#define cadadr(x) (car(cdr(car(cdr(x))))) +#define caddar(x) (car(cdr(cdr(car(x))))) +#define cadddr(x) (car(cdr(cdr(cdr(x))))) +#define cdaaar(x) (cdr(car(car(car(x))))) +#define cdaadr(x) (cdr(car(car(cdr(x))))) +#define cdadar(x) (cdr(car(cdr(car(x))))) +#define cdaddr(x) (cdr(car(cdr(cdr(x))))) +#define cddaar(x) (cdr(cdr(car(car(x))))) +#define cddadr(x) (cdr(cdr(car(cdr(x))))) +#define cdddar(x) (cdr(cdr(cdr(car(x))))) +#define cddddr(x) (cdr(cdr(cdr(cdr(x))))) + +#define data(c) ((c).car) +#define Save(c) ((c).cdr=Env.stack, Env.stack=&(c)) +#define drop(c) (Env.stack=(c).cdr) +#define Push(c,x) (data(c)=(x), Save(c)) +#define Tuck(c1,c2,x) (data(c1)=(x), (c1).cdr=(c2).cdr, (c2).cdr=&(c1)) +#define Pop(c) (drop(c), data(c)) + +#define Bind(s,f) ((f).i=0, (f).cnt=1, (f).bnd[0].sym=(s), (f).bnd[0].val=val(s), (f).link=Env.bind, Env.bind=&(f)) +#define Unbind(f) (val((f).bnd[0].sym)=(f).bnd[0].val, Env.bind=(f).link) + +/* Predicates */ +#define isNil(x) ((x)==Nil) +#define isNum(x) (num(x)&(WORD/2)) +#define isSym(x) (num(x)&WORD) +#define isCell(x) (!(num(x)&(2*WORD-2))) +#define isExt(s) (num(tail(s))&1) +#define IsZero(n) (!unDig(n) && !isNum(cdr(numCell(n)))) + +/* Evaluation */ +#define EVAL(x) (isNum(x)? x : isSym(x)? val(x) : evList(x)) +#define evSubr(f,x) (*(fun)unDig(f))(x) + +/* Error checking */ +#define NeedNum(ex,x) if (!isNum(x)) numError(ex,x) +#define NeedCnt(ex,x) if (!isNum(x) || isNum(cdr(numCell(x)))) cntError(ex,x) +#define NeedSym(ex,x) if (!isSym(x)) symError(ex,x) +#define NeedExt(ex,x) if (!isSym(x) || !isExt(x)) extError(ex,x) +#define NeedCell(ex,x) if (!isCell(x)) cellError(ex,x) +#define NeedAtom(ex,x) if (isCell(x)) atomError(ex,x) +#define NeedLst(ex,x) if (!isCell(x) && !isNil(x)) lstError(ex,x) +#define NeedVar(ex,x) if (isNum(x)) varError(ex,x) +#define CheckNil(ex,x) if (isNil(x)) protError(ex,x) +#define CheckVar(ex,x) if ((x)>=Nil && (x)<=T) protError(ex,x) + +/* External symbol access */ +#define Fetch(ex,x) if (isExt(x)) db(ex,x,1) +#define Touch(ex,x) if (isExt(x)) db(ex,x,2) + +/* Globals */ +extern int Signal, Repl, Chr, Slot, Spkr, Mic, Hear, Tell, Children, ExtN; +extern char **AV, *AV0, *Home; +extern child *Child; +extern heap *Heaps; +extern cell *Avail; +extern stkEnv Env; +extern catchFrame *CatchPtr; +extern struct termios OrgTermio, *Termio; +extern int InFDs, OutFDs; +extern inFile *InFile, **InFiles; +extern outFile *OutFile, **OutFiles; +extern int (*getBin)(void); +extern void (*putBin)(int); +extern any TheKey, TheCls, Thrown; +extern any Alarm, Line, Zero, One, Intern[IHASH], Transient[IHASH], Extern[EHASH]; +extern any ApplyArgs, ApplyBody, DbVal, DbTail; +extern any Nil, DB, Meth, Quote, T; +extern any Solo, PPid, Pid, At, At2, At3, This, Dbg, Zap, Ext, Scl, Class; +extern any Run, Hup, Sig1, Sig2, Up, Err, Msg, Uni, Led, Tsm, Adr, Fork, Bye; + +/* Prototypes */ +void *alloc(void*,size_t); +any apply(any,any,bool,int,cell*); +void argError(any,any) __attribute__ ((noreturn)); +void atomError(any,any) __attribute__ ((noreturn)); +void begString(void); +void bigAdd(any,any); +int bigCompare(any,any); +any bigCopy(any); +void bigSub(any,any); +void binPrint(int,any); +any binRead(int); +adr blk64(any); +any boxChar(int,int*,any*); +any boxWord2(word2); +any brkLoad(any); +int bufSize(any); +void bufString(any,char*); +void bye(int) __attribute__ ((noreturn)); +void byteSym(int,int*,any*); +void cellError(any,any) __attribute__ ((noreturn)); +void charSym(int,int*,any*); +void closeInFile(int); +void closeOnExec(any,int); +void closeOutFile(int); +void cntError(any,any) __attribute__ ((noreturn)); +int compare(any,any); +any cons(any,any); +any consNum(word,any); +any consStr(any); +any consSym(any,any); +void newline(void); +void ctOpen(any,any,ctlFrame*); +void db(any,any,int); +int dbSize(any,any); +void digAdd(any,word); +void digDiv2(any); +void digMul2(any); +void digSub1(any); +any doubleToNum(double); +unsigned long ehash(any); +any endString(void); +bool eol(void); +bool equal(any,any); +void err(any,any,char*,...) __attribute__ ((noreturn)); +any evExpr(any,any); +long evCnt(any,any); +double evDouble(any,any); +any evList(any); +any evSym(any); +void execError(char*) __attribute__ ((noreturn)); +void extError(any,any) __attribute__ ((noreturn)); +any extOffs(int,any); +any findHash(any,any*); +int firstByte(any); +bool flush(outFile*); +void flushAll(void); +pid_t forkLisp(any); +any funq(any); +any get(any,any); +int getChar(void); +void getStdin(void); +void giveup(char*) __attribute__ ((noreturn)); +bool hashed(any,long,any*); +void heapAlloc(void); +any idx(any,any,int); +unsigned long ihash(any); +inFile *initInFile(int,char*); +outFile *initOutFile(int); +void initSymbols(void); +any intern(char*); +bool isBlank(any); +bool isLife(any); +void lstError(any,any) __attribute__ ((noreturn)); +any load(any,int,any); +any loadAll(any); +any method(any); +any mkChar(int); +any mkDat(int,int,int); +any mkName(char*); +any mkStr(char*); +any mkTime(int,int,int); +any name(any); +any new64(adr,any); +any newId(any,int); +int nonblocking(int); +int numBytes(any); +void numError(any,any) __attribute__ ((noreturn)); +double numToDouble(any); +any numToSym(any,int,int,int); +void outName(any); +void outNum(any); +void outString(char*); +void outWord(word); +void pack(any,int*,any*,cell*); +int pathSize(any); +void pathString(any,char*); +void pipeError(any,char*); +void popCtlFiles(void); +void popInFiles(void); +void popOutFiles(void); +void pr(int,any); +void prin(any); +void prin1(any); +void print(any); +void print1(any); +void prn(long); +void protError(any,any) __attribute__ ((noreturn)); +void pushInFiles(inFrame*); +void pushOutFiles(outFrame*); +void pushCtlFiles(ctlFrame*); +void put(any,any,any); +void putStdout(int); +void rdOpen(any,any,inFrame*); +any read1(int); +int rdBytes(int,byte*,int,bool); +int secondByte(any); +void setCooked(void); +void setRaw(void); +bool sharedLib(any); +void sighandler(any); +int slow(inFile*,bool); +void space(void); +bool subStr(any,any); +int symByte(any); +int symChar(any); +void symError(any,any) __attribute__ ((noreturn)); +any symToNum(any,int,int,int); +word2 unBoxWord2(any); +void undefined(any,any); +void unwind (catchFrame*); +void varError(any,any) __attribute__ ((noreturn)); +long waitFd(any,int,long); +bool wrBytes(int,byte*,int); +void wrOpen(any,any,outFrame*); +long xCnt(any,any); +any xSym(any); +void zapZero(any); + +any doAbs(any); +any doAccept(any); +any doAdd(any); +any doAlarm(any); +any doAll(any); +any doAnd(any); +any doAny(any); +any doAppend(any); +any doApply(any); +any doArg(any); +any doArgs(any); +any doArgv(any); +any doArrow(any); +any doAsoq(any); +any doAs(any); +any doAssoc(any); +any doAt(any); +any doAtom(any); +any doBind(any); +any doBitAnd(any); +any doBitOr(any); +any doBitQ(any); +any doBitXor(any); +any doBool(any); +any doBox(any); +any doBoxQ(any); +any doBreak(any); +any doBy(any); +any doBye(any) __attribute__ ((noreturn)); +any doCaaaar(any); +any doCaaadr(any); +any doCaaar(any); +any doCaadar(any); +any doCaaddr(any); +any doCaadr(any); +any doCaar(any); +any doCadaar(any); +any doCadadr(any); +any doCadar(any); +any doCaddar(any); +any doCadddr(any); +any doCaddr(any); +any doCadr(any); +any doCall(any); +any doCar(any); +any doCase(any); +any doCatch(any); +any doCdaaar(any); +any doCdaadr(any); +any doCdaar(any); +any doCdadar(any); +any doCdaddr(any); +any doCdadr(any); +any doCd(any); +any doCdar(any); +any doCddaar(any); +any doCddadr(any); +any doCddar(any); +any doCdddar(any); +any doCddddr(any); +any doCdddr(any); +any doCddr(any); +any doCdr(any); +any doChain(any); +any doChar(any); +any doChop(any); +any doCirc(any); +any doClip(any); +any doClose(any); +any doCmd(any); +any doCnt(any); +any doCol(any); +any doCommit(any); +any doCon(any); +any doConc(any); +any doCond(any); +any doConnect(any); +any doCons(any); +any doCopy(any); +any doCtl(any); +any doCtty(any); +any doCut(any); +any doDate(any); +any doDbck(any); +any doDe(any); +any doDec(any); +any doDef(any); +any doDefault(any); +any doDel(any); +any doDelete(any); +any doDelq(any); +any doDiff(any); +any doDir(any); +any doDiv(any); +any doDm(any); +any doDo(any); +any doE(any); +any doEcho(any); +any doEnv(any); +any doEof(any); +any doEol(any); +any doEq(any); +any doEq0(any); +any doEqT(any); +any doEqual(any); +any doEval(any); +any doExt(any); +any doExtern(any); +any doExtQ(any); +any doExtra(any); +any doExtract(any); +any doFifo(any); +any doFile(any); +any doFill(any); +any doFilter(any); +any doFin(any); +any doFinally(any); +any doFind(any); +any doFish(any); +any doFlgQ(any); +any doFlip(any); +any doFlush(any); +any doFold(any); +any doFor(any); +any doFork(any); +any doFormat(any); +any doFree(any); +any doFrom(any); +any doFull(any); +any doFunQ(any); +any doGc(any); +any doGe(any); +any doGe0(any); +any doGet(any); +any doGetd(any); +any doGetl(any); +any doGlue(any); +any doGt(any); +any doGt0(any); +any doHead(any); +any doHeap(any); +any doHear(any); +any doHide(any); +any doHost(any); +any doId(any); +any doIdx(any); +any doIf(any); +any doIf2(any); +any doIfn(any); +any doIn(any); +any doInc(any); +any doIndex(any); +any doInfo(any); +any doIntern(any); +any doIpid(any); +any doIsa(any); +any doJob(any); +any doJournal(any); +any doKey(any); +any doKill(any); +any doLast(any); +any doLe(any); +any doLength(any); +any doLet(any); +any doLetQ(any); +any doLieu(any); +any doLine(any); +any doLines(any); +any doLink(any); +any doList(any); +any doListen(any); +any doLit(any); +any doLstQ(any); +any doLoad(any); +any doLock(any); +any doLoop(any); +any doLowQ(any); +any doLowc(any); +any doLt(any); +any doLt0(any); +any doLup(any); +any doMade(any); +any doMake(any); +any doMap(any); +any doMapc(any); +any doMapcan(any); +any doMapcar(any); +any doMapcon(any); +any doMaplist(any); +any doMaps(any); +any doMark(any); +any doMatch(any); +any doMax(any); +any doMaxi(any); +any doMember(any); +any doMemq(any); +any doMeta(any); +any doMeth(any); +any doMethod(any); +any doMin(any); +any doMini(any); +any doMix(any); +any doMmeq(any); +any doMul(any); +any doMulDiv(any); +any doName(any); +any doNand(any); +any doNEq(any); +any doNEq0(any); +any doNEqT(any); +any doNEqual(any); +any doNeed(any); +any doNew(any); +any doNext(any); +any doNil(any); +any doNond(any); +any doNor(any); +any doNot(any); +any doNth(any); +any doNumQ(any); +any doOff(any); +any doOffset(any); +any doOn(any); +any doOne(any); +any doOnOff(any); +any doOpen(any); +any doOpid(any); +any doOpt(any); +any doOr(any); +any doOut(any); +any doPack(any); +any doPair(any); +any doPass(any); +any doPath(any); +any doPatQ(any); +any doPeek(any); +any doPick(any); +any doPid(any); +any doPipe(any); +any doPoll(any); +any doPool(any); +any doPop(any); +any doPort(any); +any doPr(any); +any doPreQ(any); +any doPrin(any); +any doPrinl(any); +any doPrint(any); +any doPrintln(any); +any doPrintsp(any); +any doProg(any); +any doProg1(any); +any doProg2(any); +any doProp(any); +any doPropCol(any); +any doProtect(any); +any doProve(any); +any doPush(any); +any doPush1(any); +any doPut(any); +any doPutl(any); +any doPwd(any); +any doQueue(any); +any doQuit(any); +any doQuote(any); +any doRand(any); +any doRange(any); +any doRank(any); +any doRaw(any); +any doRd(any); +any doRead(any); +any doRem(any); +any doReplace(any); +any doRest(any); +any doReverse(any); +any doRewind(any); +any doRollback(any); +any doRot(any); +any doRpc(any); +any doRun(any); +any doSect(any); +any doSeed(any); +any doSeek(any); +any doSemicol(any); +any doSend(any); +any doSeq(any); +any doSet(any); +any doSetCol(any); +any doSetq(any); +any doShift(any); +any doSize(any); +any doSkip(any); +any doSort(any); +any doSpace(any); +any doSplit(any); +any doSpQ(any); +any doState(any); +any doStem(any); +any doStr(any); +any doStrip(any); +any doStrQ(any); +any doSub(any); +any doSubQ(any); +any doSum(any); +any doSuper(any); +any doSym(any); +any doSymQ(any); +any doSync(any); +any doSys(any); +any doT(any); +any doTail(any); +any doTell(any); +any doText(any); +any doThrow(any); +any doTick(any); +any doTill(any); +any doTime(any); +any doTouch(any); +any doTrace(any); +any doTrim(any); +any doTry(any); +any doType(any); +any doUdp(any); +any doUnify(any); +any doUnless(any); +any doUntil(any); +any doUp(any); +any doUppQ(any); +any doUppc(any); +any doUse(any); +any doUsec(any); +any doVal(any); +any doWait(any); +any doWhen(any); +any doWhile(any); +any doWipe(any); +any doWith(any); +any doWr(any); +any doXchg(any); +any doXor(any); +any doYoke(any); +any doZap(any); +any doZero(any); + +static inline long unBox(any x) { + long n = unDig(x) / 2; + return unDig(x) & 1? -n : n; +} + +static inline any boxCnt(long n) {return box(n>=0? n*2 : -n*2+1);} + +/* List element access */ +static inline any nCdr(int n, any x) { + while (--n >= 0) + x = cdr(x); + return x; +} + +static inline any nth(int n, any x) { + if (--n < 0) + return Nil; + return nCdr(n,x); +} + +static inline any getn(any x, any y) { + if (isNum(x)) { + long n = unDig(x) / 2; + + if (isNeg(x)) { + while (--n) + y = cdr(y); + return cdr(y); + } + if (n == 0) + return Nil; + while (--n) + y = cdr(y); + return car(y); + } + do + if (isCell(car(y)) && x == caar(y)) + return cdar(y); + while (isCell(y = cdr(y))); + return Nil; +} + +/* List length calculation */ +static inline int length(any x) { + int n; + + for (n = 0; isCell(x); x = cdr(x)) + ++n; + return n; +} + +/* Membership */ +static inline any member(any x, any y) { + any z = y; + + while (isCell(y)) { + if (equal(x, car(y))) + return y; + if (z == (y = cdr(y))) + return NULL; + } + return isNil(y) || !equal(x,y)? NULL : y; +} + +static inline any memq(any x, any y) { + any z = y; + + while (isCell(y)) { + if (x == car(y)) + return y; + if (z == (y = cdr(y))) + return NULL; + } + return isNil(y) || x != y? NULL : y; +} + +static inline int indx(any x, any y) { + int n = 1; + any z = y; + + while (isCell(y)) { + if (equal(x, car(y))) + return n; + ++n; + if (z == (y = cdr(y))) + return 0; + } + return 0; +} + +/* List interpreter */ +static inline any prog(any x) { + any y; + + do + y = EVAL(car(x)); + while (isCell(x = cdr(x))); + return y; +} + +static inline any run(any x) { + any y; + cell at; + + Push(at,val(At)); + do + y = EVAL(car(x)); + while (isCell(x = cdr(x))); + val(At) = Pop(at); + return y; +} diff --git a/src/ssl.c b/src/ssl.c @@ -0,0 +1,241 @@ +/* 20jul09abu + * (c) Software Lab. Alexander Burger + */ + +#include <stdio.h> +#include <stdlib.h> +#include <unistd.h> +#include <fcntl.h> +#include <dirent.h> +#include <errno.h> +#include <string.h> +#include <signal.h> +#include <netdb.h> +#include <sys/stat.h> +#include <sys/socket.h> +#include <arpa/inet.h> +#include <netinet/tcp.h> +#include <netinet/in.h> + +#include <openssl/pem.h> +#include <openssl/ssl.h> +#include <openssl/err.h> + +typedef enum {NO,YES} bool; + +static char *File, *Dir, *Data; +static off_t Size; + +static char Get[] = + "GET /%s HTTP/1.0\r\n" + "User-Agent: PicoLisp\r\n" + "Host: %s:%s\r\n" + "Accept-Charset: utf-8\r\n\r\n"; + +static void errmsg(char *msg) { + fprintf(stderr, "ssl: %s\n", msg); +} + +static void giveup(char *msg) { + errmsg(msg); + exit(1); +} + +static void sslChk(int n) { + if (n < 0) { + ERR_print_errors_fp(stderr); + exit(1); + } +} + +static int sslConnect(SSL *ssl, char *host, int port) { + struct sockaddr_in addr; + struct hostent *p; + int sd; + + memset(&addr, 0, sizeof(addr)); + if ((long)(addr.sin_addr.s_addr = inet_addr(host)) == -1) { + if (!(p = gethostbyname(host)) || p->h_length == 0) + return -1; + addr.sin_addr.s_addr = ((struct in_addr*)p->h_addr_list[0])->s_addr; + } + + if ((sd = socket(AF_INET, SOCK_STREAM, 0)) < 0) { + errmsg("No socket"); + return -1; + } + addr.sin_family = AF_INET; + addr.sin_port = htons((unsigned short)port); + if (connect(sd, (struct sockaddr*)&addr, sizeof(addr)) < 0) { + close(sd); + return -1; + } + + SSL_set_fd(ssl,sd); + if (SSL_connect(ssl) >= 0) + return sd; + close(sd); + return -1; +} + +static void sslClose(SSL *ssl, int sd) { + SSL_shutdown(ssl); + close(sd); +} + +static bool sslFile(SSL *ssl, char *file) { + int fd, n; + char buf[BUFSIZ]; + + if (file[0] == '-') + return SSL_write(ssl, file+1, strlen(file)-1) >= 0; + if ((fd = open(file, O_RDONLY)) < 0) + return NO; + while ((n = read(fd, buf, sizeof(buf))) > 0) + if (SSL_write(ssl, buf, n) < 0) { + close(fd); + return NO; + } + close(fd); + return n == 0; +} + +static void doSigTerm(int n __attribute__((unused))) { + int fd1, fd2, cnt; + char buf[BUFSIZ]; + + if (Data && (fd1 = open(File, O_RDWR)) >= 0) { + if (unlink(File) < 0) + giveup("Can't unlink back"); + if ((fd2 = open(File, O_CREAT|O_WRONLY|O_TRUNC, 0666)) < 0) + giveup("Can't create back"); + if (write(fd2, Data, Size) != Size) + giveup("Can't write back"); + while ((cnt = read(fd1, buf, sizeof(buf))) > 0) + write(fd2, buf, cnt); + } + exit(0); +} + +// ssl host port url +// ssl host port url file +// ssl host port url key file +// ssl host port url key file dir sec +int main(int ac, char *av[]) { + SSL_CTX *ctx; + SSL *ssl; + bool bin; + int n, sec, getLen, lenLen, fd, sd; + DIR *dp; + struct dirent *p; + struct stat st; + struct flock fl; + char get[1024], buf[4096], nm[4096], len[64]; + + if (!(ac >= 4 && ac <= 6 || ac == 8)) + giveup("host port url [[key] file] | host port url key file dir sec"); + if (strlen(Get)+strlen(av[1])+strlen(av[2])+strlen(av[3]) >= sizeof(get)) + giveup("Names too long"); + if (strchr(av[3],'/')) + bin = NO, getLen = sprintf(get, Get, av[3], av[1], av[2]); + else + bin = YES, getLen = sprintf(get, "@%s ", av[3]); + + SSL_library_init(); + SSL_load_error_strings(); + if (!(ctx = SSL_CTX_new(SSLv23_client_method()))) { + ERR_print_errors_fp(stderr); + giveup("SSL init"); + } + ssl = SSL_new(ctx); + + if (ac <= 6) { + if (sslConnect(ssl, av[1], atoi(av[2])) < 0) { + errmsg("Can't connect"); + return 1; + } + sslChk(SSL_write(ssl, get, getLen)); + if (ac > 4) { + if (*av[4] && !sslFile(ssl,av[4])) + giveup(av[4]); + if (ac > 5 && *av[5] && !sslFile(ssl,av[5])) + giveup(av[5]); + } + while ((n = SSL_read(ssl, buf, sizeof(buf))) > 0) + write(STDOUT_FILENO, buf, n); + return 0; + } + + signal(SIGCHLD,SIG_IGN); /* Prevent zombies */ + if ((n = fork()) < 0) + giveup("detach"); + if (n) + return 0; + setsid(); + + File = av[5]; + Dir = av[6]; + sec = atoi(av[7]); + signal(SIGINT, doSigTerm); + signal(SIGTERM, doSigTerm); + signal(SIGPIPE, SIG_IGN); + for (;;) { + if (*File && (fd = open(File, O_RDWR)) >= 0) { + if (fstat(fd,&st) < 0 || st.st_size == 0) + close(fd); + else { + fl.l_type = F_WRLCK; + fl.l_whence = SEEK_SET; + fl.l_start = 0; + fl.l_len = 0; + if (fcntl(fd, F_SETLKW, &fl) < 0) + giveup("Can't lock"); + if (fstat(fd,&st) < 0 || (Size = st.st_size) == 0) + giveup("Can't access"); + lenLen = sprintf(len, "%lld\n", Size); + if ((Data = malloc(Size)) == NULL) + giveup("Can't alloc"); + if (read(fd, Data, Size) != Size) + giveup("Can't read"); + if (ftruncate(fd,0) < 0) + errmsg("Can't truncate"); + close(fd); + for (;;) { + if ((sd = sslConnect(ssl, av[1], atoi(av[2]))) >= 0) { + if (SSL_write(ssl, get, getLen) == getLen && + (!*av[4] || sslFile(ssl,av[4])) && // key + (bin || SSL_write(ssl, len, lenLen) == lenLen) && // length + SSL_write(ssl, Data, Size) == Size && // data + SSL_write(ssl, bin? "\0" : "T", 1) == 1 && // ack + SSL_read(ssl, buf, 1) == 1 && buf[0] == 'T' ) { + sslClose(ssl,sd); + break; + } + sslClose(ssl,sd); + } + sleep(sec); + } + free(Data), Data = NULL; + } + } + if (*Dir && (dp = opendir(Dir))) { + while (p = readdir(dp)) { + if (p->d_name[0] != '.') { + snprintf(nm, sizeof(nm), "%s%s", Dir, p->d_name); + if ((n = readlink(nm, buf, sizeof(buf))) > 0 && + (sd = sslConnect(ssl, av[1], atoi(av[2]))) >= 0 ) { + if (SSL_write(ssl, get, getLen) == getLen && + (!*av[4] || sslFile(ssl,av[4])) && // key + (bin || SSL_write(ssl, buf, n) == n) && // path + (bin || SSL_write(ssl, "\n", 1) == 1) && // nl + sslFile(ssl, nm) ) // file + unlink(nm); + sslClose(ssl,sd); + } + } + } + closedir(dp); + } + sleep(sec); + } +} diff --git a/src/start.c b/src/start.c @@ -0,0 +1,10 @@ +/* 03sep06abu + * (c) Software Lab. Alexander Burger + */ + +extern void main2(int ac, char *av[]) __attribute__ ((noreturn)); +int main(int ac, char *av[]) __attribute__ ((noreturn)); + +int main(int ac, char *av[]) { + main2(ac,av); +} diff --git a/src/subr.c b/src/subr.c @@ -0,0 +1,1686 @@ +/* 07nov09abu + * (c) Software Lab. Alexander Burger + */ + +#include "pico.h" + +// (car 'var) -> any +any doCar(any ex) { + any x = cdr(ex); + x = EVAL(car(x)); + NeedVar(ex,x); + return car(x); +} + +// (cdr 'lst) -> any +any doCdr(any ex) { + any x = cdr(ex); + x = EVAL(car(x)); + NeedLst(ex,x); + return cdr(x); +} + +any doCaar(any ex) { + any x = cdr(ex); + x = EVAL(car(x)); + NeedVar(ex,x); + return caar(x); +} + +any doCadr(any ex) { + any x = cdr(ex); + x = EVAL(car(x)); + NeedLst(ex,x); + return cadr(x); +} + +any doCdar(any ex) { + any x = cdr(ex); + x = EVAL(car(x)); + NeedVar(ex,x); + return cdar(x); +} + +any doCddr(any ex) { + any x = cdr(ex); + x = EVAL(car(x)); + NeedLst(ex,x); + return cddr(x); +} + +any doCaaar(any ex) { + any x = cdr(ex); + x = EVAL(car(x)); + NeedVar(ex,x); + return caaar(x); +} + +any doCaadr(any ex) { + any x = cdr(ex); + x = EVAL(car(x)); + NeedLst(ex,x); + return caadr(x); +} + +any doCadar(any ex) { + any x = cdr(ex); + x = EVAL(car(x)); + NeedVar(ex,x); + return cadar(x); +} + +any doCaddr(any ex) { + any x = cdr(ex); + x = EVAL(car(x)); + NeedLst(ex,x); + return caddr(x); +} + +any doCdaar(any ex) { + any x = cdr(ex); + x = EVAL(car(x)); + NeedVar(ex,x); + return cdaar(x); +} + +any doCdadr(any ex) { + any x = cdr(ex); + x = EVAL(car(x)); + NeedLst(ex,x); + return cdadr(x); +} + +any doCddar(any ex) { + any x = cdr(ex); + x = EVAL(car(x)); + NeedVar(ex,x); + return cddar(x); +} + +any doCdddr(any ex) { + any x = cdr(ex); + x = EVAL(car(x)); + NeedLst(ex,x); + return cdddr(x); +} + +any doCaaaar(any ex) { + any x = cdr(ex); + x = EVAL(car(x)); + NeedVar(ex,x); + return caaaar(x); +} + +any doCaaadr(any ex) { + any x = cdr(ex); + x = EVAL(car(x)); + NeedLst(ex,x); + return caaadr(x); +} + +any doCaadar(any ex) { + any x = cdr(ex); + x = EVAL(car(x)); + NeedVar(ex,x); + return caadar(x); +} + +any doCaaddr(any ex) { + any x = cdr(ex); + x = EVAL(car(x)); + NeedLst(ex,x); + return caaddr(x); +} + +any doCadaar(any ex) { + any x = cdr(ex); + x = EVAL(car(x)); + NeedVar(ex,x); + return cadaar(x); +} + +any doCadadr(any ex) { + any x = cdr(ex); + x = EVAL(car(x)); + NeedLst(ex,x); + return cadadr(x); +} + +any doCaddar(any ex) { + any x = cdr(ex); + x = EVAL(car(x)); + NeedVar(ex,x); + return caddar(x); +} + +any doCadddr(any ex) { + any x = cdr(ex); + x = EVAL(car(x)); + NeedLst(ex,x); + return cadddr(x); +} + +any doCdaaar(any ex) { + any x = cdr(ex); + x = EVAL(car(x)); + NeedVar(ex,x); + return cdaaar(x); +} + +any doCdaadr(any ex) { + any x = cdr(ex); + x = EVAL(car(x)); + NeedLst(ex,x); + return cdaadr(x); +} + +any doCdadar(any ex) { + any x = cdr(ex); + x = EVAL(car(x)); + NeedVar(ex,x); + return cdadar(x); +} + +any doCdaddr(any ex) { + any x = cdr(ex); + x = EVAL(car(x)); + NeedLst(ex,x); + return cdaddr(x); +} + +any doCddaar(any ex) { + any x = cdr(ex); + x = EVAL(car(x)); + NeedVar(ex,x); + return cddaar(x); +} + +any doCddadr(any ex) { + any x = cdr(ex); + x = EVAL(car(x)); + NeedLst(ex,x); + return cddadr(x); +} + +any doCdddar(any ex) { + any x = cdr(ex); + x = EVAL(car(x)); + NeedVar(ex,x); + return cdddar(x); +} + +any doCddddr(any ex) { + any x = cdr(ex); + x = EVAL(car(x)); + NeedLst(ex,x); + return cddddr(x); +} + +// (nth 'lst 'cnt ..) -> lst +any doNth(any ex) { + any x; + cell c1; + + x = cdr(ex), Push(c1, EVAL(car(x))), x = cdr(x); + for (;;) { + if (!isCell(data(c1))) + return Pop(c1); + data(c1) = nth((int)evCnt(ex,x), data(c1)); + if (!isCell(x = cdr(x))) + return Pop(c1); + data(c1) = car(data(c1)); + } +} + +// (con 'lst 'any) -> any +any doCon(any ex) { + any x; + cell c1; + + x = cdr(ex), Push(c1, EVAL(car(x))); + NeedCell(ex,data(c1)); + x = cdr(x), x = cdr(data(c1)) = EVAL(car(x)); + drop(c1); + return x; +} + +// (cons 'any ['any ..]) -> lst +any doCons(any x) { + any y; + cell c1; + + x = cdr(x); + Push(c1, y = cons(EVAL(car(x)),Nil)); + while (isCell(cdr(x = cdr(x)))) + y = cdr(y) = cons(EVAL(car(x)),Nil); + cdr(y) = EVAL(car(x)); + return Pop(c1); +} + +// (conc 'lst ..) -> lst +any doConc(any x) { + any y, z; + cell c1; + + x = cdr(x), Push(c1, y = EVAL(car(x))); + while (isCell(x = cdr(x))) { + z = EVAL(car(x)); + if (!isCell(y)) + y = data(c1) = z; + else { + while (isCell(cdr(y))) + y = cdr(y); + cdr(y) = z; + } + } + return Pop(c1); +} + +// (circ 'any ..) -> lst +any doCirc(any x) { + any y; + cell c1; + + x = cdr(x); + Push(c1, y = cons(EVAL(car(x)),Nil)); + while (isCell(x = cdr(x))) + y = cdr(y) = cons(EVAL(car(x)),Nil); + cdr(y) = data(c1); + return Pop(c1); +} + +// (rot 'lst ['cnt]) -> lst +any doRot(any ex) { + any x, y, z; + int n; + cell c1; + + x = cdr(ex), Push(c1, y = EVAL(car(x))); + if (isCell(y)) { + n = isCell(x = cdr(x))? (int)evCnt(ex,x) : 0; + x = car(y); + while (--n && isCell(y = cdr(y)) && y != data(c1)) + z = car(y), car(y) = x, x = z; + car(data(c1)) = x; + } + return Pop(c1); +} + +// (list 'any ['any ..]) -> lst +any doList(any x) { + any y; + cell c1; + + x = cdr(x); + Push(c1, y = cons(EVAL(car(x)),Nil)); + while (isCell(x = cdr(x))) + y = cdr(y) = cons(EVAL(car(x)),Nil); + return Pop(c1); +} + +// (need 'cnt ['lst ['any]]) -> lst +any doNeed(any ex) { + int n; + any x; + cell c1, c2; + + n = (int)evCnt(ex, x = cdr(ex)); + x = cdr(x), Push(c1, EVAL(car(x))); + Push(c2, EVAL(cadr(x))); + x = data(c1); + if (n > 0) + for (n -= length(x); n > 0; --n) + data(c1) = cons(data(c2), data(c1)); + else if (n) { + if (!isCell(x)) + data(c1) = x = cons(data(c2),Nil); + else + while (isCell(cdr(x))) + ++n, x = cdr(x); + while (++n < 0) + x = cdr(x) = cons(data(c2),Nil); + } + return Pop(c1); +} + +// (range 'num1 'num2 ['num3]) -> lst +any doRange(any ex) { + any x; + cell c1, c2, c3, c4; + + x = cdr(ex), Push(c1, EVAL(car(x))); // Start value + NeedNum(ex,data(c1)); + x = cdr(x), Push(c2, EVAL(car(x))); // End value + NeedNum(ex,data(c2)); + x = cdr(x), Push(c3, One); // Increment + if (!isNil(x = EVAL(car(x)))) { + NeedNum(ex, data(c3) = x); + if (IsZero(x) || isNeg(x)) + argError(ex,x); + } + Push(c4, x = cons(data(c1), Nil)); + if (bigCompare(data(c2), data(c1)) >= 0) { + for (;;) { + data(c1) = bigCopy(data(c1)); + if (!isNeg(data(c1))) + bigAdd(data(c1), data(c3)); + else { + bigSub(data(c1), data(c3)); + if (!IsZero(data(c1))) + neg(data(c1)); + } + if (bigCompare(data(c2), data(c1)) < 0) + break; + x = cdr(x) = cons(data(c1), Nil); + } + } + else { + for (;;) { + data(c1) = bigCopy(data(c1)); + if (!isNeg(data(c1))) + bigSub(data(c1), data(c3)); + else { + bigAdd(data(c1), data(c3)); + if (!IsZero(data(c1))) + neg(data(c1)); + } + if (bigCompare(data(c2), data(c1)) > 0) + break; + x = cdr(x) = cons(data(c1),Nil); + } + } + drop(c1); + return data(c4); +} + +// (full 'any) -> bool +any doFull(any x) { + x = cdr(x); + for (x = EVAL(car(x)); isCell(x); x = cdr(x)) + if (isNil(car(x))) + return Nil; + return T; +} + +// (make .. [(made 'lst ..)] .. [(link 'any ..)] ..) -> any +any doMake(any x) { + any *make, *yoke; + cell c1; + + Push(c1, Nil); + make = Env.make; + yoke = Env.yoke; + Env.make = Env.yoke = &data(c1); + while (isCell(x = cdr(x))) + if (isCell(car(x))) + evList(car(x)); + Env.yoke = yoke; + Env.make = make; + return Pop(c1); +} + +static void makeError(any ex) {err(ex, NULL, "Not making");} + +// (made ['lst1 ['lst2]]) -> lst +any doMade(any x) { + if (!Env.make) + makeError(x); + if (isCell(x = cdr(x))) { + *Env.yoke = EVAL(car(x)); + if (x = cdr(x), !isCell(x = EVAL(car(x)))) { + x = *Env.yoke; + while (isCell(cdr(x = cdr(x)))); + } + Env.make = &cdr(x); + } + return *Env.yoke; +} + +// (chain 'lst ..) -> lst +any doChain(any x) { + any y; + + if (!Env.make) + makeError(x); + x = cdr(x); + do + if (isCell(*Env.make = y = EVAL(car(x)))) + do + Env.make = &cdr(*Env.make); + while (isCell(*Env.make)); + while (isCell(x = cdr(x))); + return y; +} + +// (link 'any ..) -> any +any doLink(any x) { + any y; + + if (!Env.make) + makeError(x); + x = cdr(x); + do { + y = EVAL(car(x)); + Env.make = &cdr(*Env.make = cons(y, Nil)); + } while (isCell(x = cdr(x))); + return y; +} + +// (yoke 'any ..) -> any +any doYoke(any x) { + any y; + + if (!Env.make) + makeError(x); + x = cdr(x); + do { + y = EVAL(car(x)); + *Env.yoke = cons(y, *Env.yoke); + } while (isCell(x = cdr(x))); + while (isCell(*Env.make)) + Env.make = &cdr(*Env.make); + return y; +} + +// (copy 'any) -> any +any doCopy(any x) { + any y, z; + cell c1; + + x = cdr(x); + if (!isCell(x = EVAL(car(x)))) + return x; + Push(c1, y = cons(car(x), cdr(z = x))); + while (isCell(x = cdr(y))) { + if (x == z) { + cdr(y) = data(c1); + break; + } + y = cdr(y) = cons(car(x), cdr(x)); + } + return Pop(c1); +} + +// (mix 'lst cnt|'any ..) -> lst +any doMix(any x) { + any y; + cell c1, c2; + + x = cdr(x); + if (!isCell(data(c1) = EVAL(car(x))) && !isNil(data(c1))) + return data(c1); + if (!isCell(x = cdr(x))) + return Nil; + Save(c1); + Push(c2, + y = cons( + isNum(car(x))? car(nth((int)unBox(car(x)),data(c1))) : EVAL(car(x)), + Nil ) ); + while (isCell(x = cdr(x))) + y = cdr(y) = cons( + isNum(car(x))? car(nth((int)unBox(car(x)),data(c1))) : EVAL(car(x)), + Nil ); + drop(c1); + return data(c2); +} + +// (append 'lst ..) -> lst +any doAppend(any x) { + any y, z; + cell c1; + + while (isCell(cdr(x = cdr(x)))) { + if (isCell(y = EVAL(car(x)))) { + Push(c1, z = cons(car(y), cdr(y))); + while (isCell(y = cdr(z))) + z = cdr(z) = cons(car(y), cdr(y)); + while (isCell(cdr(x = cdr(x)))) { + y = EVAL(car(x)); + while (isCell(y)) { + z = cdr(z) = cons(car(y), cdr(y)); + y = cdr(z); + } + cdr(z) = y; + } + cdr(z) = EVAL(car(x)); + return Pop(c1); + } + } + return EVAL(car(x)); +} + +// (delete 'any 'lst) -> lst +any doDelete(any x) { + any y, z; + cell c1, c2, c3; + + x = cdr(x), Push(c1, y = EVAL(car(x))); + x = cdr(x); + if (!isCell(x = EVAL(car(x)))) { + drop(c1); + return x; + } + if (equal(y, car(x))) { + drop(c1); + return cdr(x); + } + Push(c2, x); + Push(c3, z = cons(car(x), Nil)); + while (isCell(x = cdr(x))) { + if (equal(y, car(x))) { + cdr(z) = cdr(x); + drop(c1); + return data(c3); + } + z = cdr(z) = cons(car(x), Nil); + } + cdr(z) = x; + drop(c1); + return data(c3); +} + +// (delq 'any 'lst) -> lst +any doDelq(any x) { + any y, z; + cell c1, c2, c3; + + x = cdr(x), Push(c1, y = EVAL(car(x))); + x = cdr(x); + if (!isCell(x = EVAL(car(x)))) { + drop(c1); + return x; + } + if (y == car(x)) { + drop(c1); + return cdr(x); + } + Push(c2, x); + Push(c3, z = cons(car(x), Nil)); + while (isCell(x = cdr(x))) { + if (y == car(x)) { + cdr(z) = cdr(x); + drop(c1); + return data(c3); + } + z = cdr(z) = cons(car(x), Nil); + } + cdr(z) = x; + drop(c1); + return data(c3); +} + +// (replace 'lst 'any1 'any2 ..) -> lst +any doReplace(any x) { + any y; + int i, n = length(cdr(x = cdr(x))) + 1 & ~1; + cell c1, c2, c[n]; + + if (!isCell(data(c1) = EVAL(car(x)))) + return data(c1); + Save(c1); + for (i = 0; i < n; ++i) + x = cdr(x), Push(c[i], EVAL(car(x))); + for (i = 0; i < n; i += 2) + if (equal(car(data(c1)), data(c[i]))) { + x = data(c[i+1]); + goto rpl1; + } + x = car(data(c1)); +rpl1: + Push(c2, y = cons(x,Nil)); + while (isCell(data(c1) = cdr(data(c1)))) { + for (i = 0; i < n; i += 2) + if (equal(car(data(c1)), data(c[i]))) { + x = data(c[i+1]); + goto rpl2; + } + x = car(data(c1)); + rpl2: + y = cdr(y) = cons(x, Nil); + } + cdr(y) = data(c1); + drop(c1); + return data(c2); +} + +// (strip 'any) -> any +any doStrip(any x) { + x = cdr(x), x = EVAL(car(x)); + while (isCell(x) && car(x) == Quote && x != cdr(x)) + x = cdr(x); + return x; +} + +// (split 'lst 'any ..) -> lst +any doSplit(any x) { + any y; + int i, n = length(cdr(x = cdr(x))); + cell c1, c[n], res, sub; + + if (!isCell(data(c1) = EVAL(car(x)))) + return data(c1); + Save(c1); + for (i = 0; i < n; ++i) + x = cdr(x), Push(c[i], EVAL(car(x))); + Push(res, x = Nil); + Push(sub, y = Nil); + do { + for (i = 0; i < n; ++i) { + if (equal(car(data(c1)), data(c[i]))) { + if (isNil(x)) + x = data(res) = cons(data(sub), Nil); + else + x = cdr(x) = cons(data(sub), Nil); + y = data(sub) = Nil; + goto spl1; + } + } + if (isNil(y)) + y = data(sub) = cons(car(data(c1)), Nil); + else + y = cdr(y) = cons(car(data(c1)), Nil); + spl1: ; + } while (isCell(data(c1) = cdr(data(c1)))); + y = cons(data(sub), Nil); + drop(c1); + if (isNil(x)) + return y; + cdr(x) = y; + return data(res); +} + +// (reverse 'lst) -> lst +any doReverse(any x) { + any y; + cell c1; + + x = cdr(x), Push(c1, x = EVAL(car(x))); + for (y = Nil; isCell(x); x = cdr(x)) + y = cons(car(x), y); + drop(c1); + return y; +} + +// (flip 'lst ['cnt])) -> lst +any doFlip(any ex) { + any x, y, z; + int n; + cell c1; + + x = cdr(ex); + if (!isCell(y = EVAL(car(x))) || !isCell(z = cdr(y))) + return y; + if (!isCell(x = cdr(x))) { + cdr(y) = Nil; + for (;;) { + x = cdr(z), cdr(z) = y; + if (!isCell(x)) + return z; + y = z, z = x; + } + } + Push(c1, y); + n = (int)evCnt(ex,x) - 1; + drop(c1); + if (n <= 0) + return y; + cdr(y) = cdr(z), cdr(z) = y; + while (--n && isCell(x = cdr(y))) + cdr(y) = cdr(x), cdr(x) = z, z = x; + return z; +} + +static any trim(any x) { + any y; + + if (!isCell(x)) + return x; + if (isNil(y = trim(cdr(x))) && isBlank(car(x))) + return Nil; + return cons(car(x),y); +} + +// (trim 'lst) -> lst +any doTrim(any x) { + cell c1; + + x = cdr(x), Push(c1, EVAL(car(x))); + x = trim(data(c1)); + drop(c1); + return x; +} + +// (clip 'lst) -> lst +any doClip(any x) { + cell c1; + + x = cdr(x), Push(c1, EVAL(car(x))); + while (isCell(data(c1)) && isBlank(car(data(c1)))) + data(c1) = cdr(data(c1)); + x = trim(data(c1)); + drop(c1); + return x; +} + +// (head 'cnt|lst 'lst) -> lst +any doHead(any ex) { + long n; + any x, y; + cell c1, c2; + + x = cdr(ex); + if (isNil(data(c1) = EVAL(car(x)))) + return Nil; + x = cdr(x); + if (isCell(data(c1))) { + Save(c1); + if (isCell(x = EVAL(car(x)))) { + for (y = data(c1); equal(car(y), car(x)); x = cdr(x)) + if (!isCell(y = cdr(y))) + return Pop(c1); + } + drop(c1); + return Nil; + } + if ((n = xCnt(ex,data(c1))) == 0) + return Nil; + if (!isCell(x = EVAL(car(x)))) + return x; + if (n < 0 && (n += length(x)) <= 0) + return Nil; + Push(c1,x); + Push(c2, x = cons(car(data(c1)), Nil)); + while (--n && isCell(data(c1) = cdr(data(c1)))) + x = cdr(x) = cons(car(data(c1)), Nil); + drop(c1); + return data(c2); +} + +// (tail 'cnt|lst 'lst) -> lst +any doTail(any ex) { + long n; + any x, y; + cell c1; + + x = cdr(ex); + if (isNil(data(c1) = EVAL(car(x)))) + return Nil; + x = cdr(x); + if (isCell(data(c1))) { + Save(c1); + if (isCell(x = EVAL(car(x)))) { + do + if (equal(x,data(c1))) + return Pop(c1); + while (isCell(x = cdr(x))); + } + drop(c1); + return Nil; + } + if ((n = xCnt(ex,data(c1))) == 0) + return Nil; + if (!isCell(x = EVAL(car(x)))) + return x; + if (n < 0) + return nth(1 - n, x); + for (y = cdr(x); --n; y = cdr(y)) + if (!isCell(y)) + return x; + while (isCell(y)) + x = cdr(x), y = cdr(y); + return x; +} + +// (stem 'lst 'any ..) -> lst +any doStem(any x) { + int i, n = length(cdr(x = cdr(x))); + cell c1, c[n]; + + Push(c1, EVAL(car(x))); + for (i = 0; i < n; ++i) + x = cdr(x), Push(c[i], EVAL(car(x))); + for (x = data(c1); isCell(x); x = cdr(x)) { + for (i = 0; i < n; ++i) + if (equal(car(x), data(c[i]))) { + data(c1) = cdr(x); + break; + } + } + return Pop(c1); +} + +// (fin 'any) -> num|sym +any doFin(any x) { + x = cdr(x), x = EVAL(car(x)); + while (isCell(x)) + x = cdr(x); + return x; +} + +// (last 'lst) -> any +any doLast(any x) { + x = cdr(x), x = EVAL(car(x)); + if (!isCell(x)) + return x; + while (isCell(cdr(x))) + x = cdr(x); + return car(x); +} + +// (== 'any ..) -> flg +any doEq(any x) { + cell c1; + + x = cdr(x), Push(c1, EVAL(car(x))); + while (isCell(x = cdr(x))) + if (data(c1) != EVAL(car(x))) { + drop(c1); + return Nil; + } + drop(c1); + return T; +} + +// (n== 'any ..) -> flg +any doNEq(any x) { + cell c1; + + x = cdr(x), Push(c1, EVAL(car(x))); + while (isCell(x = cdr(x))) + if (data(c1) != EVAL(car(x))) { + drop(c1); + return T; + } + drop(c1); + return Nil; +} + +// (= 'any ..) -> flg +any doEqual(any x) { + cell c1; + + x = cdr(x), Push(c1, EVAL(car(x))); + while (isCell(x = cdr(x))) + if (!equal(data(c1), EVAL(car(x)))) { + drop(c1); + return Nil; + } + drop(c1); + return T; +} + +// (<> 'any ..) -> flg +any doNEqual(any x) { + cell c1; + + x = cdr(x), Push(c1, EVAL(car(x))); + while (isCell(x = cdr(x))) + if (!equal(data(c1), EVAL(car(x)))) { + drop(c1); + return T; + } + drop(c1); + return Nil; +} + +// (=0 'any) -> 0 | NIL +any doEq0(any x) { + x = cdr(x); + return isNum(x = EVAL(car(x))) && IsZero(x)? x : Nil; +} + +// (=T 'any) -> flg +any doEqT(any x) { + x = cdr(x); + return T == EVAL(car(x))? T : Nil; +} + +// (n0 'any) -> flg +any doNEq0(any x) { + x = cdr(x); + return isNum(x = EVAL(car(x))) && IsZero(x)? Nil : T; +} + +// (nT 'any) -> flg +any doNEqT(any x) { + x = cdr(x); + return T == EVAL(car(x))? Nil : T; +} + +// (< 'any ..) -> flg +any doLt(any x) { + any y; + cell c1; + + x = cdr(x), Push(c1, EVAL(car(x))); + while (isCell(x = cdr(x))) { + y = EVAL(car(x)); + if (compare(data(c1), y) >= 0) { + drop(c1); + return Nil; + } + data(c1) = y; + } + drop(c1); + return T; +} + +// (<= 'any ..) -> flg +any doLe(any x) { + any y; + cell c1; + + x = cdr(x), Push(c1, EVAL(car(x))); + while (isCell(x = cdr(x))) { + y = EVAL(car(x)); + if (compare(data(c1), y) > 0) { + drop(c1); + return Nil; + } + data(c1) = y; + } + drop(c1); + return T; +} + +// (> 'any ..) -> flg +any doGt(any x) { + any y; + cell c1; + + x = cdr(x), Push(c1, EVAL(car(x))); + while (isCell(x = cdr(x))) { + y = EVAL(car(x)); + if (compare(data(c1), y) <= 0) { + drop(c1); + return Nil; + } + data(c1) = y; + } + drop(c1); + return T; +} + +// (>= 'any ..) -> flg +any doGe(any x) { + any y; + cell c1; + + x = cdr(x), Push(c1, EVAL(car(x))); + while (isCell(x = cdr(x))) { + y = EVAL(car(x)); + if (compare(data(c1), y) < 0) { + drop(c1); + return Nil; + } + data(c1) = y; + } + drop(c1); + return T; +} + +// (max 'any ..) -> any +any doMax(any x) { + any y; + cell c1; + + x = cdr(x), Push(c1, EVAL(car(x))); + while (isCell(x = cdr(x))) { + y = EVAL(car(x)); + if (compare(y, data(c1)) > 0) + data(c1) = y; + } + return Pop(c1); +} + +// (min 'any ..) -> any +any doMin(any x) { + any y; + cell c1; + + x = cdr(x), Push(c1, EVAL(car(x))); + while (isCell(x = cdr(x))) { + y = EVAL(car(x)); + if (compare(y, data(c1)) < 0) + data(c1) = y; + } + return Pop(c1); +} + +// (atom 'any) -> flg +any doAtom(any x) { + x = cdr(x); + return !isCell(EVAL(car(x)))? T : Nil; +} + +// (pair 'any) -> any +any doPair(any x) { + x = cdr(x); + return isCell(x = EVAL(car(x)))? x : Nil; +} + +// (lst? 'any) -> flg +any doLstQ(any x) { + x = cdr(x); + return isCell(x = EVAL(car(x))) || isNil(x)? T : Nil; +} + +// (num? 'any) -> num | NIL +any doNumQ(any x) { + x = cdr(x); + return isNum(x = EVAL(car(x)))? x : Nil; +} + +// (sym? 'any) -> flg +any doSymQ(any x) { + x = cdr(x); + return isSym(EVAL(car(x)))? T : Nil; +} + +// (flg? 'any) -> flg +any doFlgQ(any x) { + x = cdr(x); + return isNil(x = EVAL(car(x))) || x==T? T : Nil; +} + +// (member 'any 'lst) -> any +any doMember(any x) { + cell c1; + + x = cdr(x), Push(c1, EVAL(car(x))); + x = cdr(x), x = EVAL(car(x)); + return member(Pop(c1), x) ?: Nil; +} + +// (memq 'any 'lst) -> any +any doMemq(any x) { + cell c1; + + x = cdr(x), Push(c1, EVAL(car(x))); + x = cdr(x), x = EVAL(car(x)); + return memq(Pop(c1), x) ?: Nil; +} + +// (mmeq 'lst 'lst) -> any +any doMmeq(any x) { + any y, z; + cell c1; + + x = cdr(x), Push(c1, EVAL(car(x))); + x = cdr(x), y = EVAL(car(x)); + for (x = Pop(c1); isCell(x); x = cdr(x)) + if (z = memq(car(x), y)) + return z; + return Nil; +} + +// (sect 'lst 'lst) -> lst +any doSect(any x) { + cell c1, c2, c3; + + x = cdr(x), Push(c1, EVAL(car(x))); + x = cdr(x), Push(c2, EVAL(car(x))); + Push(c3, x = Nil); + while (isCell(data(c1))) { + if (member(car(data(c1)), data(c2))) + if (isNil(x)) + x = data(c3) = cons(car(data(c1)), Nil); + else + x = cdr(x) = cons(car(data(c1)), Nil); + data(c1) = cdr(data(c1)); + } + drop(c1); + return data(c3); +} + +// (diff 'lst 'lst) -> lst +any doDiff(any x) { + cell c1, c2, c3; + + x = cdr(x), Push(c1, EVAL(car(x))); + x = cdr(x), Push(c2, EVAL(car(x))); + Push(c3, x = Nil); + while (isCell(data(c1))) { + if (!member(car(data(c1)), data(c2))) + if (isNil(x)) + x = data(c3) = cons(car(data(c1)), Nil); + else + x = cdr(x) = cons(car(data(c1)), Nil); + data(c1) = cdr(data(c1)); + } + drop(c1); + return data(c3); +} + +// (index 'any 'lst) -> cnt | NIL +any doIndex(any x) { + int n; + cell c1; + + x = cdr(x), Push(c1, EVAL(car(x))); + x = cdr(x), x = EVAL(car(x)); + if (n = indx(Pop(c1), x)) + return boxCnt(n); + return Nil; +} + +// (offset 'lst1 'lst2) -> cnt | NIL +any doOffset(any x) { + int n; + any y; + cell c1; + + x = cdr(x), Push(c1, EVAL(car(x))); + x = cdr(x), y = EVAL(car(x)); + for (n = 1, x = Pop(c1); isCell(y); ++n, y = cdr(y)) + if (equal(x,y)) + return boxCnt(n); + return Nil; +} + +// (length 'any) -> cnt | T +any doLength(any x) { + int n, c; + any y; + + if (isNum(x = EVAL(cadr(x)))) + return numToSym(x, 0, -1, 0); + if (isSym(x)) { + for (n = 0, c = symChar(name(x)); c; ++n, c = symChar(NULL)); + return boxCnt(n); + } + n = 1; + while (car(x) == Quote) { + if (x == cdr(x)) + return T; + if (!isCell(x = cdr(x))) + return boxCnt(n); + ++n; + } + y = x; + while (isCell(x = cdr(x))) { + if (x == y) + return T; + ++n; + } + return boxCnt(n); +} + +static int size(any x) { + int n; + any y; + + n = 1; + while (car(x) == Quote) { + if (x == cdr(x) || !isCell(x = cdr(x))) + return n; + ++n; + } + for (y = x;;) { + if (isCell(car(x))) + n += size(car(x)); + if (!isCell(x = cdr(x)) || x == y) + break; + ++n; + } + return n; +} + +// (size 'any) -> cnt +any doSize(any ex) { + any x = cdr(ex); + + if (isNum(x = EVAL(car(x)))) + return boxCnt(numBytes(x)); + if (!isSym(x)) + return boxCnt(size(x)); + if (isExt(x)) + return boxCnt(dbSize(ex,x)); + return isNum(x = name(x))? boxCnt(numBytes(x)) : Zero; +} + +// (assoc 'any 'lst) -> lst +any doAssoc(any x) { + any y; + cell c1; + + x = cdr(x), Push(c1, EVAL(car(x))); + x = cdr(x), y = EVAL(car(x)); + for (x = Pop(c1); isCell(y); y = cdr(y)) + if (isCell(car(y)) && equal(x,caar(y))) + return car(y); + return Nil; +} + +// (asoq 'any 'lst) -> lst +any doAsoq(any x) { + any y; + cell c1; + + x = cdr(x), Push(c1, EVAL(car(x))); + x = cdr(x), y = EVAL(car(x)); + for (x = Pop(c1); isCell(y); y = cdr(y)) + if (isCell(car(y)) && x == caar(y)) + return car(y); + return Nil; +} + +static any Rank; + +any rank1(any lst, int n) { + int i; + + if (isCell(car(lst)) && compare(caar(lst), Rank) > 0) + return NULL; + if (n == 1) + return car(lst); + i = n / 2; + return rank1(nCdr(i,lst), n-i) ?: rank1(lst, i); +} + +any rank2(any lst, int n) { + int i; + + if (isCell(car(lst)) && compare(Rank, caar(lst)) > 0) + return NULL; + if (n == 1) + return car(lst); + i = n / 2; + return rank2(nCdr(i,lst), n-i) ?: rank2(lst, i); +} + +// (rank 'any 'lst ['flg]) -> lst +any doRank(any x) { + any y; + cell c1, c2; + + x = cdr(x), Push(c1, EVAL(car(x))); + x = cdr(x), Push(c2, y = EVAL(car(x))); + x = cdr(x), x = EVAL(car(x)); + Rank = Pop(c1); + if (!isCell(y)) + return Nil; + if (isNil(x)) + return rank1(y, length(y)) ?: Nil; + return rank2(y, length(y)) ?: Nil; +} + +/* Pattern matching */ +bool match(any p, any d) { + any x; + + for (;;) { + if (!isCell(p)) { + if (isSym(p) && firstByte(p) == '@') { + val(p) = d; + return YES; + } + return equal(p,d); + } + if (isSym(x = car(p)) && firstByte(x) == '@') { + if (!isCell(d)) { + if (equal(d, cdr(p))) { + val(x) = Nil; + return YES; + } + return NO; + } + if (match(cdr(p), cdr(d))) { + val(x) = cons(car(d), Nil); + return YES; + } + if (match(cdr(p), d)) { + val(x) = Nil; + return YES; + } + if (match(p, cdr(d))) { + val(x) = cons(car(d), val(x)); + return YES; + } + } + if (!isCell(d) || !(match(x, car(d)))) + return NO; + p = cdr(p); + d = cdr(d); + } +} + +// (match 'lst1 'lst2) -> flg +any doMatch(any x) { + cell c1, c2; + + x = cdr(x), Push(c1, EVAL(car(x))); + x = cdr(x), Push(c2, EVAL(car(x))); + x = match(data(c1), data(c2))? T : Nil; + drop(c1); + return x; +} + +// Fill template structure +static any fill(any x, any s) { + any y; + cell c1; + + if (isNum(x)) + return NULL; + if (isSym(x)) + return + (isNil(s)? x!=At && firstByte(x)=='@' : memq(x,s)!=NULL)? + val(x) : NULL; + if (y = fill(car(x),s)) { + Push(c1,y); + y = fill(cdr(x),s); + return cons(Pop(c1), y ?: cdr(x)); + } + if (y = fill(cdr(x),s)) + return cons(car(x), y); + return NULL; +} + +// (fill 'any ['sym|lst]) -> any +any doFill(any x) { + cell c1, c2; + + x = cdr(x), Push(c1, EVAL(car(x))); + x = cdr(x), Push(c2, EVAL(car(x))); + if (x = fill(data(c1),data(c2))) { + drop(c1); + return x; + } + return Pop(c1); +} + +/* Declarative Programming */ +cell *Penv, *Pnl; + +static bool unify(any n1, any x1, any n2, any x2) { + any x, env; + + lookup1: + if (isSym(x1) && firstByte(x1) == '@') + for (x = data(*Penv); isCell(car(x)); x = cdr(x)) + if (unDig(n1) == unDig(caaar(x)) && x1 == cdaar(x)) { + n1 = cadar(x); + x1 = cddar(x); + goto lookup1; + } + lookup2: + if (isSym(x2) && firstByte(x2) == '@') + for (x = data(*Penv); isCell(car(x)); x = cdr(x)) + if (unDig(n2) == unDig(caaar(x)) && x2 == cdaar(x)) { + n2 = cadar(x); + x2 = cddar(x); + goto lookup2; + } + if (unDig(n1) == unDig(n2) && equal(x1, x2)) + return YES; + if (isSym(x1) && firstByte(x1) == '@') { + if (x1 != At) { + data(*Penv) = cons(cons(cons(n1,x1), Nil), data(*Penv)); + cdar(data(*Penv)) = cons(n2,x2); + } + return YES; + } + if (isSym(x2) && firstByte(x2) == '@') { + if (x2 != At) { + data(*Penv) = cons(cons(cons(n2,x2), Nil), data(*Penv)); + cdar(data(*Penv)) = cons(n1,x1); + } + return YES; + } + if (!isCell(x1) || !isCell(x2)) + return equal(x1, x2); + env = data(*Penv); + if (unify(n1, car(x1), n2, car(x2)) && unify(n1, cdr(x1), n2, cdr(x2))) + return YES; + data(*Penv) = env; + return NO; +} + +static any lup(any n, any x) { + any y; + cell c1; + + lup: + if (isSym(x) && firstByte(x) == '@') + for (y = data(*Penv); isCell(car(y)); y = cdr(y)) + if (unDig(n) == unDig(caaar(y)) && x == cdaar(y)) { + n = cadar(y); + x = cddar(y); + goto lup; + } + if (!isCell(x)) + return x; + Push(c1, lup(n, car(x))); + x = lup(n, cdr(x)); + return cons(Pop(c1), x); +} + +static any lookup(any n, any x) { + return isSym(x = lup(n,x)) && firstByte(x)=='@'? Nil : x; +} + +static any uniFill(any x) { + cell c1; + + if (isNum(x)) + return x; + if (isSym(x)) + return lup(car(data(*Pnl)), x); + Push(c1, uniFill(car(x))); + x = uniFill(cdr(x)); + return cons(Pop(c1), x); +} + +// (prove 'lst ['lst]) -> lst +any doProve(any x) { + int i; + cell *envSave, *nlSave, at, q, dbg, env, n, nl, alt, tp1, tp2, e; + + x = cdr(x); + if (!isCell(data(q) = EVAL(car(x)))) + return Nil; + Save(q); + Push(at,val(At)); + envSave = Penv, Penv = &env, nlSave = Pnl, Pnl = &nl; + if (x = cdr(x), isNil(x = EVAL(car(x)))) + data(dbg) = NULL; + else + Push(dbg, x); + Push(env, caar(data(q))), car(data(q)) = cdar(data(q)); + Push(n, car(data(env))), data(env) = cdr(data(env)); + Push(nl, car(data(env))), data(env) = cdr(data(env)); + Push(alt, car(data(env))), data(env) = cdr(data(env)); + Push(tp1, car(data(env))), data(env) = cdr(data(env)); + Push(tp2, car(data(env))), data(env) = cdr(data(env)); + Push(e,Nil); + while (isCell(data(tp1)) || isCell(data(tp2))) { + if (isCell(data(alt))) { + data(e) = data(env); + if (!unify(car(data(nl)), cdar(data(tp1)), data(n), caar(data(alt)))) { + if (!isCell(data(alt) = cdr(data(alt)))) { + data(env) = caar(data(q)), car(data(q)) = cdar(data(q)); + data(n) = car(data(env)), data(env) = cdr(data(env)); + data(nl) = car(data(env)), data(env) = cdr(data(env)); + data(alt) = car(data(env)), data(env) = cdr(data(env)); + data(tp1) = car(data(env)), data(env) = cdr(data(env)); + data(tp2) = car(data(env)), data(env) = cdr(data(env)); + } + } + else { + if (data(dbg) && memq(caar(data(tp1)), data(dbg))) { + outWord(indx(car(data(alt)), get(caar(data(tp1)), T))); + space(); + print(uniFill(car(data(tp1)))), newline(); + } + if (isCell(cdr(data(alt)))) + car(data(q)) = + cons( + cons(data(n), + cons(data(nl), + cons(cdr(data(alt)), + cons(data(tp1), cons(data(tp2),data(e))) ) ) ), + car(data(q)) ); + data(nl) = cons(data(n), data(nl)); + data(n) = box(2 + unDig(data(n))); + data(tp2) = cons(cdr(data(tp1)), data(tp2)); + data(tp1) = cdar(data(alt)); + data(alt) = Nil; + } + } + else if (!isCell(x = data(tp1))) { + data(tp1) = car(data(tp2)), data(tp2) = cdr(data(tp2)); + data(nl) = cdr(data(nl)); + } + else if (car(x) == T) { + while (isCell(car(data(q))) && + unDig(caaar(data(q))) >= unDig(car(data(nl))) ) + car(data(q)) = cdar(data(q)); + data(tp1) = cdr(x); + } + else if (isNum(caar(x))) { + data(e) = EVAL(cdar(x)); + for (i = unDig(caar(x)), x = data(nl); (i -= 2) > 0;) + x = cdr(x); + data(nl) = cons(car(x), data(nl)); + data(tp2) = cons(cdr(data(tp1)), data(tp2)); + data(tp1) = data(e); + } + else if (isSym(caar(x)) && firstByte(caar(x)) == '@') { + if (!isNil(data(e) = EVAL(cdar(x))) && + unify(car(data(nl)), caar(x), car(data(nl)), data(e)) ) + data(tp1) = cdr(x); + else { + data(env) = caar(data(q)), car(data(q)) = cdar(data(q)); + data(n) = car(data(env)), data(env) = cdr(data(env)); + data(nl) = car(data(env)), data(env) = cdr(data(env)); + data(alt) = car(data(env)), data(env) = cdr(data(env)); + data(tp1) = car(data(env)), data(env) = cdr(data(env)); + data(tp2) = car(data(env)), data(env) = cdr(data(env)); + } + } + else if (!isCell(data(alt) = get(caar(x), T))) { + data(env) = caar(data(q)), car(data(q)) = cdar(data(q)); + data(n) = car(data(env)), data(env) = cdr(data(env)); + data(nl) = car(data(env)), data(env) = cdr(data(env)); + data(alt) = car(data(env)), data(env) = cdr(data(env)); + data(tp1) = car(data(env)), data(env) = cdr(data(env)); + data(tp2) = car(data(env)), data(env) = cdr(data(env)); + } + } + for (data(e) = Nil, x = data(env); isCell(cdr(x)); x = cdr(x)) + if (!unDig(caaar(x))) + data(e) = cons(cons(cdaar(x), lookup(Zero, cdaar(x))), data(e)); + val(At) = data(at); + drop(q); + Penv = envSave, Pnl = nlSave; + return isCell(data(e))? data(e) : isCell(data(env))? T : Nil; +} + +// (-> sym [num]) -> any +any doArrow(any x) { + int i; + any y; + + if (!isNum(caddr(x))) + return lookup(car(data(*Pnl)), cadr(x)); + for (i = unDig(caddr(x)), y = data(*Pnl); (i -= 2) > 0;) + y = cdr(y); + return lookup(car(y), cadr(x)); +} + +// (unify 'any) -> lst +any doUnify(any x) { + cell c1; + + Push(c1, EVAL(cadr(x))); + if (unify(cadr(data(*Pnl)), data(c1), car(data(*Pnl)), data(c1))) { + drop(c1); + return data(*Penv); + } + drop(c1); + return Nil; +} + +/* List Merge Sort: Bill McDaniel, DDJ Jun99 */ +static bool cmp(any ex, any foo, cell c[2]) { + if (isNil(foo)) + return compare(car(data(c[0])), car(data(c[1]))) < 0; + return !isNil(apply(ex, foo, YES, 2, c)); +} + +// (sort 'lst ['fun]) -> lst +any doSort(any ex) { + int i; + any x; + cell p, foo, in[2], out[2], last[2]; + any *tail[2]; + + x = cdr(ex); + if (!isCell(data(out[0]) = EVAL(car(x)))) + return data(out[0]); + Save(out[0]); + x = cdr(x), Push(foo, EVAL(car(x))); + Push(out[1], Nil); + Save(in[0]); + Save(in[1]); + Push(p, Nil); + Push(last[1], Nil); + do { + data(in[0]) = data(out[0]); + data(in[1]) = data(out[1]); + + i = isCell(data(in[1])) && !cmp(ex, data(foo), in); + if (isCell(data(p) = data(in[i]))) + data(in[i]) = cdr(data(in[i])); + data(out[0]) = data(p); + tail[0] = &cdr(data(p)); + data(last[1]) = data(out[0]); + cdr(data(p)) = Nil; + i = 0; + data(out[1]) = Nil; + tail[1] = &data(out[1]); + while (isCell(data(in[0])) || isCell(data(in[1]))) { + if (!isCell(data(in[1]))) { + if (isCell(data(p) = data(in[0]))) + data(in[0]) = cdr(data(in[0])); + data(last[0]) = data(p); + if (cmp(ex, data(foo), last)) + i = 1 - i; + } + else if (!isCell(data(in[0]))) { + data(last[0]) = data(p) = data(in[1]), data(in[1]) = cdr(data(in[1])); + if (cmp(ex, data(foo), last)) + i = 1 - i; + } + else if (data(last[0]) = data(in[0]), cmp(ex, data(foo), last)) { + data(last[0]) = data(in[1]); + if (!cmp(ex, data(foo), last)) + data(p) = data(in[1]), data(in[1]) = cdr(data(in[1])); + else { + if (cmp(ex, data(foo), in)) + data(p) = data(in[0]), data(in[0]) = cdr(data(in[0])); + else + data(p) = data(in[1]), data(in[1]) = cdr(data(in[1])); + i = 1 - i; + } + } + else { + data(last[0]) = data(in[1]); + if (cmp(ex, data(foo), last)) + data(p) = data(in[0]), data(in[0]) = cdr(data(in[0])); + else { + if (cmp(ex, data(foo), in)) + data(p) = data(in[0]), data(in[0]) = cdr(data(in[0])); + else + data(p) = data(in[1]), data(in[1]) = cdr(data(in[1])); + } + } + *tail[i] = data(p); + tail[i] = &cdr(data(p)); + cdr(data(p)) = Nil; + data(last[1]) = data(p); + } + } while (isCell(data(out[1]))); + return Pop(out[0]); +} diff --git a/src/sym.c b/src/sym.c @@ -0,0 +1,1991 @@ +/* 24jun09abu + * (c) Software Lab. Alexander Burger + */ + +#include "pico.h" + +/* Internal/transient hash */ +unsigned long ihash(any x) { + unsigned long g, h; + word n; + + for (h = 0; isNum(x); x = cdr(numCell(x))) + for (n = unDig(x); n; n >>= 8) + g = (h = (h<<4) + (n&0xFF)) & 0xF0000000, h = (h ^ g>>24) & ~g; + return h % IHASH; +} + +/* External hash */ +unsigned long ehash(any x) { + unsigned long h; + word n; + + for (h = 0; isNum(x); x = cdr(numCell(x))) + for (n = unDig(x); n; n >>= 11) + h += n; + return h % EHASH; +} + +bool hashed(any s, long h, any *tab) { + any x; + + for (x = tab[h]; isCell(x); x = cdr(x)) + if (s == car(x)) + return YES; + return NO; +} + +any findHash(any s, any *p) { + any x, y, *q, h; + + if (isCell(h = *p)) { + x = s, y = name(car(h)); + while (unDig(x) == unDig(y)) { + x = cdr(numCell(x)); + y = cdr(numCell(y)); + if (!isNum(x) && !isNum(y)) + return car(h); + } + while (isCell(h = *(q = &cdr(h)))) { + x = s, y = name(car(h)); + while (unDig(x) == unDig(y)) { + x = cdr(numCell(x)); + y = cdr(numCell(y)); + if (!isNum(x) && !isNum(y)) { + *q = cdr(h), cdr(h) = *p, *p = h; + return car(h); + } + } + } + } + return NULL; +} + +/* Get symbol name */ +any name(any s) { + for (s = tail1(s); isCell(s); s = cdr(s)); + return s; +} + +// (name 'sym ['sym2]) -> sym +any doName(any ex) { + any x, y, *p; + cell c1; + + x = cdr(ex), data(c1) = EVAL(car(x)); + NeedSym(ex,data(c1)); + y = name(data(c1)); + if (!isCell(x = cdr(x))) + return isNum(y)? consStr(y) : Nil; + if (isNil(data(c1)) || isExt(data(c1)) || hashed(data(c1), ihash(y), Intern)) + err(ex, data(c1), "Can't rename"); + Save(c1); + x = EVAL(car(x)); + NeedSym(ex,x); + for (p = &tail(data(c1)); isCell(*p); p = &cdr(*p)); + *p = name(x); + return Pop(c1); +} + +/* Find or create single-char symbol */ +any mkChar(int c) { + if (c >= 0x80) { + if (c < 0x800) + c = 0xC0 | c>>6 & 0x1F | (0x80 | c & 0x3F) << 8; + else if (c == TOP) + c = 0xFF; + else + c = 0xE0 | c>>12 & 0x0F | (0x80 | c>>6 & 0x3F) << 8 | (0x80 | c & 0x3F) << 16; + } + return consStr(box(c)); +} + +/* Make name */ +any mkName(char *s) { + int i; + any nm; + cell c1; + + i = 0, Push(c1, nm = box(*(byte*)s++)); + while (*s) + byteSym(*(byte*)s++, &i, &nm); + return Pop(c1); +} + +any intern(char *s) { + any nm, x, *h; + + if (!*s) + return Nil; + nm = mkName(s); + if (x = findHash(nm, h = Intern + ihash(nm))) + return x; + *h = cons(x = consStr(nm), *h); + return x; +} + +/* Make string */ +any mkStr(char *s) {return s && *s? consStr(mkName(s)) : Nil;} + +/* Get first byte of symbol name */ +int firstByte(any s) { + return !isNum(s = name(s))? 0 : unDig(s) & 0xFF; +} + +int secondByte(any s) { + return !isNum(s = name(s))? 0 : unDig(s) >> 8 & 0xFF; +} + +bool isBlank(any x) { + int c; + + if (!isSym(x)) + return NO; + for (c = symChar(name(x)); c; c = symChar(NULL)) + if (c > ' ') + return NO; + return YES; +} + +// (sp? 'any) -> flg +any doSpQ(any x) { + x = cdr(x); + return isBlank(EVAL(car(x)))? T : Nil; +} + +// (pat? 'any) -> sym | NIL +any doPatQ(any x) { + x = cdr(x); + return isSym(x = EVAL(car(x))) && firstByte(x) == '@'? x : Nil; +} + +// (fun? 'any) -> any +any doFunQ(any x) { + x = cdr(x); + return funq(EVAL(car(x))); +} + +// (getd 'any) -> fun | NIL +any doGetd(any x) { + x = cdr(x); + if (!isSym(x = EVAL(car(x)))) + return Nil; + return !isNil(funq(val(x))) || isNil(val(x)) && sharedLib(x)? + val(x) : Nil; +} + +// (all ['T | '0]) -> lst +any doAll(any x) { + any *p; + int mod, i; + cell c1; + + x = cdr(x), x = EVAL(car(x)); + if isNil(x) + p = Intern, mod = IHASH; + else if (x == T) + p = Transient, mod = IHASH; + else + p = Extern, mod = EHASH; + Push(c1, Nil); + for (i = 0; i < mod; ++i) + for (x = p[i]; isCell(x); x = cdr(x)) + data(c1) = cons(car(x), data(c1)); + return Pop(c1); +} + +// (intern 'sym) -> sym +any doIntern(any ex) { + any x, y, z, *h; + + x = cdr(ex), x = EVAL(car(x)); + NeedSym(ex,x); + if (!isNum(y = name(x))) + return Nil; + if (unDig(y) == ('L'<<16 | 'I'<<8 | 'N')) + return Nil; + if (z = findHash(y, h = Intern + ihash(y))) + return z; + *h = cons(x,*h); + return x; +} + +// (extern 'sym) -> sym | NIL +any doExtern(any ex) { + int c, i; + any x, y, *h, nm; + cell c1, c2; + + x = cdr(ex), x = EVAL(car(x)); + NeedSym(ex,x); + if (!isNum(x = name(x))) + return Nil; + if (!(y = findHash(x, Extern + ehash(x)))) { + Push(c1, x); + if ((c = symChar(x)) == '{') + c = symChar(NULL); + Push(c2, boxChar(c, &i, &nm)); + while ((c = symChar(NULL)) && c != '}') + charSym(c, &i, &nm); + if (!(y = findHash(data(c2), h = Extern + ehash(data(c2))))) { + mkExt(y = consSym(Nil,data(c2))); + *h = cons(y,*h); + } + drop(c1); + } + return isLife(y)? y : Nil; +} + +// (==== ['sym ..]) -> NIL +any doHide(any ex) { + any x, y, z, *h; + int i; + + for (i = 0; i < IHASH; ++i) + Transient[i] = Nil; + for (x = cdr(ex); isCell(x); x = cdr(x)) { + y = EVAL(car(x)); + NeedSym(ex,y); + if (isNum(z = name(y)) && !findHash(z, h = Transient + ihash(z))) + *h = cons(y,*h); + } + return Nil; +} + +// (box? 'any) -> sym | NIL +any doBoxQ(any x) { + x = cdr(x); + return isSym(x = EVAL(car(x))) && !isNum(name(x))? x : Nil; +} + +// (str? 'any) -> sym | NIL +any doStrQ(any x) { + x = cdr(x); + return isSym(x = EVAL(car(x))) && + !isExt(x) && !hashed(x, ihash(name(x)), Intern)? x : Nil; +} + +// (ext? 'any) -> sym | NIL +any doExtQ(any x) { + x = cdr(x); + return isSym(x = EVAL(car(x))) && isExt(x) && isLife(x) ? x : Nil; +} + +// (touch 'sym) -> sym +any doTouch(any ex) { + any x = cdr(ex); + x = EVAL(car(x)); + NeedSym(ex,x); + Touch(ex,x); + return x; +} + +// (zap 'sym) -> sym +any doZap(any ex) { + any x, y, *h; + + x = cdr(ex), x = EVAL(car(x)); + NeedSym(ex,x); + if (isExt(x)) + db(ex,x,3); + else { + if (x >= Nil && x <= Bye) + protError(ex,x); + for (h = Intern + ihash(name(x)); isCell(y = *h); h = &y->cdr) + if (x == car(y)) { + *h = cdr(y); + break; + } + } + return x; +} + +// (chop 'any) -> lst +any doChop(any x) { + int c; + cell c1, c2; + + if (isCell(x = EVAL(cadr(x)))) + return x; + if (!(c = symChar(name(x = xSym(x))))) + return Nil; + Push(c1, x); + Push(c2, x = cons(mkChar(c), Nil)); + while (c = symChar(NULL)) + x = cdr(x) = cons(mkChar(c), Nil); + drop(c1); + return data(c2); +} + +void pack(any x, int *i, any *nm, cell *p) { + int c; + cell c1; + + if (isCell(x)) + do + pack(car(x), i, nm, p); + while (isCell(x = cdr(x))); + if (!isNil(x)) { + if (isNum(x)) { + Push(c1, x = numToSym(x, 0, 0, 0)); + c = symChar(name(x)); + if (*nm) + charSym(c, i, nm); + else + Tuck(*p, c1, boxChar(c, i, nm)); + while (c = symChar(NULL)) + charSym(c, i, nm); + drop(c1); + } + else if (c = symChar(name(x))) { + if (*nm) { + if (isExt(x)) + charSym('{', i, nm); + charSym(c, i, nm); + } + else if (!isExt(x)) + Push(*p, boxChar(c, i, nm)); + else { + Push(*p, boxChar('{', i, nm)); + charSym(c, i, nm); + } + while (c = symChar(NULL)) + charSym(c, i, nm); + if (isExt(x)) + charSym('}', i, nm); + } + } +} + +// (pack 'any ..) -> sym +any doPack(any x) { + int i; + any nm; + cell c1, c2; + + x = cdr(x), Push(c1, EVAL(car(x))); + nm = NULL, pack(data(c1), &i, &nm, &c2); + while (isCell(x = cdr(x))) + pack(data(c1) = EVAL(car(x)), &i, &nm, &c2); + drop(c1); + return nm? consStr(data(c2)) : Nil; +} + +// (glue 'any 'lst) -> sym +any doGlue(any x) { + int i; + any nm; + cell c1, c2, c3; + + x = cdr(x), Push(c1, EVAL(car(x))); + x = cdr(x), Push(c2, x = EVAL(car(x))); + if (!isCell(x)) { + drop(c1); + return x; + } + nm = NULL, pack(car(x), &i, &nm, &c3); + while (isCell(x = cdr(x))) { + pack(data(c1), &i, &nm, &c3); + pack(car(x), &i, &nm, &c3); + } + drop(c1); + return nm? consStr(data(c3)) : Nil; +} + +// (text 'any1 'any ..) -> sym +any doText(any x) { + int c, n, i; + any nm; + any y = evSym(x = cdr(x)); + char *p, buf[bufSize(y)]; + cell c1; + + bufString(y, buf); + if (!*(p = buf)) + return Nil; + { + cell arg[length(x = cdr(x))]; + + for (n = 0; isCell(x); ++n, x = cdr(x)) + Push(arg[n], EVAL(car(x))); + + nm = NULL; + do { + if ((c = *p++) != '@') { + if (nm) + byteSym(c, &i, &nm); + else + i = 0, Push(c1, nm = box(c & 0xFF)); + } + else if (!(c = *p++)) + break; + else if (c == '@') { + if (nm) + byteSym('@', &i, &nm); + else + i = 0, Push(c1, nm = box('@')); + } + else if (c >= '1') { + if ((c -= '1') > 8) + c -= 7; + if (n > c) + pack(data(arg[c]), &i, &nm, &c1); + } + } while (*p); + if (n) + drop(arg[0]); + else if (nm) + drop(c1); + return nm? consStr(data(c1)) : Nil; + } +} + +static bool pre(word n1, any y, word n2, any x) { + for (;;) { + if ((n1 & 0xFF) != (n2 & 0xFF)) + return NO; + if ((n1 >>= 8) == 0) { + if (!isNum(y = cdr(numCell(y)))) + return YES; + n1 = unDig(y); + } + if ((n2 >>= 8) == 0) { + if (!isNum(x = cdr(numCell(x)))) + return NO; + n2 = unDig(x); + } + } +} + +bool subStr(any y, any x) { + word n; + + if (!isNum(y = name(y))) + return YES; + if (!isNum(x = name(x))) + return NO; + n = unDig(x); + for (;;) { + if (pre(unDig(y), y, n, x)) + return YES; + if ((n >>= 8) == 0) { + if (!isNum(x = cdr(numCell(x)))) + return NO; + n = unDig(x); + } + } +} + +// (pre? 'any1 'any2) -> any2 | NIL +any doPreQ(any x) { + any y, z; + cell c1; + + x = cdr(x), Push(c1, evSym(x)); + x = cdr(x), x = evSym(x); + drop(c1); + if (!isNum(y = name(data(c1)))) + return x; + if (!isNum(z = name(x))) + return Nil; + return pre(unDig(y), y, unDig(z), z)? x : Nil; +} + +// (sub? 'any1 'any2) -> any2 | NIL +any doSubQ(any x) { + cell c1; + + x = cdr(x), Push(c1, evSym(x)); + x = cdr(x), x = evSym(x); + drop(c1); + return subStr(data(c1), x)? x : Nil; +} + +// (val 'var) -> any +any doVal(any ex) { + any x; + + x = cdr(ex), x = EVAL(car(x)); + NeedVar(ex,x); + if (isSym(x)) + Fetch(ex,x); + return val(x); +} + +// (set 'var 'any ..) -> any +any doSet(any ex) { + any x; + cell c1, c2; + + x = cdr(ex); + do { + Push(c1, EVAL(car(x))), x = cdr(x); + NeedVar(ex,data(c1)); + CheckVar(ex,data(c1)); + if (isSym(data(c1))) + Touch(ex,data(c1)); + Push(c2, EVAL(car(x))), x = cdr(x); + val(data(c1)) = data(c2); + drop(c1); + } while (isCell(x)); + return val(data(c1)); +} + +// (setq var 'any ..) -> any +any doSetq(any ex) { + any x, y; + + x = cdr(ex); + do { + y = car(x), x = cdr(x); + NeedVar(ex,y); + CheckVar(ex,y); + val(y) = EVAL(car(x)); + } while (isCell(x = cdr(x))); + return val(y); +} + +// (xchg 'var 'var ..) -> any +any doXchg(any ex) { + any x, y; + cell c1, c2; + + x = cdr(ex); + do { + Push(c1, EVAL(car(x))), x = cdr(x); + NeedVar(ex,data(c1)); + CheckVar(ex,data(c1)); + if (isSym(data(c1))) + Touch(ex,data(c1)); + Push(c2, EVAL(car(x))), x = cdr(x); + NeedVar(ex,data(c2)); + CheckVar(ex,data(c2)); + if (isSym(data(c2))) + Touch(ex,data(c2)); + y = val(data(c1)), val(data(c1)) = val(data(c2)), val(data(c2)) = y; + drop(c1); + } while (isCell(x)); + return y; +} + +// (on var ..) -> T +any doOn(any ex) { + any x = cdr(ex); + do { + NeedVar(ex,car(x)); + CheckVar(ex,car(x)); + val(car(x)) = T; + } while (isCell(x = cdr(x))); + return T; +} + +// (off var ..) -> NIL +any doOff(any ex) { + any x = cdr(ex); + do { + NeedVar(ex,car(x)); + CheckVar(ex,car(x)); + val(car(x)) = Nil; + } while (isCell(x = cdr(x))); + return Nil; +} + +// (onOff var ..) -> flg +any doOnOff(any ex) { + any x = cdr(ex); + any y; + + do { + NeedVar(ex,car(x)); + CheckVar(ex,car(x)); + y = val(car(x)) = isNil(val(car(x)))? T : Nil; + } while (isCell(x = cdr(x))); + return y; +} + +// (zero var ..) -> 0 +any doZero(any ex) { + any x = cdr(ex); + do { + NeedVar(ex,car(x)); + CheckVar(ex,car(x)); + val(car(x)) = Zero; + } while (isCell(x = cdr(x))); + return Zero; +} + +// (one var ..) -> 1 +any doOne(any ex) { + any x = cdr(ex); + do { + NeedVar(ex,car(x)); + CheckVar(ex,car(x)); + val(car(x)) = One; + } while (isCell(x = cdr(x))); + return One; +} + +// (default var 'any ..) -> any +any doDefault(any ex) { + any x, y; + + x = cdr(ex); + do { + y = car(x), x = cdr(x); + NeedVar(ex,y); + CheckVar(ex,y); + if (isNil(val(y))) + val(y) = EVAL(car(x)); + } while (isCell(x = cdr(x))); + return val(y); +} + +// (push 'var 'any ..) -> any +any doPush(any ex) { + any x; + cell c1, c2; + + x = cdr(ex), Push(c1, EVAL(car(x))); + NeedVar(ex,data(c1)); + CheckVar(ex,data(c1)); + if (isSym(data(c1))) + Touch(ex,data(c1)); + x = cdr(x), Push(c2, EVAL(car(x))); + val(data(c1)) = cons(data(c2), val(data(c1))); + while (isCell(x = cdr(x))) { + data(c2) = EVAL(car(x)); + val(data(c1)) = cons(data(c2), val(data(c1))); + } + drop(c1); + return data(c2); +} + +// (push1 'var 'any ..) -> any +any doPush1(any ex) { + any x; + cell c1, c2; + + x = cdr(ex), Push(c1, EVAL(car(x))); + NeedVar(ex,data(c1)); + CheckVar(ex,data(c1)); + if (isSym(data(c1))) + Touch(ex,data(c1)); + x = cdr(x), Push(c2, EVAL(car(x))); + if (!member(data(c2), val(data(c1)))) + val(data(c1)) = cons(data(c2), val(data(c1))); + while (isCell(x = cdr(x))) + if (!member(data(c2) = EVAL(car(x)), val(data(c1)))) + val(data(c1)) = cons(data(c2), val(data(c1))); + drop(c1); + return data(c2); +} + +// (pop 'var) -> any +any doPop(any ex) { + any x, y; + + x = cdr(ex), x = EVAL(car(x)); + NeedVar(ex,x); + CheckVar(ex,x); + if (isSym(x)) + Touch(ex,x); + if (!isCell(y = val(x))) + return y; + val(x) = cdr(y); + return car(y); +} + +// (cut 'cnt 'var) -> lst +any doCut(any ex) { + long n; + any x, y; + cell c1, c2; + + if ((n = evCnt(ex, x = cdr(ex))) <= 0) + return Nil; + x = cdr(x), Push(c1, EVAL(car(x))); + NeedVar(ex,data(c1)); + CheckVar(ex,data(c1)); + if (isSym(data(c1))) + Touch(ex,data(c1)); + if (isCell(val(data(c1)))) { + Push(c2, y = cons(car(val(data(c1))), Nil)); + while (isCell(val(data(c1)) = cdr(val(data(c1)))) && --n) + y = cdr(y) = cons(car(val(data(c1))), Nil); + drop(c1); + return data(c2); + } + return val(Pop(c1)); +} + +// (del 'any 'var) -> lst +any doDel(any ex) { + any x, y; + cell c1, c2, c3; + + x = cdr(ex), Push(c1, EVAL(car(x))); + x = cdr(x), Push(c2, EVAL(car(x))); + NeedVar(ex,data(c2)); + CheckVar(ex,data(c2)); + if (isSym(data(c2))) + Touch(ex,data(c2)); + if (isCell(x = val(data(c2)))) { + if (equal(data(c1), car(x))) { + drop(c1); + return val(data(c2)) = cdr(x); + } + Push(c3, y = cons(car(x), Nil)); + while (isCell(x = cdr(x))) { + if (equal(data(c1), car(x))) { + cdr(y) = cdr(x); + drop(c1); + return val(data(c2)) = data(c3); + } + y = cdr(y) = cons(car(x), Nil); + } + } + drop(c1); + return val(data(c2)); +} + +// (queue 'var 'any) -> any +any doQueue(any ex) { + any x, y; + cell c1; + + x = cdr(ex), Push(c1, EVAL(car(x))); + NeedVar(ex,data(c1)); + CheckVar(ex,data(c1)); + if (isSym(data(c1))) + Touch(ex,data(c1)); + x = cdr(x), x = EVAL(car(x)); + if (!isCell(y = val(data(c1)))) + val(data(c1)) = cons(x,Nil); + else { + while (isCell(cdr(y))) + y = cdr(y); + cdr(y) = cons(x,Nil); + } + drop(c1); + return x; +} + +// (fifo 'var ['any ..]) -> any +any doFifo(any ex) { + any x, y, z; + cell c1; + + x = cdr(ex), Push(c1, EVAL(car(x))); + NeedVar(ex,data(c1)); + CheckVar(ex,data(c1)); + if (isSym(data(c1))) + Touch(ex,data(c1)); + if (isCell(x = cdr(x))) { + y = EVAL(car(x)); + if (isCell(z = val(data(c1)))) + val(data(c1)) = z = cdr(z) = cons(y,cdr(z)); + else + cdr(z) = z = val(data(c1)) = cons(y,Nil); + while (isCell(x = cdr(x))) + val(data(c1)) = z = cdr(z) = cons(y = EVAL(car(x)), cdr(z)); + } + else if (!isCell(z = val(data(c1)))) + y = Nil; + else { + if (z == cdr(z)) { + y = car(z); + val(data(c1)) = Nil; + } + else { + y = cadr(z); + cdr(z) = cddr(z); + } + } + drop(c1); + return y; +} + +any idx(any var, any key, int flg) { + any x, y, z, *p; + int n; + + if (!key) { + cell c1, c2; + + if (!isCell(x = val(var))) + return Nil; + y = Nil; // Result + Push(c1, x); // Tree + Push(c2, Nil); // TOS + for (;;) { + while (isCell(cddr(data(c1)))) + z = data(c1), data(c1) = cddr(z), cddr(z) = data(c2), data(c2) = z; + for (;;) { + y = cons(car(data(c1)), y); + if (isCell(cadr(data(c1)))) { + z = data(c1), data(c1) = cadr(z), cadr(z) = data(c2), data(c2) = symPtr(z); + break; + } + for (;;) { + if (isNil(data(c2))) { + drop(c1); + return y; + } + if (isCell(data(c2))) { + z = data(c2), data(c2) = cddr(z), cddr(z) = data(c1), data(c1) = z; + break; + } + z = cellPtr(data(c2)), data(c2) = cadr(z), cadr(z) = data(c1), data(c1) = z; + } + } + } + } + if (!isCell(x = val(var))) { + if (flg > 0) + val(var) = cons(key,Nil); + return Nil; + } + p = (any*)var; + for (;;) { + if ((n = compare(key, car(x))) == 0) { + if (flg < 0) { + if (!isCell(cadr(x))) + *p = cddr(x); + else if (!isCell(y = cddr(x))) + *p = cadr(x); + else if (!isCell(z = cadr(y))) + car(x) = car(y), cddr(x) = cddr(y); + else { + while (isCell(cadr(z))) + z = cadr(y = z); + car(x) = car(z), cadr(y) = cddr(z); + } + } + return x; + } + if (!isCell(cdr(x))) { + if (flg > 0) + cdr(x) = n < 0? cons(cons(key,Nil), Nil) : cons(Nil, cons(key,Nil)); + return Nil; + } + if (n < 0) { + if (!isCell(cadr(x))) { + if (flg > 0) + cadr(x) = cons(key,Nil); + return Nil; + } + x = *(p = &cadr(x)); + } + else { + if (!isCell(cddr(x))) { + if (flg > 0) + cddr(x) = cons(key,Nil); + return Nil; + } + x = *(p = &cddr(x)); + } + } +} + +// (idx 'var 'any 'flg) -> lst +// (idx 'var 'any) -> lst +// (idx 'var) -> lst +any doIdx(any ex) { + any x; + int flg; + cell c1, c2; + + x = cdr(ex), Push(c1, EVAL(car(x))); + NeedVar(ex,data(c1)); + CheckVar(ex,data(c1)); + if (!isCell(x = cdr(x))) + x = idx(data(c1), NULL, 0); + else { + Push(c2, EVAL(car(x))); + if (!isCell(cdr(x))) + flg = 0; + else + flg = isNil(EVAL(cadr(x)))? -1 : +1; + x = idx(data(c1), data(c2), flg); + } + drop(c1); + return x; +} + +// (lup 'lst 'any) -> lst +// (lup 'lst 'any 'any2) -> lst +any doLup(any x) { + int n; + cell c1, c2, c3, c4, c5; + + x = cdr(x), data(c1) = EVAL(car(x)); + if (!isCell(data(c1))) + return data(c1); + Save(c1); + x = cdr(x), Push(c2, EVAL(car(x))); // from + if (isCell(x = cdr(x))) { + Push(c3, EVAL(car(x))); // to + Push(c4, Nil); // tos + Push(c5, Nil); // result + for (;;) { + while (isCell(cddr(data(c1))) && car(data(c1)) != T && (!isCell(car(data(c1))) || compare(data(c3), caar(data(c1))) >= 0)) + x = data(c1), data(c1) = cddr(x), cddr(x) = data(c4), data(c4) = x; + for (;;) { + if (isCell(car(data(c1))) && compare(data(c2), caar(data(c1))) <= 0) { + if (compare(data(c3), caar(data(c1))) >= 0) + data(c5) = cons(car(data(c1)), data(c5)); + if (isCell(cadr(data(c1)))) { + x = data(c1), data(c1) = cadr(x), cadr(x) = data(c4), data(c4) = symPtr(x); + break; + } + } + for (;;) { + if (isNil(data(c4))) { + drop(c1); + return data(c5); + } + if (isCell(data(c4))) { + x = data(c4), data(c4) = cddr(x), cddr(x) = data(c1), data(c1) = x; + break; + } + else + x = cellPtr(data(c4)), data(c4) = cadr(x), cadr(x) = data(c1), data(c1) = x; + } + } + } + } + do { + if (car(data(c1)) == T) + data(c1) = cadr(data(c1)); + else if (!isCell(car(data(c1)))) + data(c1) = cddr(data(c1)); + else if (n = compare(data(c2), caar(data(c1)))) + data(c1) = n < 0? cadr(data(c1)) : cddr(data(c1)); + else { + drop(c1); + return car(data(c1)); + } + } while (isCell(data(c1))); + drop(c1); + return Nil; +} + +void put(any x, any key, any val) { + any y, z; + + if (isCell(y = tail1(x))) { + if (isCell(car(y))) { + if (key == cdar(y)) { + if (isNil(val)) + Tail(x, cdr(y)); + else if (val == T) + car(y) = key; + else + caar(y) = val; + return; + } + } + else if (key == car(y)) { + if (isNil(val)) + Tail(x, cdr(y)); + else if (val != T) + car(y) = cons(val,key); + return; + } + while (isCell(z = cdr(y))) { + if (isCell(car(z))) { + if (key == cdar(z)) { + if (isNil(val)) + cdr(y) = cdr(z); + else { + if (val == T) + car(z) = key; + else + caar(z) = val; + cdr(y) = cdr(z), cdr(z) = tail1(x), Tail(x, z); + } + return; + } + } + else if (key == car(z)) { + if (isNil(val)) + cdr(y) = cdr(z); + else { + if (val != T) + car(z) = cons(val,key); + cdr(y) = cdr(z), cdr(z) = tail1(x), Tail(x, z); + } + return; + } + y = z; + } + } + if (!isNil(val)) + Tail(x, cons(val==T? key : cons(val,key), tail1(x))); +} + +any get(any x, any key) { + any y, z; + + if (!isCell(y = tail1(x))) + return Nil; + if (!isCell(car(y))) { + if (key == car(y)) + return T; + } + else if (key == cdar(y)) + return caar(y); + while (isCell(z = cdr(y))) { + if (!isCell(car(z))) { + if (key == car(z)) { + cdr(y) = cdr(z), cdr(z) = tail1(x), Tail(x, z); + return T; + } + } + else if (key == cdar(z)) { + cdr(y) = cdr(z), cdr(z) = tail1(x), Tail(x, z); + return caar(z); + } + y = z; + } + return Nil; +} + +any prop(any x, any key) { + any y, z; + + if (!isCell(y = tail1(x))) + return Nil; + if (!isCell(car(y))) { + if (key == car(y)) + return key; + } + else if (key == cdar(y)) + return car(y); + while (isCell(z = cdr(y))) { + if (!isCell(car(z))) { + if (key == car(z)) { + cdr(y) = cdr(z), cdr(z) = tail1(x), Tail(x, z); + return key; + } + } + else if (key == cdar(z)) { + cdr(y) = cdr(z), cdr(z) = tail1(x), Tail(x, z); + return car(z); + } + y = z; + } + return Nil; +} + +// (put 'sym1|lst ['sym2|cnt ..] 'sym|0 'any) -> any +any doPut(any ex) { + any x; + cell c1, c2, c3; + + x = cdr(ex), Push(c1, EVAL(car(x))); + x = cdr(x), Push(c2, EVAL(car(x))); + while (isCell(cdr(x = cdr(x)))) { + if (isCell(data(c1))) + data(c1) = getn(data(c2), data(c1)); + else { + NeedSym(ex,data(c1)); + Fetch(ex,data(c1)); + data(c1) = isNum(data(c2)) && !unDig(data(c2))? val(data(c1)) : get(data(c1), data(c2)); + } + data(c2) = EVAL(car(x)); + } + NeedSym(ex,data(c1)); + CheckNil(ex,data(c1)); + Push(c3, EVAL(car(x))); + Touch(ex,data(c1)); + if (isNum(data(c2)) && IsZero(data(c2))) + val(data(c1)) = x = data(c3); + else + put(data(c1), data(c2), x = data(c3)); + drop(c1); + return x; +} + +// (get 'sym1|lst ['sym2|cnt ..]) -> any +any doGet(any ex) { + any x, y; + cell c1; + + x = cdr(ex), data(c1) = EVAL(car(x)); + if (!isCell(x = cdr(x))) + return data(c1); + Save(c1); + do { + y = EVAL(car(x)); + if (isCell(data(c1))) + data(c1) = getn(y, data(c1)); + else { + NeedSym(ex,data(c1)); + Fetch(ex,data(c1)); + data(c1) = isNum(y) && !unDig(y)? val(data(c1)) : get(data(c1), y); + } + } while (isCell(x = cdr(x))); + return Pop(c1); +} + +// (prop 'sym1|lst ['sym2|cnt ..] 'sym) -> lst|sym +any doProp(any ex) { + any x; + cell c1, c2; + + x = cdr(ex), Push(c1, EVAL(car(x))); + x = cdr(x), Push(c2, EVAL(car(x))); + while (isCell(x = cdr(x))) { + if (isCell(data(c1))) + data(c1) = getn(data(c2), data(c1)); + else { + NeedSym(ex,data(c1)); + Fetch(ex,data(c1)); + data(c1) = isNum(data(c2)) && !unDig(data(c2))? val(data(c1)) : get(data(c1), data(c2)); + } + data(c2) = EVAL(car(x)); + } + NeedSym(ex,data(c1)); + Fetch(ex,data(c1)); + return prop(Pop(c1), data(c2)); +} + +// (; 'sym1|lst [sym2|cnt ..]) -> any +any doSemicol(any ex) { + any x; + cell c1; + + x = cdr(ex), data(c1) = EVAL(car(x)); + if (!isCell(x = cdr(x))) + return data(c1); + Save(c1); + do { + if (isCell(data(c1))) + data(c1) = getn(car(x), data(c1)); + else { + NeedSym(ex,data(c1)); + Fetch(ex,data(c1)); + data(c1) = isNum(car(x)) && !unDig(car(x))? val(data(c1)) : get(data(c1), car(x)); + } + } while (isCell(x = cdr(x))); + return Pop(c1); +} + +// (=: sym|0 [sym1|cnt .. sym2|0] 'any) -> any +any doSetCol(any ex) { + any x, y, z; + cell c1; + + x = cdr(ex), y = val(This); + Fetch(ex,y); + if (z = car(x), isCell(cdr(x = cdr(x)))) { + y = isNum(z) && !unDig(z)? val(y) : get(y,z); + while (z = car(x), isCell(cdr(x = cdr(x)))) { + if (isCell(y)) + y = getn(z,y); + else { + NeedSym(ex,y); + Fetch(ex,y); + y = isNum(z) && !unDig(z)? val(y) : get(y,z); + } + } + } + NeedSym(ex,y); + CheckNil(ex,y); + Push(c1, EVAL(car(x))); + Touch(ex,y); + if (isNum(z) && IsZero(z)) + val(y) = x = data(c1); + else + put(y, z, x = data(c1)); + drop(c1); + return x; +} + +// (: sym|0 [sym1|cnt ..]) -> any +any doCol(any ex) { + any x, y; + + x = cdr(ex), y = val(This); + Fetch(ex,y); + y = isNum(car(x)) && !unDig(car(x))? val(y) : get(y, car(x)); + while (isCell(x = cdr(x))) { + if (isCell(y)) + y = getn(car(x), y); + else { + NeedSym(ex,y); + Fetch(ex,y); + y = isNum(car(x)) && !unDig(car(x))? val(y) : get(y, car(x)); + } + } + return y; +} + +// (:: sym|0 [sym1|cnt .. sym2]) -> lst|sym +any doPropCol(any ex) { + any x, y; + + x = cdr(ex), y = val(This); + Fetch(ex,y); + if (isCell(cdr(x))) { + y = isNum(car(x)) && !unDig(car(x))? val(y) : get(y, car(x)); + while (isCell(cdr(x = cdr(x)))) { + if (isCell(y)) + y = getn(car(x), y); + else { + NeedSym(ex,y); + Fetch(ex,y); + y = isNum(car(x)) && !unDig(car(x))? val(y) : get(y, car(x)); + } + } + } + return prop(y, car(x)); +} + +// (putl 'sym1|lst1 ['sym2|cnt ..] 'lst) -> lst +any doPutl(any ex) { + any x; + cell c1, c2; + + x = cdr(ex), Push(c1, EVAL(car(x))); + x = cdr(x), Push(c2, EVAL(car(x))); + while (isCell(x = cdr(x))) { + if (isCell(data(c1))) + data(c1) = getn(data(c2), data(c1)); + else { + NeedSym(ex,data(c1)); + Fetch(ex,data(c1)); + data(c1) = isNum(data(c2)) && !unDig(data(c2))? val(data(c1)) : get(data(c1), data(c2)); + } + data(c2) = EVAL(car(x)); + } + NeedSym(ex,data(c1)); + CheckNil(ex,data(c1)); + Touch(ex,data(c1)); + while (isCell(tail(data(c1)))) + Tail(data(c1), cdr(tail1(data(c1)))); + for (x = data(c2); isCell(x); x = cdr(x)) { + if (!isCell(car(x))) + Tail(data(c1), cons(car(x), tail1(data(c1)))); + else if (!isNil(caar(x))) + Tail(data(c1), cons(caar(x)==T? cdar(x) : car(x), tail1(data(c1)))); + } + drop(c1); + return data(c2); +} + +// (getl 'sym1|lst1 ['sym2|cnt ..]) -> lst +any doGetl(any ex) { + any x, y; + cell c1, c2; + + x = cdr(ex), Push(c1, EVAL(car(x))); + while (isCell(x = cdr(x))) { + y = EVAL(car(x)); + if (isCell(data(c1))) + data(c1) = getn(y, data(c1)); + else { + NeedSym(ex,data(c1)); + Fetch(ex,data(c1)); + data(c1) = isNum(y) && !unDig(y)? val(data(c1)) : get(data(c1), y); + } + } + NeedSym(ex,data(c1)); + Fetch(ex,data(c1)); + if (!isCell(x = tail1(data(c1)))) + data(c2) = Nil; + else { + Push(c2, y = cons(car(x),Nil)); + while (isCell(x = cdr(x))) + y = cdr(y) = cons(car(x),Nil); + } + drop(c1); + return data(c2); +} + +static void wipe(any x) { + any y, z; + + for (y = tail1(x); isCell(y); y = cdr(y)); + if (!isNum(y)) { + val(x) = Nil; + tail(x) = y; + } + else { + z = numCell(y); + while (isNum(cdr(z))) + z = numCell(cdr(z)); + if (isNil(cdr(z)) || cdr(z) == At) { + val(x) = Nil; + Tail(x, y); + cdr(z) = Nil; + } + } +} + +// (wipe 'sym|lst) -> sym +any doWipe(any x) { + any y; + + x = cdr(x); + if (!isNil(x = EVAL(car(x)))) + if (!isCell(x)) + wipe(x); + else { + y = x; do + wipe(car(y)); + while (isCell(y = cdr(y))); + } + return x; +} + +static any meta(any x, any y) { + any z; + + while (isCell(x)) { + if (isSym(car(x))) + if (!isNil(z = get(car(x),y)) || !isNil(z = meta(val(car(x)), y))) + return z; + x = cdr(x); + } + return Nil; +} + +// (meta 'obj|typ 'sym ['sym2|cnt ..]) -> any +any doMeta(any ex) { + any x, y; + cell c1; + + x = cdr(ex), Push(c1, EVAL(car(x))); + if (isSym(data(c1))) { + Fetch(ex,data(c1)); + data(c1) = val(data(c1)); + } + x = cdr(x), y = EVAL(car(x)); + data(c1) = meta(data(c1), y); + while (isCell(x = cdr(x))) { + y = EVAL(car(x)); + if (isCell(data(c1))) + data(c1) = getn(y, data(c1)); + else { + NeedSym(ex,data(c1)); + Fetch(ex,data(c1)); + data(c1) = isNum(y) && !unDig(y)? val(data(c1)) : get(data(c1), y); + } + } + return Pop(c1); +} + +/*** Case mappings from the GNU Kaffe Project ***/ +#define CHAR_UPPERCASE 1 +#define CHAR_LOWERCASE 2 +#define CHAR_LETTER 62 +#define CHAR_DIGIT 512 + +static u_int16_t Blocks[] = { + 0x1C2, 0x1C2, 0x1C1, 0x12C, 0x12B, 0x1A0, 0x1F8, 0x2DC, 0x25F, 0x2EE, 0x215, 0x346, 0x2DC, 0x326, 0x2BC, 0x216, + 0x15F, 0x2D4, 0x376, 0x376, 0x376, 0x369, 0xFE8F, 0x344, 0xFF85, 0xFF65, 0xFDB5, 0xFDA1, 0x1B, 0x2C4, 0x1C, 0x47, + 0xFEA8, 0xFF8C, 0x235, 0xFEFF, 0x1A, 0xFEBF, 0x26, 0xFB20, 0xFE28, 0x113, 0x104, 0xFB61, 0xFB5A, 0x10B, 0x109, 0xFE, + 0xFF08, 0x229, 0x25E, 0x1C7, 0x1FC, 0x1DC, 0xFC46, 0x229, 0xFE27, 0xFB55, 0x169, 0xFBC8, 0xFC, 0x103, 0xFB68, 0xFB48, + 0xFB28, 0xFB08, 0xFAE8, 0xFAC8, 0xFAA8, 0xFA88, 0xFA68, 0xFA48, 0x65, 0x50, 0xAB, 0x139, 0xFE0E, 0x63, 0x155, 0x1A8, + 0xF669, 0x129, 0x128, 0xF91F, 0xFE56, 0x108, 0x107, 0xFAC0, 0xFC8E, 0xFEAD, 0xC6, 0xFCA7, 0xFB95, 0xF47D, 0x9F, 0xFB17, + 0xFE20, 0xFD28, 0xFB2F, 0x3B, 0xF3B9, 0xFE57, 0xFCCE, 0xFFBB, 0xF339, 0xFA98, 0xFF8B, 0xFF3B, 0xFA54, 0xF7E3, 0xFF2B, 0xFAD7, + 0xFB69, 0xFC3A, 0xFEE5, 0xF4C8, 0xFCB0, 0xFA88, 0xFDBF, 0xF448, 0xFE45, 0xFCC7, 0xFE4F, 0xF7F1, 0xF715, 0xF2E8, 0xFD9F, 0xF348, + 0xF96A, 0xFC02, 0xFD97, 0xF2C8, 0xF2A8, 0xF4B9, 0xF4B3, 0xEF6B, 0xF86A, 0xF84A, 0xFC58, 0xF80A, 0xF7EA, 0xFC0F, 0xF7AA, 0xEE9C, + 0xFB90, 0xF74A, 0xF7FA, 0xF70A, 0xF7CA, 0xF792, 0xF471, 0xF4D2, 0xF732, 0xF64A, 0xF401, 0xF64D, 0xEFA8, 0xF5CA, 0xF5AA, 0xECA1, + 0xF569, 0xF54A, 0xF52A, 0xF50A, 0xF4EA, 0xF4CA, 0xF4AA, 0xF48A, 0xF46A, 0xF44A, 0xF42A, 0xF40A, 0xF3EA, 0xF3CA, 0xF3AA, 0xF38A, + 0xF36A, 0xF34A, 0xF32A, 0xF289, 0xF777, 0xF2CA, 0xF2AA, 0xF737, 0xEC28, 0xEC08, 0xEBE8, 0xEBC8, 0xF1EA, 0xF4A2, 0xF545, 0xEDC6, + 0xF2D7, 0xF14A, 0xE8ED, 0xE81E, 0xF0EA, 0xF597, 0xEA68, 0xEA48, 0xEA28, 0xEA08, 0xE9E8, 0xE9C8, 0xE9A8, 0xE988, 0xE968, 0xE948, + 0xE928, 0xE908, 0xE8E8, 0xE8C8, 0xE8A8, 0xE888, 0xE868, 0xE848, 0xE828, 0xE808, 0xE7E8, 0xE7C8, 0xE7A8, 0xE788, 0xE768, 0xE748, + 0xE728, 0xE708, 0xE6E8, 0xE6C8, 0xE6A8, 0xE688, 0xE668, 0xE648, 0xE628, 0xE608, 0xE5E8, 0xE5C8, 0xE5A8, 0xE588, 0xE568, 0xE548, + 0xE55F, 0xE53F, 0xE51F, 0xE4FF, 0xEFD7, 0xE4BF, 0xE49F, 0xE485, 0xEF87, 0xEF57, 0xEF57, 0xEF57, 0xEF57, 0xEF47, 0xE1AD, 0xEF46, + 0xEF46, 0xEF46, 0xE1E0, 0xE3DD, 0xEF06, 0xE9D9, 0xEBEB, 0xE244, 0xEED4, 0xEF65, 0xE1F5, 0xEF45, 0xEEE9, 0xEF7C, 0xEE74, 0xEF70, + 0xEF7D, 0xEF78, 0xEE91, 0xEFD3, 0xEE7D, 0xEE25, 0xEE27, 0xEF65, 0xEFDD, 0xEE96, 0xEFD3, 0xEFE1, 0xEF69, 0xDF88, 0xDF68, 0xDF48, + 0xED2B, 0xED3D, 0xED19, 0xEF1C, 0xEF08, 0xED47, 0xED3D, 0xED33, 0xEC2B, 0xEC0B, 0xEBEB, 0xEBCB, 0xEBCE, 0xEA7C, 0xEB69, 0xEB6C, + 0xE9B6, 0xEB0B, 0xEAEB, 0xE9E9, 0xDCA8, 0xDC88, 0xDC68, 0xDC48, 0xE910, 0xEA23, 0xEB58, 0xEB4F, 0xEB45, 0xEAE5, 0xDB68, 0xDB48, + 0xE92B, 0xE90B, 0xE8EB, 0xE8CB, 0xE8AB, 0xE88B, 0xE86B, 0xE84B, 0xDA28, 0xDA08, 0xD9E8, 0xD9C8, 0xD9A8, 0xD988, 0xD968, 0xD948, + 0xD928, 0xD908, 0xD8E8, 0xD8C8, 0xD8A8, 0xD888, 0xD868, 0xD848, 0xD828, 0xD808, 0xD7E8, 0xD7C8, 0xD7A8, 0xD788, 0xD768, 0xD748, + 0xD728, 0xD708, 0xD6E8, 0xD6C8, 0xD6A8, 0xD688, 0xD668, 0xD648, 0xD628, 0xD608, 0xD5E8, 0xD5C8, 0xD5A8, 0xD588, 0xD568, 0xD548, + 0xD528, 0xD508, 0xD4E8, 0xD4C8, 0xE2B1, 0xE28B, 0xE26B, 0xE270, 0xE22B, 0xE20B, 0xE1EB, 0xE1CB, 0xE1AB, 0xE18B, 0xE18E, 0xDD8F, + 0xE3A8, 0xDFD3, 0xD929, 0xD90A, 0xE348, 0xD8C9, 0xD8AA, 0xDCD7, 0xDCB2, 0xD681, 0xD82A, 0xD80A, 0xE268, 0xCEDE, 0xD168, 0xD148, + 0xE116, 0xE0E9, 0xE1CB, 0xE0B7, 0xE0B7, 0xE15E, 0xDF17, 0xE034, 0xE013, 0xDFF3, 0xDFD3, 0xDE6C, 0xDF93, 0xDF73, 0xDF55, 0xDF34, + 0xD56A, 0xD54A, 0xD52A, 0xD50A, 0xD4EA, 0xD4CA, 0xD4AA, 0xD48A, 0xD46A, 0xD44A, 0xD42A, 0xD40A, 0xD3EA, 0xD3CA, 0xD3AA, 0xD38A, + 0xD36A, 0xD34A, 0xD32A, 0xD30A, 0xD2EA, 0xD2CA, 0xD2AA, 0xD28A, 0xD26A, 0xD24A, 0xD22A, 0xD20A, 0xD1EA, 0xD1CA, 0xD1AA, 0xD18A, + 0xD16A, 0xD14A, 0xD12A, 0xD10A, 0xD0EA, 0xD0CA, 0xD0AA, 0xD08A, 0xD06A, 0xD04A, 0xD02A, 0xD00A, 0xCFEA, 0xCFCA, 0xCFAA, 0xCF8A, + 0xCF6A, 0xCF4A, 0xCF2A, 0xCF0A, 0xCEEA, 0xCECA, 0xCEAA, 0xCE8A, 0xCE6A, 0xCE4A, 0xCE2A, 0xCE0A, 0xCDEA, 0xCDCA, 0xCDAA, 0xCD8A, + 0xCD6A, 0xCD4A, 0xCD2A, 0xCD0A, 0xCCEA, 0xCCCA, 0xCCAA, 0xCC8A, 0xCC6A, 0xCC4A, 0xCC2A, 0xCC0A, 0xCBEA, 0xCBCA, 0xCBAA, 0xCB8A, + 0xCB6A, 0xCB4A, 0xCB2A, 0xCB0A, 0xCAEA, 0xCACA, 0xCAAA, 0xCA8A, 0xCA6A, 0xCA4A, 0xCA2A, 0xCA0A, 0xC9EA, 0xC9CA, 0xC9AA, 0xC98A, + 0xC96A, 0xC94A, 0xC92A, 0xC90A, 0xC8EA, 0xC8CA, 0xC8AA, 0xC88A, 0xC86A, 0xC84A, 0xC82A, 0xC80A, 0xC7EA, 0xC7CA, 0xC7AA, 0xC78A, + 0xC76A, 0xC74A, 0xC72A, 0xC70A, 0xC6EA, 0xC6CA, 0xC6AA, 0xC68A, 0xC66A, 0xC64A, 0xC62A, 0xC60A, 0xC5EA, 0xC5CA, 0xC5AA, 0xC58A, + 0xC56A, 0xC54A, 0xC52A, 0xC50A, 0xC4EA, 0xC4CA, 0xC4AA, 0xC48A, 0xC46A, 0xC44A, 0xC42A, 0xC40A, 0xC3EA, 0xC3CA, 0xC3AA, 0xC38A, + 0xC36A, 0xC34A, 0xC32A, 0xC30A, 0xC2EA, 0xC2CA, 0xC2AA, 0xC28A, 0xC26A, 0xC24A, 0xC22A, 0xC20A, 0xC1EA, 0xC1CA, 0xC1AA, 0xC18A, + 0xC16A, 0xC14A, 0xC12A, 0xC10A, 0xC0EA, 0xC0CA, 0xC0AA, 0xC08A, 0xC06A, 0xC04A, 0xC02A, 0xC00A, 0xBFEA, 0xBFCA, 0xBFAA, 0xBF8A, + 0xBF6A, 0xBF4A, 0xBF2A, 0xBF0A, 0xBEEA, 0xBECA, 0xBEAA, 0xBE8A, 0xBE6A, 0xBE4A, 0xBE2A, 0xBE0A, 0xBDEA, 0xBDCA, 0xBDAA, 0xBD8A, + 0xBD6A, 0xBD4A, 0xBD2A, 0xBD0A, 0xBCEA, 0xBCCA, 0xBCAA, 0xBC8A, 0xBC6A, 0xBC4A, 0xBC2A, 0xBC0A, 0xBBEA, 0xB2E0, 0xB568, 0xB548, + 0xBB6A, 0xBB4A, 0xBB2A, 0xBB0A, 0xBAEA, 0xBACA, 0xBAAA, 0xBA8A, 0xBA6A, 0xBA4A, 0xBA2A, 0xBA0A, 0xB9EA, 0xB9CA, 0xB9AA, 0xB98A, + 0xB96A, 0xB94A, 0xB92A, 0xB90A, 0xB8EA, 0xB8CA, 0xB8AA, 0xB88A, 0xB86A, 0xB84A, 0xB82A, 0xB80A, 0xB7EA, 0xB7CA, 0xB7AA, 0xB78A, + 0xB76A, 0xB74A, 0xB72A, 0xB70A, 0xB6EA, 0xB6CA, 0xB6AA, 0xB68A, 0xB66A, 0xB64A, 0xB62A, 0xB60A, 0xB5EA, 0xB5CA, 0xB5AA, 0xB58A, + 0xB56A, 0xB54A, 0xB52A, 0xB50A, 0xB4EA, 0xB4CA, 0xB4AA, 0xB48A, 0xB46A, 0xB44A, 0xB42A, 0xB40A, 0xB3EA, 0xB3CA, 0xB3AA, 0xB38A, + 0xB36A, 0xB34A, 0xB32A, 0xB30A, 0xB2EA, 0xB2CA, 0xB2AA, 0xB28A, 0xB26A, 0xB24A, 0xB22A, 0xB20A, 0xB1EA, 0xB1CA, 0xB1AA, 0xB18A, + 0xB16A, 0xB14A, 0xB12A, 0xB10A, 0xB0EA, 0xB0CA, 0xB0AA, 0xB08A, 0xB06A, 0xB04A, 0xB02A, 0xB00A, 0xAFEA, 0xAFCA, 0xAFAA, 0xAF8A, + 0xAF6A, 0xAF4A, 0xAF2A, 0xAF0A, 0xAEEA, 0xAECA, 0xAEAA, 0xAE8A, 0xAE6A, 0xAE4A, 0xAE2A, 0xAE0A, 0xADEA, 0xADCA, 0xADAA, 0xAD8A, + 0xAD6A, 0xAD4A, 0xAD2A, 0xAD0A, 0xACEA, 0xACCA, 0xACAA, 0xAC8A, 0xAC6A, 0xAC4A, 0xAC2A, 0xAC0A, 0xABEA, 0xABCA, 0xABAA, 0xAB8A, + 0xAB6A, 0xAB4A, 0xAB2A, 0xAB0A, 0xAAEA, 0xAACA, 0xAAAA, 0xAA8A, 0xAA6A, 0xAA4A, 0xAA2A, 0xAA0A, 0xA9EA, 0xA9CA, 0xA9AA, 0xA98A, + 0xA96A, 0xA94A, 0xA92A, 0xA90A, 0xA8EA, 0xA8CA, 0xA8AA, 0xA88A, 0xA86A, 0xA84A, 0xA82A, 0xA80A, 0xA7EA, 0xA7CA, 0xA7AA, 0xA78A, + 0xA76A, 0xA74A, 0xA72A, 0xA70A, 0xA6EA, 0xA6CA, 0xA6AA, 0xA68A, 0xA66A, 0xA64A, 0xA62A, 0xA60A, 0xA5EA, 0xA5CA, 0xA5AA, 0xA58A, + 0xA56A, 0xA54A, 0xA52A, 0xA50A, 0xA4EA, 0xA4CA, 0xA4AA, 0xA48A, 0xA46A, 0xA44A, 0xA42A, 0xA40A, 0xA3EA, 0xA3CA, 0xA3AA, 0xA38A, + 0xA36A, 0xA34A, 0xA32A, 0xA30A, 0xA2EA, 0xA2CA, 0xA2AA, 0xA28A, 0xA26A, 0xA24A, 0xA22A, 0xA20A, 0xA1EA, 0xA1CA, 0xA1AA, 0xA18A, + 0xA16A, 0xA14A, 0xA12A, 0xA10A, 0xA0EA, 0xA0CA, 0xA0AA, 0xA08A, 0xA06A, 0xA04A, 0xA02A, 0xA00A, 0x9FEA, 0x9FCA, 0x9FAA, 0x9F8A, + 0x9F6A, 0x9F4A, 0x9F2A, 0x9F0A, 0x9EEA, 0x9ECA, 0x9EAA, 0x9E8A, 0x9E6A, 0x9E4A, 0x9E2A, 0x9E0A, 0x9DEA, 0x9DCA, 0x9DAA, 0x9D8A, + 0x9D6A, 0x9D4A, 0x9D2A, 0x9D0A, 0x9CEA, 0x9CCA, 0x9CAA, 0x9C8A, 0x9C6A, 0x9C4A, 0x9C2A, 0x9C0A, 0x9BEA, 0x9BCA, 0x9BAA, 0x9B8A, + 0x9B6A, 0x9B4A, 0x9B2A, 0x9B0A, 0x9AEA, 0x9ACA, 0x9AAA, 0x9A8A, 0x9A6A, 0x9A4A, 0x9A2A, 0x9A0A, 0x99EA, 0x99CA, 0x99AA, 0x998A, + 0x996A, 0x994A, 0x992A, 0x990A, 0x98EA, 0x98CA, 0x98AA, 0x988A, 0x986A, 0x984A, 0x982A, 0x980A, 0x97EA, 0x97CA, 0x97AA, 0x978A, + 0x976A, 0x974A, 0x972A, 0x970A, 0x96EA, 0x96CA, 0x96AA, 0x968A, 0x966A, 0x964A, 0x962A, 0x960A, 0x95EA, 0x95CA, 0x95AA, 0x958A, + 0x956A, 0x954A, 0x952A, 0x950A, 0x94EA, 0x94CA, 0x94AA, 0x948A, 0x946A, 0x944A, 0x942A, 0x940A, 0x93EA, 0x93CA, 0x93AA, 0x938A, + 0x936A, 0x934A, 0x932A, 0x930A, 0x92EA, 0x92CA, 0x92AA, 0x928A, 0x926A, 0x924A, 0x922A, 0x920A, 0x91EA, 0x91CA, 0x91AA, 0x918A, + 0x916A, 0x914A, 0x912A, 0x910A, 0x90EA, 0x90CA, 0x90AA, 0x908A, 0x906A, 0x904A, 0x902A, 0x900A, 0x8FEA, 0x8FCA, 0x8FAA, 0x8F8A, + 0x8F6A, 0x8F4A, 0x8F2A, 0x8F0A, 0x8EEA, 0x8ECA, 0x8EAA, 0x8E8A, 0x8E6A, 0x8E4A, 0x8E2A, 0x8E0A, 0x8DEA, 0x8DCA, 0x8DAA, 0x8D8A, + 0x8D6A, 0x8D4A, 0x8D2A, 0x8D0A, 0x8CEA, 0x8CCA, 0x8CAA, 0x8C8A, 0x8C6A, 0x8C4A, 0x8C2A, 0x8C0A, 0x8BEA, 0x8BCA, 0x8BAA, 0x8B8A, + 0x8B6A, 0x8B4A, 0x8B2A, 0x8B0A, 0x8AEA, 0x8ACA, 0x8AAA, 0x8A8A, 0x8A6A, 0x8A4A, 0x8A2A, 0x8A0A, 0x89EA, 0x89CA, 0x89AA, 0x898A, + 0x896A, 0x894A, 0x892A, 0x890A, 0x88EA, 0x88CA, 0x88AA, 0x888A, 0x886A, 0x884A, 0x882A, 0x880A, 0x87EA, 0x87CA, 0x87AA, 0x878A, + 0x876A, 0x874A, 0x872A, 0x870A, 0x86EA, 0x86CA, 0x86AA, 0x868A, 0x866A, 0x864A, 0x862A, 0x860A, 0x85EA, 0x85CA, 0x85AA, 0x858A, + 0x856A, 0x854A, 0x852A, 0x850A, 0x84EA, 0x84CA, 0x84AA, 0x848A, 0x846A, 0x844A, 0x842A, 0x840A, 0x83EA, 0x83CA, 0x83AA, 0x838A, + 0x836A, 0x834A, 0x832A, 0x830A, 0x82EA, 0x82CA, 0x82AA, 0x828A, 0x826A, 0x824A, 0x822A, 0x820A, 0x81EA, 0x81CA, 0x81AA, 0x818A, + 0x816A, 0x814A, 0x812A, 0x810A, 0x80EA, 0x80CA, 0x80AA, 0x808A, 0x806A, 0x804A, 0x802A, 0x800A, 0x7FEA, 0x7FCA, 0x7FAA, 0x7F8A, + 0x7F6A, 0x7F4A, 0x7F2A, 0x7F0A, 0x7EEA, 0x7ECA, 0x7EAA, 0x7E8A, 0x7E6A, 0x7E4A, 0x7E2A, 0x7E0A, 0x7DEA, 0x7DCA, 0x7DAA, 0x7D8A, + 0x7D6A, 0x7D4A, 0x7D2A, 0x7D0A, 0x7CEA, 0x7CCA, 0x7CAA, 0x7C8A, 0x7C6A, 0x7C4A, 0x7C2A, 0x7C0A, 0x7BEA, 0x7BCA, 0x7BAA, 0x7B8A, + 0x7B6A, 0x7B4A, 0x7B2A, 0x7B0A, 0x7AEA, 0x7ACA, 0x7AAA, 0x7A8A, 0x7A6A, 0x7A4A, 0x7A2A, 0x7A0A, 0x79EA, 0x79CA, 0x79AA, 0x798A, + 0x796A, 0x794A, 0x792A, 0x790A, 0x78EA, 0x78CA, 0x78AA, 0x788A, 0x786A, 0x784A, 0x782A, 0x780A, 0x77EA, 0x77CA, 0x77AA, 0x778A, + 0x776A, 0x774A, 0x772A, 0x770A, 0x76EA, 0x76CA, 0x76AA, 0x768A, 0x766A, 0x764A, 0x762A, 0x760A, 0x75EA, 0x75CA, 0x75AA, 0x758A, + 0x756A, 0x754A, 0x752A, 0x750A, 0x74EA, 0x74CA, 0x74AA, 0x748A, 0x746A, 0x744A, 0x742A, 0x740A, 0x73EA, 0x73CA, 0x73AA, 0x738A, + 0x736A, 0x734A, 0x732A, 0x730A, 0x72EA, 0x72CA, 0x72AA, 0x728A, 0x726A, 0x724A, 0x722A, 0x720A, 0x71EA, 0x71CA, 0x71AA, 0x718A, + 0x716A, 0x714A, 0x712A, 0x710A, 0x70EA, 0x70CA, 0x70AA, 0x708A, 0x706A, 0x704A, 0x702A, 0x700A, 0x6FEA, 0x6FCA, 0x6FAA, 0x6F8A, + 0x6F6A, 0x6F4A, 0x6F2A, 0x6F0A, 0x6EEA, 0x6ECA, 0x6EAA, 0x6E8A, 0x6E6A, 0x6E4A, 0x6E2A, 0x6E0A, 0x6DEA, 0x6DCA, 0x6DAA, 0x6D8A, + 0x6D6A, 0x6D4A, 0x6D2A, 0x6D0A, 0x6CEA, 0x6CCA, 0x6CAA, 0x6C8A, 0x6C6A, 0x6C4A, 0x6C2A, 0x6C0A, 0x6BEA, 0x6BCA, 0x6BAA, 0x6B8A, + 0x6B6A, 0x6B4A, 0x6B2A, 0x6B0A, 0x6AEA, 0x6ACA, 0x6AAA, 0x6A8A, 0x6A6A, 0x6A4A, 0x6A2A, 0x6A0A, 0x69EA, 0x60F0, 0x6368, 0x6348, + 0x696A, 0x694A, 0x692A, 0x690A, 0x68EA, 0x68CA, 0x68AA, 0x688A, 0x686A, 0x684A, 0x682A, 0x680A, 0x67EA, 0x67CA, 0x67AA, 0x678A, + 0x676A, 0x674A, 0x672A, 0x670A, 0x66EA, 0x66CA, 0x66AA, 0x668A, 0x666A, 0x664A, 0x662A, 0x660A, 0x65EA, 0x65CA, 0x65AA, 0x658A, + 0x656A, 0x654A, 0x652A, 0x650A, 0x6B26, 0x6DE1, 0x6E9C, 0x5E48, 0x5E28, 0x5E08, 0x5DE8, 0x5DC8, 0x5DA8, 0x5D88, 0x5D68, 0x5D48, + 0x5D28, 0x5D08, 0x5CE8, 0x5CC8, 0x5CA8, 0x5C88, 0x5C68, 0x5C48, 0x5C28, 0x5C08, 0x5BE8, 0x5BC8, 0x5BA8, 0x5B88, 0x5B68, 0x5B48, + 0x5B28, 0x5B08, 0x5AE8, 0x5AC8, 0x5AA8, 0x5A88, 0x5A68, 0x5A48, 0x5A28, 0x5A08, 0x59E8, 0x59C8, 0x59A8, 0x5988, 0x5968, 0x5948, + 0x5928, 0x5908, 0x58E8, 0x58C8, 0x58A8, 0x5888, 0x5868, 0x5848, 0x5828, 0x5808, 0x57E8, 0x57C8, 0x57A8, 0x5788, 0x5768, 0x5748, + 0x5D6A, 0x5D4A, 0x5D2A, 0x5D0A, 0x5CEA, 0x5CCA, 0x5CAA, 0x5C8A, 0x5C6A, 0x5C4A, 0x5C2A, 0x5C0A, 0x5BEA, 0x5BCA, 0x5BAA, 0x5B8A, + 0x5B6A, 0x5B4A, 0x5B2A, 0x5B0A, 0x5AEA, 0x5ACA, 0x5AAA, 0x5A8A, 0x5A6A, 0x5A4A, 0x5A2A, 0x5A0A, 0x59EA, 0x59CA, 0x59AA, 0x598A, + 0x596A, 0x594A, 0x592A, 0x590A, 0x58EA, 0x58CA, 0x58AA, 0x588A, 0x586A, 0x584A, 0x582A, 0x580A, 0x57EA, 0x57CA, 0x57AA, 0x578A, + 0x576A, 0x574A, 0x572A, 0x570A, 0x56EA, 0x56CA, 0x56AA, 0x568A, 0x566A, 0x564A, 0x562A, 0x560A, 0x55EA, 0x55CA, 0x55AA, 0x558A, + 0x556A, 0x554A, 0x552A, 0x550A, 0x54EA, 0x54CA, 0x54AA, 0x548A, 0x546A, 0x544A, 0x542A, 0x540A, 0x53EA, 0x53CA, 0x53AA, 0x538A, + 0x536A, 0x534A, 0x532A, 0x530A, 0x52EA, 0x52CA, 0x52AA, 0x528A, 0x526A, 0x524A, 0x522A, 0x520A, 0x51EA, 0x51CA, 0x51AA, 0x518A, + 0x516A, 0x514A, 0x512A, 0x510A, 0x50EA, 0x50CA, 0x50AA, 0x508A, 0x506A, 0x504A, 0x502A, 0x500A, 0x4FEA, 0x4FCA, 0x4FAA, 0x4F8A, + 0x4F6A, 0x4F4A, 0x4F2A, 0x4F0A, 0x4EEA, 0x4ECA, 0x4EAA, 0x4E8A, 0x4E6A, 0x4E4A, 0x4E2A, 0x4E0A, 0x4DEA, 0x4DCA, 0x4DAA, 0x4D8A, + 0x4D6A, 0x4D4A, 0x4D2A, 0x4D0A, 0x4CEA, 0x4CCA, 0x4CAA, 0x4C8A, 0x4C6A, 0x4C4A, 0x4C2A, 0x4C0A, 0x4BEA, 0x4BCA, 0x4BAA, 0x4B8A, + 0x4B6A, 0x4B4A, 0x4B2A, 0x4B0A, 0x4AEA, 0x4ACA, 0x4AAA, 0x4A8A, 0x4A6A, 0x4A4A, 0x4A2A, 0x4A0A, 0x49EA, 0x49CA, 0x49AA, 0x498A, + 0x496A, 0x494A, 0x492A, 0x490A, 0x48EA, 0x48CA, 0x48AA, 0x488A, 0x486A, 0x484A, 0x482A, 0x480A, 0x47EA, 0x47CA, 0x47AA, 0x478A, + 0x476A, 0x474A, 0x472A, 0x470A, 0x46EA, 0x46CA, 0x46AA, 0x468A, 0x466A, 0x464A, 0x462A, 0x460A, 0x45EA, 0x45CA, 0x45AA, 0x458A, + 0x456A, 0x454A, 0x452A, 0x450A, 0x44EA, 0x44CA, 0x44AA, 0x448A, 0x446A, 0x444A, 0x442A, 0x440A, 0x43EA, 0x43CA, 0x43AA, 0x438A, + 0x436A, 0x434A, 0x432A, 0x430A, 0x42EA, 0x42CA, 0x42AA, 0x428A, 0x426A, 0x424A, 0x422A, 0x420A, 0x41EA, 0x41CA, 0x41AA, 0x418A, + 0x416A, 0x414A, 0x412A, 0x410A, 0x40EA, 0x40CA, 0x40AA, 0x408A, 0x406A, 0x404A, 0x402A, 0x400A, 0x3FEA, 0x3FCA, 0x3FAA, 0x3F8A, + 0x3F6A, 0x3F4A, 0x3F2A, 0x3F0A, 0x3EEA, 0x3ECA, 0x3EAA, 0x3E8A, 0x3E6A, 0x3E4A, 0x3E2A, 0x3E0A, 0x3DEA, 0x3DCA, 0x3DAA, 0x3D8A, + 0x3D6A, 0x3D4A, 0x3D2A, 0x3D0A, 0x3CEA, 0x3CCA, 0x3CAA, 0x3C8A, 0x3C6A, 0x3C4A, 0x3C2A, 0x3C0A, 0x3BEA, 0x3BCA, 0x3BAA, 0x3B8A, + 0x3B6A, 0x3B4A, 0x3B2A, 0x3B0A, 0x3AEA, 0x3ACA, 0x3AAA, 0x3A8A, 0x3A6A, 0x3A4A, 0x3A2A, 0x3A0A, 0x39EA, 0x39CA, 0x39AA, 0x398A, + 0x396A, 0x394A, 0x392A, 0x390A, 0x38EA, 0x38CA, 0x38AA, 0x388A, 0x386A, 0x384A, 0x382A, 0x380A, 0x37EA, 0x37CA, 0x37AA, 0x378A, + 0x376A, 0x374A, 0x372A, 0x370A, 0x36EA, 0x36CA, 0x36AA, 0x368A, 0x366A, 0x364A, 0x362A, 0x360A, 0x35EA, 0x35CA, 0x35AA, 0x358A, + 0x356A, 0x354A, 0x352A, 0x350A, 0x34EA, 0x34CA, 0x34AA, 0x348A, 0x346A, 0x344A, 0x342A, 0x340A, 0x33EA, 0x33CA, 0x33AA, 0x338A, + 0x336A, 0x334A, 0x332A, 0x330A, 0x32EA, 0x32CA, 0x32AA, 0x328A, 0x326A, 0x324A, 0x322A, 0x320A, 0x31EA, 0x28F2, 0x2B68, 0x2B48, + 0x3C2B, 0x3C0B, 0x3BEB, 0x3BCB, 0x3BAB, 0x3B8B, 0x3B6B, 0x3B4B, 0x3B2B, 0x3B0B, 0x3AEB, 0x3ACB, 0x3AAB, 0x3A8B, 0x3A6B, 0x3A4B, + 0x3A2B, 0x3A0B, 0x39EB, 0x39CB, 0x39AB, 0x398B, 0x396B, 0x394B, 0x392B, 0x390B, 0x38EB, 0x38CB, 0x38AB, 0x388B, 0x386B, 0x384B, + 0x382B, 0x380B, 0x37EB, 0x37CB, 0x37AB, 0x378B, 0x376B, 0x374B, 0x372B, 0x370B, 0x36EB, 0x36CB, 0x36AB, 0x368B, 0x366B, 0x364B, + 0x362B, 0x360B, 0x35EB, 0x35CB, 0x35AB, 0x358B, 0x356B, 0x354B, 0x352B, 0x350B, 0x34EB, 0x34CB, 0x34AB, 0x348B, 0x346B, 0x344B, + 0x344B, 0x342B, 0x340B, 0x33EB, 0x33CB, 0x33AB, 0x338B, 0x336B, 0x334B, 0x332B, 0x330B, 0x32EB, 0x32CB, 0x32AB, 0x328B, 0x326B, + 0x324B, 0x322B, 0x320B, 0x31EB, 0x31CB, 0x31AB, 0x318B, 0x316B, 0x314B, 0x312B, 0x310B, 0x30EB, 0x30CB, 0x30AB, 0x308B, 0x306B, + 0x304B, 0x302B, 0x300B, 0x2FEB, 0x2FCB, 0x2FAB, 0x2F8B, 0x2F6B, 0x2F4B, 0x2F2B, 0x2F0B, 0x2EEB, 0x2ECB, 0x2EAB, 0x2E8B, 0x2E6B, + 0x2E4B, 0x2E2B, 0x2E0B, 0x2DEB, 0x2DCB, 0x2DAB, 0x2D8B, 0x2D6B, 0x2D4B, 0x2D2B, 0x2D0B, 0x2CEB, 0x2CCB, 0x2CAB, 0x2C8B, 0x2C6B, + 0x2C4B, 0x2C2B, 0x2C0B, 0x2BEB, 0x2BCB, 0x2BAB, 0x2B8B, 0x2B6B, 0x2B4B, 0x2B2B, 0x2B0B, 0x2AEB, 0x2ACB, 0x2AAB, 0x2A8B, 0x2A6B, + 0x2A4B, 0x2A2B, 0x2A0B, 0x29EB, 0x29CB, 0x29AB, 0x298B, 0x296B, 0x294B, 0x292B, 0x290B, 0x28EB, 0x28CB, 0x28AB, 0x288B, 0x286B, + 0x284B, 0x282B, 0x280B, 0x27EB, 0x27CB, 0x27AB, 0x278B, 0x276B, 0x274B, 0x272B, 0x270B, 0x26EB, 0x26CB, 0x26AB, 0x268B, 0x266B, + 0x264B, 0x262B, 0x260B, 0x25EB, 0x25CB, 0x25AB, 0x258B, 0x256B, 0x254B, 0x252B, 0x250B, 0x24EB, 0x24CB, 0x24AB, 0x248B, 0x246B, + 0x244B, 0x242B, 0x240B, 0x23EB, 0x23CB, 0x23AB, 0x238B, 0x236B, 0x234B, 0x232B, 0x230B, 0x22EB, 0x22CB, 0x22AB, 0x228B, 0x226B, + 0x224B, 0x222B, 0x220B, 0x21EB, 0x21CB, 0x21AB, 0x218B, 0x216B, 0x214B, 0x212B, 0x210B, 0x20EB, 0x20CB, 0x20AB, 0x208B, 0x206B, + 0x204B, 0x202B, 0x200B, 0x1FEB, 0x1FCB, 0x1FAB, 0x1F8B, 0x1F6B, 0x1F4B, 0x1F2B, 0x1F0B, 0x1EEB, 0x1ECB, 0x1EAB, 0x1E8B, 0x1E6B, + 0x1E4B, 0x1E2B, 0x1E0B, 0x1DEB, 0x1DCB, 0x1DAB, 0x1D8B, 0x1D6B, 0x1D4B, 0x1D2B, 0x1D0B, 0x1CEB, 0x1CCB, 0x1CAB, 0x1C8B, 0x1C6B, + 0x1C4B, 0x1C2B, 0x1C0B, 0x1BEB, 0x1BCB, 0x1BAB, 0x1B8B, 0x1B6B, 0x106A, 0x104A, 0x102A, 0x100A, 0xFEA, 0xFCA, 0xFAA, 0xF8A, + 0xF6A, 0x668, 0x8E8, 0x8C8, 0x8A8, 0x888, 0x868, 0x848, 0x7D7, 0x194B, 0x7B6, 0xD1C, 0xCFC, 0xCB2, 0xCA9, 0xC9C, + 0xC7C, 0xC5C, 0xC3C, 0xC1C, 0xBFC, 0xBDC, 0xBBC, 0xB9C, 0xB7C, 0xB5E, 0xB2C, 0xB1C, 0xAB8, 0xADC, 0xA9C, 0x2C2, + 0x528, 0x166B, 0x1667, 0x3FF, 0x9FC, 0x9DC, 0x9BC, 0x659, 0xBB8, 0x15A7, 0xFC6, 0x1C0, 0x1B1, 0x9CB, 0x82C, 0x1285, +}; + +static u_int16_t Data[] = { + 0x3001, 0x3082, 0x3001, 0x3082, 0x3001, 0x3082, 0x3001, 0x3082, 0x3001, 0x3082, 0x3001, 0x3082, 0x3001, 0x3082, 0x3001, 0x3082, + 0x3001, 0x3082, 0x3001, 0x3082, 0x3001, 0x3082, 0x3E80, 0x3E80, 0x3001, 0x3082, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, + 0x3A85, 0x3A85, 0x3E80, 0x3E80, 0x3E80, 0x3A85, 0x3A85, 0x3A85, 0x3E80, 0x3E80, 0x3E80, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, + 0x3A85, 0x3A85, 0x3A85, 0x3E80, 0x3A85, 0x3A85, 0x3A85, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x5B88, 0x5B88, 0x3E80, 0x3A85, 0x3A85, + 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3E80, 0x3A85, 0x3A85, 0x3A85, 0x3E80, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, + 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, + 0x3A85, 0x3A85, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x5198, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x4606, 0x3E80, 0x3E80, 0x3A85, 0x3A85, + 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3A85, 0x3A85, 0x3E80, 0x3E80, 0x3A85, 0x3A85, 0x3A85, 0x3A85, + 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, + 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, + 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, + 0x3E80, 0x3E80, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x3E80, 0x3E80, + 0x3E80, 0x3E80, 0x5202, 0x5202, 0x5202, 0x5202, 0x5202, 0x5202, 0x5202, 0x5202, 0x5202, 0x5202, 0x5202, 0x5202, 0x5202, 0x5202, + 0x5202, 0x5202, 0x5202, 0x5202, 0x5202, 0x5202, 0x5202, 0x5202, 0x5202, 0x5202, 0x5202, 0x5202, 0x5202, 0x5202, 0x5202, 0x5202, + 0x5202, 0x2E82, 0x3E80, 0x5198, 0x2A14, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, + 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x4686, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, + 0x4606, 0x4606, 0x4606, 0x4606, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, + 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x1A1B, 0x1A1B, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x4584, 0x3E80, 0x3E80, 0x3E80, 0x298, + 0x3E80, 0x298, 0x6615, 0x6696, 0x298, 0x1A97, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, + 0x4584, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, + 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x4584, + 0x4584, 0x1A1B, 0x1A1B, 0x1A1B, 0x1A1B, 0x1A1B, 0x1A1B, 0x1A1B, 0x1A1B, 0x1A1B, 0x1A1B, 0x1A1B, 0x1A1B, 0x1A1B, 0x1A1B, 0x4584, + 0x4584, 0x1A1B, 0x1A1B, 0x1A1B, 0x1A1B, 0x1A1B, 0x1A1B, 0x1A1B, 0x1A1B, 0x1A1B, 0x1A1B, 0x1A1B, 0x1A1B, 0x1A1B, 0x1A1B, 0x2E82, + 0x7282, 0x2E82, 0x3E80, 0x2E82, 0x4902, 0x7481, 0x7481, 0x7481, 0x7481, 0x7383, 0x1A1B, 0x1A1B, 0x1A1B, 0x6D82, 0x6D82, 0x4902, + 0x4902, 0x3E80, 0x3E80, 0x2E82, 0x4902, 0x6E01, 0x6E01, 0x7501, 0x7501, 0x3E80, 0x1A1B, 0x1A1B, 0x1A1B, 0x1B02, 0x1B82, 0x1C02, + 0x1C82, 0x1D02, 0x1D82, 0x1E02, 0x1E82, 0x1F02, 0x1F82, 0x2002, 0x2082, 0x2102, 0x2182, 0x2202, 0x2282, 0x2302, 0x2382, 0x2402, + 0x2482, 0x2502, 0x2582, 0x2602, 0x2682, 0x2702, 0x2782, 0x455, 0xC99, 0x4D6, 0xC99, 0xF, 0xF, 0xF, 0xF, 0xF, + 0x10F, 0xF, 0xF, 0xF, 0xF, 0xF, 0xF, 0xF, 0xF, 0xF, 0xF, 0xF, 0xF, 0xF, 0xF, 0xF, + 0xF, 0xF, 0xF, 0xF, 0xF, 0xF, 0xF, 0xF, 0xF, 0xF, 0xF, 0x8F, 0x10F, 0x8F, 0x18F, 0x10F, + 0xF, 0xF, 0xF, 0xF, 0xF, 0xF, 0xF, 0xF, 0xF, 0xF, 0xF, 0xF, 0xF, 0xF, 0x10F, 0x10F, + 0x10F, 0x8F, 0x20C, 0x298, 0x298, 0x318, 0x39A, 0x318, 0x298, 0x298, 0x455, 0x4D6, 0x298, 0x519, 0x598, 0x614, + 0x598, 0x698, 0x709, 0x789, 0x809, 0x889, 0x909, 0x989, 0xA09, 0xA89, 0xB09, 0xB89, 0x598, 0x298, 0xC59, 0xC99, + 0xC59, 0x298, 0xD01, 0xD81, 0xE01, 0xE81, 0xF01, 0xF81, 0x1001, 0x1081, 0x1101, 0x1181, 0x1201, 0x1281, 0x1301, 0x1381, + 0x1401, 0x1481, 0x1501, 0x1581, 0x1601, 0x1681, 0x1701, 0x1781, 0x1801, 0x1881, 0x1901, 0x1981, 0x455, 0x298, 0x4D6, 0x1A1B, + 0x1A97, 0x298, 0x298, 0x298, 0xC99, 0x455, 0x4D6, 0x3E80, 0x298, 0x298, 0x298, 0x298, 0x298, 0x298, 0x3E80, 0x3E80, + 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, + 0x282C, 0x298, 0x39A, 0x39A, 0x39A, 0x39A, 0x289C, 0x289C, 0x1A1B, 0x289C, 0x2902, 0x29DD, 0xC99, 0x2A14, 0x289C, 0x1A1B, + 0x2A9C, 0x519, 0x2B0B, 0x2B8B, 0x1A1B, 0x2C02, 0x289C, 0x298, 0x1A1B, 0x2C8B, 0x2902, 0x2D5E, 0x2D8B, 0x2D8B, 0x2D8B, 0x298, + 0x298, 0x519, 0x614, 0xC99, 0xC99, 0xC99, 0x3E80, 0x298, 0x39A, 0x318, 0x298, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x5405, + 0x5405, 0x5405, 0x3E80, 0x5405, 0x3E80, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, + 0x5405, 0x5405, 0x3E80, 0x3E80, 0x3E80, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, + 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, + 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x3E80, 0x501C, 0x501C, 0x4F81, 0x4F81, 0x4F81, 0x4F81, 0x4F81, 0x4F81, 0x4F81, 0x4F81, + 0x4F81, 0x4F81, 0x4F81, 0x4F81, 0x4F81, 0x4F81, 0x4F81, 0x4F81, 0x2E01, 0x2E01, 0x2E01, 0x2E01, 0x2E01, 0x2E01, 0x2E01, 0x2E01, + 0x2E01, 0x2E01, 0x2E01, 0x2E01, 0x2E01, 0x2E01, 0x2E01, 0x2E01, 0x2E01, 0x2E01, 0x2E01, 0x2E01, 0x2E01, 0x2E01, 0x2E01, 0xC99, + 0x2E01, 0x2E01, 0x2E01, 0x2E01, 0x2E01, 0x2E01, 0x2E01, 0x2E82, 0x2E82, 0x2E82, 0x4902, 0x4902, 0x2E82, 0x2E82, 0x3E80, 0x3E80, + 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x2E82, 0x2E82, 0x2E82, 0x2E82, 0x2E82, 0x3E80, + 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x5305, 0x4606, 0x5305, 0x5305, 0x3E80, 0x5305, 0x5305, 0x3E80, 0x5305, 0x5305, 0x5305, 0x5305, + 0x5305, 0x5305, 0x5305, 0x5305, 0x5305, 0x5305, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, + 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5398, 0x5405, 0x4606, 0x4606, 0x4606, 0x4606, + 0x4606, 0x4606, 0x4606, 0x5087, 0x5087, 0x4606, 0x5087, 0x5087, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, + 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, + 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x2D8B, 0x2D8B, 0x2D8B, 0x2D8B, 0x2D8B, 0x2D8B, 0x2D8B, 0x2D8B, + 0x2D8B, 0x2D8B, 0x2D8B, 0x2D8B, 0x840B, 0x3082, 0x3001, 0x3082, 0x3001, 0x3082, 0x3001, 0x3082, 0x3001, 0x3082, 0x2E82, 0x3001, + 0x3082, 0x3001, 0x3082, 0x3001, 0x3082, 0x3001, 0x3082, 0x3001, 0x3082, 0x3001, 0x3082, 0x3001, 0x3082, 0x3001, 0x3082, 0x3001, + 0x3082, 0x3001, 0x3082, 0x3001, 0x3082, 0x3001, 0x3082, 0x3001, 0x3082, 0x3001, 0x3082, 0x3001, 0x3082, 0x3001, 0x3082, 0x3E80, + 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x5C09, 0x5C89, 0x5D09, 0x5D89, 0x5E09, 0x5E89, 0x5F09, 0x5F89, 0x6009, 0x6089, 0x4606, + 0x4606, 0x3A85, 0x3A85, 0x3A85, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x1A1B, + 0x1A1B, 0x4701, 0x298, 0x4781, 0x4781, 0x4781, 0x3E80, 0x4801, 0x3E80, 0x4881, 0x4881, 0x4902, 0x2E01, 0x2E01, 0x2E01, 0x2E01, + 0x2E01, 0x2E01, 0x2E01, 0x2E01, 0x2E01, 0x2E01, 0x2E01, 0x2E01, 0x2E01, 0x2E01, 0x2E01, 0x2E01, 0x2F02, 0x2F02, 0x2F02, 0x2F02, + 0x2F02, 0x2F02, 0x2F02, 0x2F02, 0x2F02, 0x2F02, 0x2F02, 0x2F02, 0x2F02, 0x2F02, 0x2F02, 0x2F02, 0x2F02, 0x2F02, 0x2F02, 0x2F02, + 0x2F02, 0x2F02, 0x2F02, 0xC99, 0x2F02, 0x2F02, 0x2F02, 0x2F02, 0x2F02, 0x2F02, 0x2F02, 0x2F82, 0x2F02, 0x2F02, 0x4A82, 0x2F02, + 0x2F02, 0x2F02, 0x2F02, 0x2F02, 0x2F02, 0x2F02, 0x2F02, 0x2F02, 0x4B02, 0x4B82, 0x4B82, 0x3E80, 0x4C02, 0x4C82, 0x4D01, 0x4D01, + 0x4D01, 0x4D82, 0x4E02, 0x2902, 0x3E80, 0x3E80, 0x3001, 0x3082, 0x3001, 0x3082, 0x3001, 0x3082, 0x3001, 0x3082, 0x3001, 0x3082, + 0x3001, 0x3082, 0x3001, 0x3082, 0x3001, 0x3082, 0x2E82, 0x3B81, 0x3C03, 0x3C82, 0x3001, 0x3082, 0x3D81, 0x3E01, 0x3001, 0x3082, + 0x3001, 0x3082, 0x3001, 0x3082, 0x3001, 0x3082, 0x3001, 0x3082, 0x3001, 0x3082, 0x3001, 0x3082, 0x3001, 0x3082, 0x3101, 0x3182, + 0x3001, 0x3082, 0x3001, 0x3082, 0x3001, 0x3082, 0x2902, 0x3001, 0x3082, 0x3001, 0x3082, 0x3001, 0x3082, 0x3001, 0x3082, 0x3001, + 0x3082, 0x3001, 0x3082, 0x3001, 0x3082, 0x3001, 0x3082, 0x4E82, 0x4F02, 0x3D02, 0x2902, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, + 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x5B10, 0x5B10, 0x5B10, 0x5B10, 0x5B10, 0x5B10, 0x7F0B, 0x3E80, 0x3E80, + 0x3E80, 0x7F8B, 0x800B, 0x808B, 0x810B, 0x818B, 0x820B, 0x519, 0x519, 0xC99, 0x455, 0x4D6, 0x2902, 0x3301, 0x3001, 0x3082, + 0x3001, 0x3082, 0x3381, 0x3001, 0x3082, 0x3401, 0x3401, 0x3001, 0x3082, 0x2902, 0x3481, 0x3501, 0x3581, 0x3001, 0x3082, 0x3401, + 0x3601, 0x3682, 0x3701, 0x3781, 0x3001, 0x3082, 0x2902, 0x2902, 0x3701, 0x3801, 0x2902, 0x3881, 0x3A85, 0x3A85, 0x3A85, 0x3A85, + 0x3B81, 0x3C03, 0x3C82, 0x3B81, 0x3C03, 0x3C82, 0x3B81, 0x3C03, 0x3C82, 0x3001, 0x3082, 0x3001, 0x3082, 0x3001, 0x3082, 0x3001, + 0x3082, 0x3001, 0x3082, 0x3001, 0x3082, 0x3001, 0x3082, 0x3001, 0x3082, 0x3D02, 0x3001, 0x3082, 0x501C, 0x4606, 0x4606, 0x4606, + 0x4606, 0x3E80, 0x5087, 0x5087, 0x3E80, 0x3E80, 0x3001, 0x3082, 0x3001, 0x3082, 0x3001, 0x3082, 0x3001, 0x3082, 0x3001, 0x3082, + 0x3001, 0x3082, 0x3001, 0x3082, 0x3001, 0x3082, 0x3001, 0x3082, 0x3001, 0x3082, 0x3001, 0x3082, 0x3001, 0x3082, 0x3201, 0x3001, + 0x3082, 0x3001, 0x3082, 0x3001, 0x3082, 0x3282, 0x3001, 0x3082, 0x3001, 0x3082, 0x3001, 0x3082, 0x3901, 0x3001, 0x3082, 0x3901, + 0x2902, 0x2902, 0x3001, 0x3082, 0x3901, 0x3001, 0x3082, 0x3981, 0x3981, 0x3001, 0x3082, 0x3001, 0x3082, 0x3A01, 0x3001, 0x3082, + 0x2902, 0x3A85, 0x3001, 0x3082, 0x2902, 0x3B02, 0x4D01, 0x3001, 0x3082, 0x3001, 0x3082, 0x3E80, 0x3E80, 0x3001, 0x3082, 0x3E80, + 0x3E80, 0x3001, 0x3082, 0x3E80, 0x3E80, 0x3E80, 0x3001, 0x3082, 0x3001, 0x3082, 0x3001, 0x3082, 0x3001, 0x3082, 0x3001, 0x3082, + 0x3001, 0x3082, 0x3001, 0x3082, 0x3001, 0x3082, 0x3001, 0x3082, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, + 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x598, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, + 0x3E80, 0x3E80, 0x3E80, 0x5398, 0x3E80, 0x3E80, 0x3E80, 0x5398, 0x5398, 0x5398, 0x5398, 0x5398, 0x5398, 0x5398, 0x5398, 0x5398, + 0x5398, 0x5398, 0x5398, 0x5398, 0x5398, 0x3E80, 0x5B10, 0x5405, 0x4606, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, + 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, + 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x3E80, 0x3E80, 0x5B10, 0x4D01, 0x4D01, 0x4D01, 0x4D01, 0x4D01, 0x4D01, 0x4D01, + 0x4D01, 0x4D01, 0x4D01, 0x4D01, 0x4D01, 0x4D01, 0x4D01, 0x4D01, 0x4D01, 0x4D01, 0x4D01, 0x4D01, 0x4D01, 0x4D01, 0x4D01, 0x4D01, + 0x4D01, 0x4D01, 0x4D01, 0x4D01, 0x4D01, 0x4D01, 0x4D01, 0x4D01, 0x4D01, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, + 0x3E80, 0x3E80, 0x3E80, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, + 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3E80, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3E80, + 0x3A85, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x5C09, 0x5C89, 0x5D09, 0x5D89, 0x5E09, 0x5E89, 0x5F09, 0x5F89, 0x6009, 0x6089, + 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, + 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x2902, 0x2902, 0x2902, 0x3F02, 0x3F82, 0x2902, 0x4002, 0x4002, 0x2902, 0x4082, + 0x2902, 0x4102, 0x2902, 0x2902, 0x2902, 0x2902, 0x4002, 0x2902, 0x2902, 0x4182, 0x2902, 0x2902, 0x2902, 0x2902, 0x4202, 0x4282, + 0x2902, 0x2902, 0x2902, 0x2902, 0x2902, 0x4282, 0x2902, 0x2902, 0x4302, 0x2902, 0x2902, 0x4382, 0x2902, 0x2902, 0x2902, 0x2902, + 0x2902, 0x2902, 0x2902, 0x2902, 0x2902, 0x2902, 0x4402, 0x2902, 0x2902, 0x4402, 0x2902, 0x2902, 0x2902, 0x2902, 0x4402, 0x2902, + 0x4482, 0x4482, 0x2902, 0x2902, 0x2902, 0x2902, 0x2902, 0x2902, 0x4502, 0x2902, 0x2902, 0x2902, 0x2902, 0x2902, 0x2902, 0x2902, + 0x2902, 0x2902, 0x2902, 0x2902, 0x2902, 0x2902, 0x2902, 0x3E80, 0x3E80, 0x4584, 0x4584, 0x4584, 0x4584, 0x4584, 0x4584, 0x4584, + 0x4584, 0x4584, 0x1A1B, 0x1A1B, 0x4584, 0x4584, 0x4584, 0x4584, 0x4584, 0x1A1B, 0x1A1B, 0x1A1B, 0x1A1B, 0x1A1B, 0x1A1B, 0x1A1B, + 0x1A1B, 0x1A1B, 0x4584, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, + 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x5101, 0x5101, 0x5101, 0x5101, 0x5101, 0x5101, 0x5101, 0x5101, 0x5101, 0x5101, 0x5101, 0x5101, + 0x5101, 0x5101, 0x5101, 0x5101, 0x5101, 0x5101, 0x5101, 0x5101, 0x5101, 0x5101, 0x5101, 0x3E80, 0x3E80, 0x4584, 0x5198, 0x5198, + 0x5198, 0x5198, 0x5198, 0x5198, 0x2E01, 0x2E01, 0x3E80, 0x2E01, 0x2E01, 0x2E01, 0x2E01, 0x2E01, 0x2E01, 0x2E01, 0x2E01, 0x2E01, + 0x4982, 0x4A02, 0x4A02, 0x4A02, 0x4902, 0x2F02, 0x2F02, 0x2F02, 0x2F02, 0x2F02, 0x2F02, 0x2F02, 0x2F02, 0x2F02, 0x2F02, 0x2F02, + 0x2F02, 0x2F02, 0x2F02, 0x2F02, 0x2F02, 0x4F02, 0x4F02, 0x4F02, 0x4F02, 0x4F02, 0x4F02, 0x4F02, 0x4F02, 0x4F02, 0x4F02, 0x4F02, + 0x4F02, 0x4F02, 0x4F02, 0x4F02, 0x4F02, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x5198, 0x4606, 0x4606, 0x3A85, 0x3A85, 0x3A85, + 0x3A85, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x3E80, 0x4606, 0x4606, + 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, + 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x3E80, 0x4606, 0x4606, 0x4606, 0x5298, 0x4606, 0x4606, 0x5298, 0x4606, 0x3E80, 0x3E80, + 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x5305, 0x5305, 0x5305, 0x5305, 0x5305, 0x5305, 0x5305, + 0x5305, 0x5305, 0x5305, 0x5305, 0x5305, 0x5305, 0x5305, 0x5305, 0x5305, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x5305, 0x5305, + 0x5305, 0x5298, 0x5298, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x5C89, 0x5D09, + 0x5D89, 0x5E09, 0x5E89, 0x5F09, 0x5F89, 0x6009, 0x6089, 0x640B, 0x648B, 0x650B, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, + 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x4606, 0x5B88, 0x3E80, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, + 0x3E80, 0x3E80, 0x3E80, 0x3A85, 0x3A85, 0x3A85, 0x3E80, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3E80, 0x3E80, 0x3E80, 0x3A85, 0x3A85, + 0x3E80, 0x3A85, 0x3E80, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3E80, 0x3E80, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, + 0x3E80, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3E80, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, + 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3E80, 0x3E80, 0x3E80, 0x3E80, + 0x3E80, 0x3E80, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, + 0x5B88, 0x5B88, 0x5B88, 0x5B88, 0x3E80, 0x4606, 0x4606, 0x4606, 0x3E80, 0x4606, 0x4606, 0x4606, 0x4606, 0x3E80, 0x3E80, 0x3E80, + 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x4606, 0x4606, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x4606, + 0x5B88, 0x5B88, 0x3E80, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3E80, 0x3E80, 0x3A85, 0x3A85, 0x3E80, + 0x3E80, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3E80, 0x3E80, + 0x3E80, 0x3E80, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, + 0x3A85, 0x3E80, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, + 0x3A85, 0x3A85, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x5B88, 0x5B88, 0x3E80, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, + 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3E80, 0x3E80, 0x3E80, 0x3A85, 0x3A85, + 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3E80, 0x3E80, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3E80, 0x3E80, 0x3A85, 0x3A85, + 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3E80, 0x3E80, 0x3A85, 0x3A85, 0x3A85, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x5C09, 0x5C89, 0x5D09, + 0x5D89, 0x5E09, 0x5E89, 0x5F09, 0x5F89, 0x6009, 0x6089, 0x501C, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, + 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x5509, 0x5589, 0x5609, 0x5689, 0x5709, 0x5789, 0x5809, 0x5889, 0x5909, + 0x5989, 0x318, 0x5A18, 0x5A18, 0x5398, 0x3E80, 0x3E80, 0x4606, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, + 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x3E80, 0x3E80, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, + 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, + 0x5405, 0x5405, 0x5405, 0x5405, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, + 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x5405, 0x5405, 0x5405, 0x5405, + 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, + 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x6615, 0x6696, 0x5484, 0x5405, + 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, + 0x4606, 0x4606, 0x4606, 0x4606, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, + 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x5B88, 0x5B88, 0x5198, 0x3E80, 0x3E80, 0x3E80, 0x3E80, + 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x4606, 0x4606, 0x5B88, 0x3E80, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, + 0x3A85, 0x3A85, 0x3E80, 0x3A85, 0x3E80, 0x3A85, 0x3A85, 0x3A85, 0x3E80, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, + 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x5198, 0x5198, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, + 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x5484, 0x5484, + 0x4606, 0x4606, 0x289C, 0x4606, 0x4606, 0x4606, 0x4606, 0x3E80, 0x3E80, 0x709, 0x789, 0x809, 0x889, 0x909, 0x989, 0xA09, + 0xA89, 0xB09, 0xB89, 0x5405, 0x5405, 0x5405, 0x5A9C, 0x5A9C, 0x3E80, 0x3A85, 0x3A85, 0x3A85, 0x3E80, 0x3A85, 0x3E80, 0x3A85, + 0x3E80, 0x3E80, 0x3A85, 0x3A85, 0x3E80, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x4606, 0x3A85, 0x3A85, 0x4606, 0x4606, 0x4606, 0x4606, + 0x4606, 0x4606, 0x3E80, 0x4606, 0x4606, 0x3A85, 0x3E80, 0x3E80, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, + 0x3A85, 0x3E80, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3E80, 0x3A85, 0x3A85, 0x3A85, + 0x3A85, 0x3A85, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x4606, 0x4606, 0x5B88, 0x3E80, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, + 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, + 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3E80, 0x3E80, 0x4606, 0x3A85, 0x5B88, 0x5B88, + 0x5B88, 0x5B88, 0x5B88, 0x3E80, 0x4606, 0x5B88, 0x5B88, 0x3E80, 0x5B88, 0x5B88, 0x4606, 0x4606, 0x3E80, 0x3E80, 0x3E80, 0x3E80, + 0x3E80, 0x3E80, 0x3E80, 0x5B88, 0x5B88, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3A85, 0x3E80, 0x5198, 0x5198, + 0x5198, 0x5198, 0x5198, 0x5198, 0x5198, 0x5198, 0x5C89, 0x5D09, 0x5D89, 0x5E09, 0x5E89, 0x5F09, 0x5F89, 0x6009, 0x6089, 0x640B, + 0x670B, 0x678B, 0x680B, 0x688B, 0x690B, 0x698B, 0x6A0B, 0x6A8B, 0x648B, 0x6B0B, 0x3E80, 0x3E80, 0x3E80, 0x3A85, 0x3A85, 0x3A85, + 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3E80, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3E80, 0x3A85, + 0x3A85, 0x3E80, 0x3E80, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3E80, 0x3E80, 0x4606, 0x3A85, 0x5B88, 0x4606, 0x4606, 0x4606, 0x4606, + 0x4606, 0x4606, 0x4606, 0x4606, 0x5B88, 0x5B88, 0x5B88, 0x5B88, 0x4606, 0x3E80, 0x3E80, 0x3A85, 0x4606, 0x4606, 0x4606, 0x4606, + 0x3E80, 0x3E80, 0x3E80, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3E80, 0x3A85, 0x3A85, 0x3A85, + 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3E80, 0x3A85, 0x3E80, 0x3E80, 0x3E80, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3E80, 0x3E80, 0x4606, + 0x3E80, 0x5B88, 0x5B88, 0x5B88, 0x3E80, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3E80, 0x3A85, 0x3A85, + 0x3A85, 0x3E80, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, + 0x3A85, 0x3E80, 0x3A85, 0x3E80, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3E80, 0x3E80, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, + 0x3A85, 0x3E80, 0x3A85, 0x3E80, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3E80, 0x3E80, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, + 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x4606, 0x3A85, 0x3A85, 0x4606, 0x4606, + 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x39A, 0x39A, 0x39A, 0x39A, 0x39A, 0x39A, 0x39A, + 0x39A, 0x39A, 0x39A, 0x39A, 0x39A, 0x39A, 0x39A, 0x39A, 0x39A, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, + 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3A85, 0x3A85, 0x4606, 0x4606, 0x5198, 0x5198, 0x5C09, + 0x5C89, 0x5D09, 0x5D89, 0x5E09, 0x5E89, 0x5F09, 0x5F89, 0x6009, 0x6089, 0x5198, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, + 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x298, 0x298, 0x318, 0x39A, 0x318, 0x298, 0x298, + 0x6615, 0x6696, 0x298, 0x519, 0x598, 0x614, 0x598, 0x698, 0x709, 0x789, 0x809, 0x889, 0x909, 0x989, 0xA09, 0xA89, + 0xB09, 0xB89, 0x598, 0x298, 0xC99, 0xC99, 0xC99, 0x298, 0x298, 0x298, 0x298, 0x298, 0x298, 0x2A14, 0x298, 0x298, + 0x298, 0x298, 0x5B10, 0x5B10, 0x5B10, 0x5B10, 0x3E80, 0x5C09, 0x5C89, 0x5D09, 0x5D89, 0x5E09, 0x5E89, 0x5F09, 0x5F89, 0x6009, + 0x6089, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, + 0x3E80, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3E80, 0x3A85, 0x3A85, 0x3A85, 0x3A85, + 0x3A85, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x5B88, 0x4606, 0x4606, 0x4606, 0x4606, 0x3E80, 0x3E80, 0x5B88, 0x5B88, 0x3E80, 0x3E80, + 0x5B88, 0x5B88, 0x4606, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x5B88, 0x3E80, 0x3E80, 0x3E80, + 0x3E80, 0x3A85, 0x3A85, 0x3E80, 0x3A85, 0x3E80, 0x3E80, 0x3A85, 0x3A85, 0x3E80, 0x3A85, 0x3E80, 0x3E80, 0x3A85, 0x3E80, 0x3E80, + 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3E80, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, + 0x3A85, 0x3A85, 0x3E80, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3E80, 0x3A85, 0x3A85, 0x3E80, 0x3A85, 0x3A85, + 0x3E80, 0x3A85, 0x3A85, 0x3E80, 0x3E80, 0x4606, 0x3E80, 0x5B88, 0x5B88, 0x4606, 0x4606, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x4606, + 0x4606, 0x3E80, 0x3E80, 0x4606, 0x4606, 0x4606, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, + 0x3E80, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3E80, 0x3A85, 0x3E80, 0x3A85, 0x3A85, 0x4606, 0x4606, 0x3E80, 0x3E80, 0x5C09, 0x5C89, + 0x5D09, 0x5D89, 0x5E09, 0x5E89, 0x5F09, 0x5F89, 0x6009, 0x6089, 0x3A85, 0x3A85, 0x39A, 0x39A, 0x610B, 0x618B, 0x620B, 0x628B, + 0x630B, 0x638B, 0x501C, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, + 0x3A85, 0x3E80, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3E80, 0x3A85, 0x3A85, 0x3E80, 0x3A85, 0x3A85, 0x3A85, + 0x3A85, 0x3A85, 0x3E80, 0x3E80, 0x4606, 0x3A85, 0x5B88, 0x5B88, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x3E80, 0x4606, 0x4606, + 0x5B88, 0x3E80, 0x5B88, 0x5B88, 0x4606, 0x3E80, 0x3E80, 0x3A85, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, + 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x5C09, 0x5C89, 0x5D09, 0x5D89, 0x5E09, 0x5E89, 0x5F09, 0x5F89, 0x6009, + 0x6089, 0x630B, 0x630B, 0x630B, 0x630B, 0x630B, 0x630B, 0x630B, 0x630B, 0x630B, 0x630B, 0x501C, 0x4606, 0x501C, 0x4606, 0x501C, + 0x4606, 0x6615, 0x6696, 0x6615, 0x6696, 0x5B88, 0x5B88, 0x4606, 0x4606, 0x4606, 0x3E80, 0x3E80, 0x3E80, 0x5B88, 0x5B88, 0x3E80, + 0x3E80, 0x5B88, 0x5B88, 0x4606, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x4606, 0x5B88, 0x3E80, 0x3E80, + 0x3E80, 0x3E80, 0x3A85, 0x3A85, 0x3E80, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3E80, 0x3A85, 0x3A85, 0x3E80, 0x5B88, 0x4606, + 0x4606, 0x4606, 0x4606, 0x5B88, 0x4606, 0x3E80, 0x3E80, 0x3E80, 0x4606, 0x4606, 0x5B88, 0x4606, 0x3E80, 0x3E80, 0x3E80, 0x3E80, + 0x3E80, 0x3E80, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, + 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x5B88, 0x5B88, 0x5B88, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, + 0x5B88, 0x5B88, 0x3E80, 0x3E80, 0x3E80, 0x5B88, 0x5B88, 0x5B88, 0x3E80, 0x5B88, 0x5B88, 0x5B88, 0x4606, 0x3E80, 0x3E80, 0x3E80, + 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x5B88, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3A85, + 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3E80, 0x4584, 0x3E80, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x3E80, 0x3E80, 0x5C09, + 0x5C89, 0x5D09, 0x5D89, 0x5E09, 0x5E89, 0x5F09, 0x5F89, 0x6009, 0x6089, 0x3E80, 0x3E80, 0x3A85, 0x3A85, 0x3E80, 0x3E80, 0x3E80, + 0x3E80, 0x5C09, 0x5C89, 0x5D09, 0x5D89, 0x5E09, 0x5E89, 0x5F09, 0x5F89, 0x6009, 0x6089, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, + 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, + 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x5087, 0x5087, 0x5087, 0x5B88, 0x4606, 0x4606, 0x4606, 0x3E80, + 0x3E80, 0x5B88, 0x5B88, 0x5B88, 0x3E80, 0x5B88, 0x5B88, 0x5B88, 0x4606, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, + 0x3E80, 0x3E80, 0x5B88, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, + 0x3A85, 0x3A85, 0x3E80, 0x3E80, 0x3E80, 0x4606, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x5B88, 0x5B88, 0x5B88, 0x4606, 0x4606, 0x4606, + 0x3E80, 0x4606, 0x3E80, 0x5B88, 0x5B88, 0x5B88, 0x5B88, 0x5B88, 0x5B88, 0x5B88, 0x5B88, 0x4606, 0x5B88, 0x5B88, 0x4606, 0x4606, + 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x5198, 0x5198, 0x5198, 0x5198, 0x5198, 0x5198, 0x5198, + 0x39A, 0x5198, 0x3E80, 0x3E80, 0x3E80, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x4584, 0x4606, 0x4606, 0x4606, 0x4606, + 0x4606, 0x4606, 0x4606, 0x4606, 0x5198, 0x5C09, 0x5C89, 0x5D09, 0x5D89, 0x5E09, 0x5E89, 0x5F09, 0x5F89, 0x6009, 0x6089, 0x5198, + 0x5198, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3A85, 0x501C, 0x501C, 0x501C, 0x5198, 0x5198, 0x5198, 0x5198, 0x5198, 0x5198, 0x5198, + 0x5198, 0x65B8, 0x5198, 0x5198, 0x5198, 0x5198, 0x5198, 0x5198, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x4606, 0x4606, 0x501C, + 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x4606, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x3E80, 0x3E80, 0x501C, 0x3E80, + 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x289C, + 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3A85, + 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3E80, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, + 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, + 0x3A85, 0x3A85, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, + 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, + 0x3A85, 0x3A85, 0x1A97, 0x4584, 0x4584, 0x4584, 0x3E80, 0x5C09, 0x5C89, 0x5D09, 0x5D89, 0x5E09, 0x5E89, 0x5F09, 0x5F89, 0x6009, + 0x6089, 0x5198, 0x5198, 0x5198, 0x5198, 0x5198, 0x5198, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x5B88, 0x5B88, 0x4606, + 0x4606, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x20C, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, + 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, + 0x3A85, 0x3A85, 0x6615, 0x6696, 0x3E80, 0x3E80, 0x3E80, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, + 0x3A85, 0x3A85, 0x5198, 0x5198, 0x5198, 0x6B8B, 0x6C0B, 0x6C8B, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, + 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, + 0x4606, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, + 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3001, 0x3082, 0x3001, 0x3082, 0x3001, 0x3082, 0x3001, 0x3082, 0x3001, + 0x3082, 0x3001, 0x3082, 0x3001, 0x3082, 0x3001, 0x3082, 0x3001, 0x3082, 0x3001, 0x3082, 0x3001, 0x3082, 0x2E82, 0x2E82, 0x2E82, + 0x2E82, 0x2E82, 0x6D02, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x6D82, 0x6D82, 0x6D82, 0x6D82, 0x6D82, 0x6D82, 0x6D82, 0x6D82, 0x6E01, + 0x6E01, 0x6E01, 0x6E01, 0x6E01, 0x6E01, 0x6E01, 0x6E01, 0x6D82, 0x6D82, 0x6D82, 0x6D82, 0x6D82, 0x6D82, 0x6D82, 0x6D82, 0x6E01, + 0x6E01, 0x6E01, 0x6E01, 0x6E01, 0x6E01, 0x6E01, 0x6E01, 0x6D82, 0x6D82, 0x6D82, 0x6D82, 0x6D82, 0x6D82, 0x3E80, 0x3E80, 0x6E01, + 0x6E01, 0x6E01, 0x6E01, 0x6E01, 0x6E01, 0x3E80, 0x3E80, 0x2E82, 0x6D82, 0x4902, 0x6D82, 0x4902, 0x6D82, 0x4902, 0x6D82, 0x3E80, + 0x6E01, 0x3E80, 0x6E01, 0x3E80, 0x6E01, 0x3E80, 0x6E01, 0x6D82, 0x6D82, 0x6D82, 0x6D82, 0x6D82, 0x6D82, 0x6D82, 0x6D82, 0x6E01, + 0x6E01, 0x6E01, 0x6E01, 0x6E01, 0x6E01, 0x6E01, 0x6E01, 0x6E82, 0x6E82, 0x6F02, 0x6F02, 0x6F02, 0x6F02, 0x6F82, 0x6F82, 0x7002, + 0x7002, 0x7082, 0x7082, 0x7102, 0x7102, 0x3E80, 0x3E80, 0x7182, 0x7182, 0x7182, 0x7182, 0x7182, 0x7182, 0x7182, 0x7182, 0x7203, + 0x7203, 0x7203, 0x7203, 0x7203, 0x7203, 0x7203, 0x7203, 0x7182, 0x7182, 0x7182, 0x7182, 0x7182, 0x7182, 0x7182, 0x7182, 0x7203, + 0x7203, 0x7203, 0x7203, 0x7203, 0x7203, 0x7203, 0x7203, 0x6D82, 0x6D82, 0x2E82, 0x7282, 0x2E82, 0x3E80, 0x2E82, 0x4902, 0x6E01, + 0x6E01, 0x7301, 0x7301, 0x7383, 0x1A1B, 0x7402, 0x1A1B, 0x1B02, 0x1B82, 0x1C02, 0x1C82, 0x1D02, 0x1D82, 0x1E02, 0x1E82, 0x1F02, + 0x1F82, 0x2002, 0x2082, 0x2102, 0x2182, 0x2202, 0x2282, 0x2302, 0x2382, 0x2402, 0x2482, 0x2502, 0x2582, 0x2602, 0x2682, 0x2702, + 0x2782, 0x6615, 0xC99, 0x6696, 0xC99, 0x3E80, 0x6D82, 0x6D82, 0x4902, 0x4902, 0x2E82, 0x7582, 0x2E82, 0x4902, 0x6E01, 0x6E01, + 0x7601, 0x7601, 0x7681, 0x1A1B, 0x1A1B, 0x1A1B, 0x3E80, 0x3E80, 0x2E82, 0x7282, 0x2E82, 0x3E80, 0x2E82, 0x4902, 0x7701, 0x7701, + 0x7781, 0x7781, 0x7383, 0x1A1B, 0x1A1B, 0x3E80, 0x20C, 0x20C, 0x20C, 0x20C, 0x20C, 0x20C, 0x20C, 0x782C, 0x20C, 0x20C, + 0x20C, 0x788C, 0x5B10, 0x5B10, 0x7910, 0x7990, 0x2A14, 0x7A34, 0x2A14, 0x2A14, 0x2A14, 0x2A14, 0x298, 0x298, 0x7A9D, 0x7B1E, + 0x6615, 0x7A9D, 0x7A9D, 0x7B1E, 0x6615, 0x7A9D, 0x298, 0x298, 0x298, 0x298, 0x298, 0x298, 0x298, 0x298, 0x7B8D, 0x7C0E, + 0x7C90, 0x7D10, 0x7D90, 0x7E10, 0x7E90, 0x782C, 0x318, 0x318, 0x318, 0x318, 0x318, 0x298, 0x298, 0x298, 0x298, 0x29DD, + 0x2D5E, 0x298, 0x298, 0x298, 0x298, 0x1A97, 0x7F0B, 0x2C8B, 0x2B0B, 0x2B8B, 0x7F8B, 0x800B, 0x808B, 0x810B, 0x818B, 0x820B, + 0x519, 0x519, 0xC99, 0x455, 0x4D6, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, + 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, + 0x3A85, 0x3A85, 0x3A85, 0x3E80, 0x3E80, 0x3E80, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, + 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x289C, + 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x4D01, 0x289C, 0x289C, 0x289C, 0x289C, 0x4D01, 0x289C, 0x289C, 0x2902, 0x4D01, + 0x4D01, 0x4D01, 0x2902, 0x2902, 0x4D01, 0x4D01, 0x4D01, 0x2902, 0x289C, 0x4D01, 0x289C, 0x289C, 0x289C, 0x4D01, 0x4D01, 0x4D01, + 0x4D01, 0x4D01, 0x289C, 0x289C, 0xA20A, 0xA28A, 0xA30A, 0xA38A, 0xA40A, 0xA48A, 0xA50A, 0xA58A, 0xA60A, 0x4606, 0x4606, 0x4606, + 0x4606, 0x4606, 0x4606, 0x2A14, 0x4584, 0x4584, 0x4584, 0x4584, 0x4584, 0x289C, 0x289C, 0xA68A, 0xA70A, 0xA78A, 0x3E80, 0x3E80, + 0x3E80, 0x289C, 0x289C, 0x289C, 0x289C, 0x3E80, 0x289C, 0x289C, 0x289C, 0x289C, 0x3E80, 0x3E80, 0x289C, 0x289C, 0x289C, 0x289C, + 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, + 0x289C, 0x289C, 0x289C, 0xC99, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, + 0x289C, 0x289C, 0xC99, 0xC99, 0x289C, 0x289C, 0xC99, 0x289C, 0xC99, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, + 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0xC99, 0x289C, 0x289C, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, + 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x948A, 0x950A, 0x958A, 0x960A, 0x3E80, 0x3E80, 0x3E80, + 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0xC99, 0xC99, 0xC99, 0xC99, 0xC99, 0x289C, 0x289C, + 0x289C, 0x289C, 0x289C, 0xC99, 0xC99, 0x289C, 0x289C, 0x289C, 0x289C, 0x4D01, 0x289C, 0x8281, 0x289C, 0x4D01, 0x289C, 0x8301, + 0x8381, 0x4D01, 0x4D01, 0x2A9C, 0x2902, 0x4D01, 0x4D01, 0x289C, 0x4D01, 0x2902, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x2902, 0x289C, + 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x848A, 0x850A, 0x858A, 0x860A, 0x868A, 0x870A, 0x878A, 0x880A, 0x888A, 0x890A, 0x898A, + 0x8A0A, 0x8A8A, 0x8B0A, 0x8B8A, 0x8C0A, 0x8C8A, 0x8D0A, 0x8D8A, 0x8E0A, 0x8E8A, 0x8F0A, 0x8F8A, 0x900A, 0x908A, 0x910A, 0x918A, + 0x920A, 0x928A, 0x930A, 0x938A, 0x940A, 0xC99, 0xC99, 0xC59, 0xC59, 0xC99, 0xC99, 0xC59, 0xC59, 0xC59, 0xC59, 0xC59, + 0xC59, 0xC59, 0xC59, 0xC59, 0xC59, 0xC59, 0xC59, 0xC59, 0xC59, 0xC59, 0xC59, 0xC59, 0xC59, 0xC59, 0xC99, 0xC99, + 0xC99, 0xC99, 0xC99, 0xC59, 0xC59, 0xC59, 0xC59, 0xC99, 0xC99, 0xC99, 0xC99, 0xC99, 0xC99, 0xC99, 0xC99, 0xC99, + 0xC59, 0xC59, 0xC59, 0xC59, 0xC59, 0xC99, 0xC99, 0xC59, 0xC59, 0xC99, 0xC99, 0xC99, 0xC99, 0xC59, 0xC59, 0xC59, + 0xC59, 0xC59, 0xC59, 0xC59, 0xC59, 0xC59, 0xC59, 0xC59, 0xC59, 0xC59, 0xC99, 0xC99, 0xC59, 0xC59, 0xC59, 0xC59, + 0xC99, 0xC99, 0xC99, 0xC99, 0xC99, 0xC59, 0xC99, 0xC99, 0xC99, 0xC99, 0xC99, 0xC99, 0xC99, 0x289C, 0x289C, 0xC99, + 0x289C, 0x289C, 0xC99, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0xC99, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, + 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, + 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x3E80, 0x289C, 0x289C, 0x289C, 0x289C, + 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, + 0x289C, 0x289C, 0x289C, 0x289C, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, + 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0xC99, 0xC59, 0xC59, + 0xC59, 0xC59, 0xC99, 0xC99, 0xC99, 0xC59, 0xC59, 0xC59, 0xC59, 0xC59, 0xC59, 0xC99, 0xC99, 0xC99, 0xC59, 0x519, + 0x519, 0xC99, 0xC59, 0xC59, 0xC99, 0xC99, 0xC99, 0xC59, 0xC59, 0xC59, 0xC59, 0xC99, 0xC59, 0xC99, 0xC59, 0xC99, + 0xC99, 0xC99, 0xC99, 0xC59, 0xC59, 0xC59, 0xC59, 0xC59, 0xC59, 0xC59, 0xC59, 0xC59, 0xC99, 0xC99, 0xC99, 0xC99, + 0xC99, 0xC59, 0xC99, 0xC59, 0xC59, 0xC59, 0xC59, 0xC59, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x455, + 0x4D6, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x501C, 0x501C, 0x501C, 0x501C, + 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, + 0x501C, 0x501C, 0x501C, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, + 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x9C1C, 0x9C1C, 0x9C1C, + 0x9C1C, 0x9C1C, 0x9C1C, 0x9C1C, 0x9C1C, 0x9C1C, 0x9C1C, 0x9C1C, 0x9C1C, 0x9C1C, 0x9C1C, 0x9C1C, 0x9C1C, 0x9C9C, 0x9C9C, 0x9C9C, + 0x9C9C, 0x9C9C, 0x9C9C, 0x9C9C, 0x9C9C, 0x9C9C, 0x9C9C, 0x9C9C, 0x9C9C, 0x9C9C, 0x9C9C, 0x9C9C, 0x9C9C, 0x7F0B, 0x3E80, 0x3E80, + 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, + 0x3E80, 0x3E80, 0x3E80, 0xC59, 0xC99, 0xC59, 0xC99, 0xC59, 0xC59, 0xC59, 0xC59, 0xC59, 0xC59, 0xC59, 0xC59, 0xC99, + 0xC99, 0xC59, 0xC59, 0xC59, 0xC59, 0xC59, 0xC59, 0xC59, 0xC59, 0xC59, 0xC59, 0xC59, 0xC59, 0xC59, 0xC59, 0xC59, + 0xC59, 0xC59, 0xC59, 0xC99, 0xC99, 0xC59, 0xC59, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, + 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x39A, 0x39A, 0xC99, 0x1A1B, 0x289C, 0x39A, 0x39A, 0x3E80, 0x289C, 0xC99, 0xC99, + 0xC99, 0xC99, 0x289C, 0x289C, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x5B10, 0x5B10, + 0x5B10, 0x289C, 0x289C, 0x3E80, 0x3E80, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, + 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x3E80, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, + 0x289C, 0x289C, 0x289C, 0x289C, 0x3E80, 0x289C, 0x3E80, 0x289C, 0x289C, 0x289C, 0x289C, 0x3E80, 0x3E80, 0x3E80, 0x289C, 0x3E80, + 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, + 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x840B, 0x9D0B, 0x9D8B, 0x9E0B, 0x9E8B, 0x9F0B, 0x9F8B, 0xA00B, 0xA08B, 0xA10B, 0x840B, + 0x9D0B, 0x9D8B, 0x9E0B, 0x9E8B, 0x9F0B, 0x9F8B, 0xA00B, 0xA08B, 0xA10B, 0x289C, 0x3E80, 0x3E80, 0x3E80, 0x289C, 0x289C, 0x289C, + 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0xC59, 0xC59, 0xC59, 0xC59, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, + 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x501C, 0x289C, + 0x289C, 0x289C, 0x289C, 0x289C, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x630B, 0x630B, 0x630B, 0x630B, 0x630B, 0x630B, 0x630B, + 0x630B, 0x630B, 0x630B, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, + 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, + 0x501C, 0x501C, 0x501C, 0x3E80, 0x3E80, 0x3E80, 0x501C, 0x610B, 0x618B, 0x620B, 0x628B, 0xA80B, 0xA88B, 0xA90B, 0xA98B, 0xAA0B, + 0x640B, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, + 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x289C, 0x3E80, 0x289C, 0x289C, + 0x289C, 0x3E80, 0x289C, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, + 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x2C8B, 0x2B0B, 0x2B8B, 0x7F8B, + 0x800B, 0x808B, 0x810B, 0x818B, 0x820B, 0x968B, 0x970B, 0x978B, 0x980B, 0x988B, 0x990B, 0x998B, 0x9A0B, 0x9A8B, 0x9B0B, 0x9B8B, + 0x2C8B, 0x2B0B, 0x2B8B, 0x7F8B, 0x800B, 0x808B, 0x810B, 0x818B, 0x820B, 0x968B, 0x970B, 0x978B, 0x980B, 0x988B, 0x990B, 0x998B, + 0x9A0B, 0x9A8B, 0x9B0B, 0x9B8B, 0x501C, 0x501C, 0x501C, 0x501C, 0x20C, 0x298, 0x298, 0x298, 0x289C, 0x4584, 0x3A85, 0xA18A, + 0x455, 0x4D6, 0x455, 0x4D6, 0x455, 0x4D6, 0x455, 0x4D6, 0x455, 0x4D6, 0x289C, 0x289C, 0x455, 0x4D6, 0x455, 0x4D6, + 0x455, 0x4D6, 0x455, 0x4D6, 0x2A14, 0x6615, 0x6696, 0x6696, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, + 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3E80, 0x3E80, 0x3E80, + 0x3E80, 0x4606, 0x4606, 0x1A1B, 0x1A1B, 0x4584, 0x4584, 0x3E80, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, + 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3E80, 0x501C, 0x501C, 0x630B, 0x630B, 0x630B, 0x630B, 0x501C, 0x501C, + 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x3E80, + 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, + 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0xAA93, 0xAA93, 0xAA93, 0xAA93, 0xAA93, + 0xAA93, 0xAA93, 0xAA93, 0xAA93, 0xAA93, 0xAA93, 0xAA93, 0xAA93, 0xAA93, 0xAA93, 0xAA93, 0xAA93, 0xAA93, 0xAA93, 0xAA93, 0xAA93, + 0xAA93, 0xAA93, 0xAA93, 0xAA93, 0xAA93, 0xAA93, 0xAA93, 0xAA93, 0xAA93, 0xAA93, 0xAA93, 0xAB12, 0xAB12, 0xAB12, 0xAB12, 0xAB12, + 0xAB12, 0xAB12, 0xAB12, 0xAB12, 0xAB12, 0xAB12, 0xAB12, 0xAB12, 0xAB12, 0xAB12, 0xAB12, 0xAB12, 0xAB12, 0xAB12, 0xAB12, 0xAB12, + 0xAB12, 0xAB12, 0xAB12, 0xAB12, 0xAB12, 0xAB12, 0xAB12, 0xAB12, 0xAB12, 0xAB12, 0xAB12, 0x5305, 0x5305, 0x5305, 0x5305, 0x5305, + 0x5305, 0x5305, 0x5305, 0x5305, 0x519, 0x5305, 0x5305, 0x5305, 0x5305, 0x5305, 0x5305, 0x5305, 0x5305, 0x5305, 0x5305, 0x5305, + 0x5305, 0x5305, 0x3E80, 0x5305, 0x5305, 0x5305, 0x5305, 0x5305, 0x3E80, 0x5305, 0x3E80, 0x4606, 0x4606, 0x4606, 0x4606, 0x3E80, + 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x298, 0x2A14, 0x2A14, 0x1A97, 0x1A97, + 0x6615, 0x6696, 0x6615, 0x6696, 0x6615, 0x6696, 0x6615, 0x6696, 0x6615, 0x6696, 0x6615, 0x6696, 0x3E80, 0x3E80, 0x3E80, 0x3E80, + 0x298, 0x298, 0x298, 0x298, 0x1A97, 0x1A97, 0x1A97, 0x598, 0x298, 0x598, 0x3E80, 0x298, 0x598, 0x298, 0x298, 0x2A14, + 0x6615, 0x6696, 0x6615, 0x6696, 0x6615, 0x6696, 0x318, 0x298, 0xD01, 0xD81, 0xE01, 0xE81, 0xF01, 0xF81, 0x1001, 0x1081, + 0x1101, 0x1181, 0x1201, 0x1281, 0x1301, 0x1381, 0x1401, 0x1481, 0x1501, 0x1581, 0x1601, 0x1681, 0x1701, 0x1781, 0x1801, 0x1881, + 0x1901, 0x1981, 0x6615, 0x298, 0x6696, 0x1A1B, 0x1A97, +}; + +static int16_t Upper[] = { + 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, + 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, + 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, + 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0xFFE0, 0xFFE0, 0xFFE0, 0xFFE0, 0xFFE0, 0xFFE0, 0xFFE0, 0xFFE0, 0xFFE0, 0xFFE0, + 0xFFE0, 0xFFE0, 0xFFE0, 0xFFE0, 0xFFE0, 0xFFE0, 0xFFE0, 0xFFE0, 0xFFE0, 0xFFE0, 0xFFE0, 0xFFE0, 0xFFE0, 0xFFE0, 0xFFE0, 0xFFE0, + 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x2E7, 0x0, 0x0, 0x0, 0x0, 0x0, 0xFFE0, 0x79, + 0x0, 0xFFFF, 0x0, 0xFF18, 0x0, 0xFED4, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x61, 0x0, 0x0, + 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x38, 0x0, 0xFFFF, 0xFFFE, 0xFFB1, 0x0, 0x0, 0x0, 0xFF2E, 0xFF32, + 0xFF33, 0xFF36, 0xFF35, 0xFF31, 0xFF2F, 0xFF2D, 0xFF2B, 0xFF2A, 0xFF26, 0xFF27, 0xFF25, 0x0, 0x0, 0x54, 0x0, 0x0, + 0x0, 0x0, 0x0, 0xFFDA, 0xFFDB, 0xFFE1, 0xFFC0, 0xFFC1, 0xFFC2, 0xFFC7, 0x0, 0xFFD1, 0xFFCA, 0xFFAA, 0xFFB0, 0x0, + 0x0, 0x0, 0x0, 0x0, 0xFFD0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, + 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, + 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, + 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0xFFC5, 0x8, 0x0, 0x4A, 0x56, 0x64, + 0x80, 0x70, 0x7E, 0x8, 0x0, 0x9, 0x0, 0x0, 0xE3DB, 0x0, 0x0, 0x7, 0x0, 0x0, 0x0, 0x0, + 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, + 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, + 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0xFFF0, 0xFFF0, 0xFFF0, 0xFFF0, 0xFFF0, 0xFFF0, 0xFFF0, + 0xFFF0, 0xFFF0, 0xFFF0, 0xFFF0, 0xFFF0, 0xFFF0, 0xFFF0, 0xFFF0, 0xFFF0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, + 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0xFFE6, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, + 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, + 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, +}; + +static int16_t Lower[] = { + 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, + 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, + 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, + 0x20, 0x20, 0x20, 0x20, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, + 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, + 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x20, 0x0, 0x0, 0x0, + 0x1, 0x0, 0xFF39, 0x0, 0xFF87, 0x0, 0xD2, 0xCE, 0xCD, 0x4F, 0xCA, 0xCB, 0xCF, 0x0, 0xD3, 0xD1, + 0xD5, 0xD6, 0xDA, 0xD9, 0xDB, 0x0, 0x0, 0x2, 0x1, 0x0, 0x0, 0xFF9F, 0xFFC8, 0x0, 0x0, 0x0, + 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x26, 0x25, + 0x40, 0x3F, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x50, + 0x0, 0x0, 0x30, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, + 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, + 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, + 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0xFFF8, 0x0, 0x0, 0x0, + 0x0, 0x0, 0x0, 0x0, 0xFFF8, 0x0, 0xFFB6, 0xFFF7, 0x0, 0xFFAA, 0xFF9C, 0x0, 0xFF90, 0xFFF9, 0xFF80, 0xFF82, + 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, + 0x0, 0x0, 0x0, 0x0, 0x0, 0xE2A3, 0xDF41, 0xDFBA, 0x0, 0x10, 0x10, 0x10, 0x10, 0x10, 0x10, 0x10, + 0x10, 0x10, 0x10, 0x10, 0x10, 0x10, 0x10, 0x10, 0x10, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, + 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, + 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x1A, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, + 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, + 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, +}; + +static inline int charType(int c) {return Data[Blocks[c>>5]+c & 0xFFFF] & 0x1F;} + +static inline bool isLowc(int c) {return charType(c) == CHAR_LOWERCASE;} +static inline bool isUppc(int c) {return charType(c) == CHAR_UPPERCASE;} + +static inline bool isLetterOrDigit(int c) { + return (1 << charType(c)) & (CHAR_DIGIT | CHAR_LETTER); +} + +static int toUpperCase(int c) { + return c + Upper[Data[Blocks[c>>5]+c & 0xFFFF] >> 7]; +} + +static int toLowerCase(int c) { + return c + Lower[Data[Blocks[c>>5]+c & 0xFFFF] >> 7]; +} + +// (low? 'any) -> sym | NIL +any doLowQ(any x) { + x = cdr(x); + return isSym(x = EVAL(car(x))) && isLowc(symChar(name(x)))? x : Nil; +} + +// (upp? 'any) -> sym | NIL +any doUppQ(any x) { + x = cdr(x); + return isSym(x = EVAL(car(x))) && isUppc(symChar(name(x)))? x : Nil; +} + +// (lowc 'any) -> any +any doLowc(any x) { + int c, i; + any nm; + cell c1, c2; + + x = cdr(x); + if (!isSym(x = EVAL(car(x))) || !(c = symChar(name(x)))) + return x; + Push(c1, x); + Push(c2, boxChar(toLowerCase(c), &i, &nm)); + while (c = symChar(NULL)) + charSym(toLowerCase(c), &i, &nm); + drop(c1); + return consStr(data(c2)); +} + +// (uppc 'any) -> any +any doUppc(any x) { + int c, i; + any nm; + cell c1, c2; + + x = cdr(x); + if (!isSym(x = EVAL(car(x))) || !(c = symChar(name(x)))) + return x; + Push(c1, x); + Push(c2, boxChar(toUpperCase(c), &i, &nm)); + while (c = symChar(NULL)) + charSym(toUpperCase(c), &i, &nm); + drop(c1); + return consStr(data(c2)); +} + +// (fold 'any ['cnt]) -> sym +any doFold(any ex) { + int n, c, i; + any x, nm; + cell c1, c2; + + x = cdr(ex); + if (!isSym(x = EVAL(car(x))) || !(c = symChar(name(x)))) + return Nil; + while (!isLetterOrDigit(c)) + if (!(c = symChar(NULL))) + return Nil; + Push(c1, x); + n = isCell(x = cddr(ex))? evCnt(ex,x) : 24; + Push(c2, boxChar(toLowerCase(c), &i, &nm)); + while (c = symChar(NULL)) + if (isLetterOrDigit(c)) { + if (!--n) + break; + charSym(toLowerCase(c), &i, &nm); + } + drop(c1); + return consStr(data(c2)); +} diff --git a/src/tab.c b/src/tab.c @@ -0,0 +1,410 @@ +/* 14nov09abu + * (c) Software Lab. Alexander Burger + */ + +#include "pico.h" + +typedef struct symInit {fun code; char *name;} symInit; + +static symInit Symbols[] = { + {doAbs, "abs"}, + {doAccept, "accept"}, + {doAdd, "+"}, + {doAlarm, "alarm"}, + {doAll, "all"}, + {doAnd, "and"}, + {doAny, "any"}, + {doAppend, "append"}, + {doApply, "apply"}, + {doArg, "arg"}, + {doArgs, "args"}, + {doArgv, "argv"}, + {doArrow, "->"}, + {doAs, "as"}, + {doAsoq, "asoq"}, + {doAssoc, "assoc"}, + {doAt, "at"}, + {doAtom, "atom"}, + {doBind, "bind"}, + {doBitAnd, "&"}, + {doBitOr, "|"}, + {doBitQ, "bit?"}, + {doBitXor, "x|"}, + {doBool, "bool"}, + {doBox, "box"}, + {doBoxQ, "box?"}, + {doBreak, "!"}, + {doBy, "by"}, + {doBye, "bye"}, + {doCaaaar, "caaaar"}, + {doCaaadr, "caaadr"}, + {doCaaar, "caaar"}, + {doCaadar, "caadar"}, + {doCaaddr, "caaddr"}, + {doCaadr, "caadr"}, + {doCaar, "caar"}, + {doCadaar, "cadaar"}, + {doCadadr, "cadadr"}, + {doCadar, "cadar"}, + {doCaddar, "caddar"}, + {doCadddr, "cadddr"}, + {doCaddr, "caddr"}, + {doCadr, "cadr"}, + {doCall, "call"}, + {doCar, "car"}, + {doCase, "case"}, + {doCatch, "catch"}, + {doCdaaar, "cdaaar"}, + {doCdaadr, "cdaadr"}, + {doCdaar, "cdaar"}, + {doCdadar, "cdadar"}, + {doCdaddr, "cdaddr"}, + {doCdadr, "cdadr"}, + {doCd, "cd"}, + {doCdar, "cdar"}, + {doCddaar, "cddaar"}, + {doCddadr, "cddadr"}, + {doCddar, "cddar"}, + {doCdddar, "cdddar"}, + {doCddddr, "cddddr"}, + {doCdddr, "cdddr"}, + {doCddr, "cddr"}, + {doCdr, "cdr"}, + {doChar, "char"}, + {doChain, "chain"}, + {doChop, "chop"}, + {doCirc, "circ"}, + {doClip, "clip"}, + {doClose, "close"}, + {doCmd, "cmd"}, + {doCnt, "cnt"}, + {doCol, ":"}, + {doCommit, "commit"}, + {doCon, "con"}, + {doConc, "conc"}, + {doCond, "cond"}, + {doConnect, "connect"}, + {doCons, "cons"}, + {doCopy, "copy"}, + {doCtl, "ctl"}, + {doCtty, "ctty"}, + {doCut, "cut"}, + {doDate, "date"}, + {doDbck, "dbck"}, + {doDe, "de"}, + {doDec, "dec"}, + {doDef, "def"}, + {doDefault, "default"}, + {doDel, "del"}, + {doDelete, "delete"}, + {doDelq, "delq"}, + {doDiff, "diff"}, + {doDir, "dir"}, + {doDiv, "/"}, + {doDm, "dm"}, + {doDo, "do"}, + {doE, "e"}, + {doEcho, "echo"}, + {doEnv, "env"}, + {doEof, "eof"}, + {doEol, "eol"}, + {doEq, "=="}, + {doEq0, "=0"}, + {doEqT, "=T"}, + {doEqual, "="}, + {doEval, "eval"}, + {doExt, "ext"}, + {doExtern, "extern"}, + {doExtQ, "ext?"}, + {doExtra, "extra"}, + {doExtract, "extract"}, + {doFifo, "fifo"}, + {doFile, "file"}, + {doFill, "fill"}, + {doFilter, "filter"}, + {doFin, "fin"}, + {doFinally, "finally"}, + {doFind, "find"}, + {doFish, "fish"}, + {doFlgQ, "flg?"}, + {doFlip, "flip"}, + {doFlush, "flush"}, + {doFold, "fold"}, + {doFor, "for"}, + {doFork, "fork"}, + {doFormat, "format"}, + {doFree, "free"}, + {doFrom, "from"}, + {doFull, "full"}, + {doFunQ, "fun?"}, + {doGc, "gc"}, + {doGe, ">="}, + {doGe0, "ge0"}, + {doGet, "get"}, + {doGetd, "getd"}, + {doGetl, "getl"}, + {doGlue, "glue"}, + {doGt, ">"}, + {doGt0, "gt0"}, + {doHead, "head"}, + {doHeap, "heap"}, + {doHear, "hear"}, + {doHide, "===="}, + {doHost, "host"}, + {doId, "id"}, + {doIdx, "idx"}, + {doIf, "if"}, + {doIf2, "if2"}, + {doIfn, "ifn"}, + {doIn, "in"}, + {doInc, "inc"}, + {doIndex, "index"}, + {doInfo, "info"}, + {doIntern, "intern"}, + {doIpid, "ipid"}, + {doIsa, "isa"}, + {doJob, "job"}, + {doJournal, "journal"}, + {doKey, "key"}, + {doKill, "kill"}, + {doLast, "last"}, + {doLe, "<="}, + {doLength, "length"}, + {doLet, "let"}, + {doLetQ, "let?"}, + {doLieu, "lieu"}, + {doLine, "line"}, + {doLines, "lines"}, + {doLink, "link"}, + {doList, "list"}, + {doListen, "listen"}, + {doLit, "lit"}, + {doLstQ, "lst?"}, + {doLoad, "load"}, + {doLock, "lock"}, + {doLoop, "loop"}, + {doLowQ, "low?"}, + {doLowc, "lowc"}, + {doLt, "<"}, + {doLt0, "lt0"}, + {doLup, "lup"}, + {doMade, "made"}, + {doMake, "make"}, + {doMap, "map"}, + {doMapc, "mapc"}, + {doMapcan, "mapcan"}, + {doMapcar, "mapcar"}, + {doMapcon, "mapcon"}, + {doMaplist, "maplist"}, + {doMaps, "maps"}, + {doMark, "mark"}, + {doMatch, "match"}, + {doMax, "max"}, + {doMaxi, "maxi"}, + {doMember, "member"}, + {doMemq, "memq"}, + {doMeta, "meta"}, + {doMethod, "method"}, + {doMin, "min"}, + {doMini, "mini"}, + {doMix, "mix"}, + {doMmeq, "mmeq"}, + {doMul, "*"}, + {doMulDiv, "*/"}, + {doName, "name"}, + {doNand, "nand"}, + {doNEq, "n=="}, + {doNEq0, "n0"}, + {doNEqT, "nT"}, + {doNEqual, "<>"}, + {doNeed, "need"}, + {doNew, "new"}, + {doNext, "next"}, + {doNil, "nil"}, + {doNond, "nond"}, + {doNor, "nor"}, + {doNot, "not"}, + {doNth, "nth"}, + {doNumQ, "num?"}, + {doOff, "off"}, + {doOffset, "offset"}, + {doOn, "on"}, + {doOne, "one"}, + {doOnOff, "onOff"}, + {doOpen, "open"}, + {doOpid, "opid"}, + {doOpt, "opt"}, + {doOr, "or"}, + {doOut, "out"}, + {doPack, "pack"}, + {doPair, "pair"}, + {doPass, "pass"}, + {doPath, "path"}, + {doPatQ, "pat?"}, + {doPeek, "peek"}, + {doPid, "pid"}, + {doPick, "pick"}, + {doPipe, "pipe"}, + {doPoll, "poll"}, + {doPool, "pool"}, + {doPop, "pop"}, + {doPort, "port"}, + {doPr, "pr"}, + {doPreQ, "pre?"}, + {doPrin, "prin"}, + {doPrinl, "prinl"}, + {doPrint, "print"}, + {doPrintln, "println"}, + {doPrintsp, "printsp"}, + {doProg, "prog"}, + {doProg1, "prog1"}, + {doProg2, "prog2"}, + {doProp, "prop"}, + {doPropCol, "::"}, + {doProtect, "protect"}, + {doProve, "prove"}, + {doPush, "push"}, + {doPush1, "push1"}, + {doPut, "put"}, + {doPutl, "putl"}, + {doPwd, "pwd"}, + {doQueue, "queue"}, + {doQuit, "quit"}, + {doRand, "rand"}, + {doRange, "range"}, + {doRank, "rank"}, + {doRaw, "raw"}, + {doRd, "rd"}, + {doRead, "read"}, + {doRem, "%"}, + {doReplace, "replace"}, + {doRest, "rest"}, + {doReverse, "reverse"}, + {doRewind, "rewind"}, + {doRollback, "rollback"}, + {doRot, "rot"}, + {doRpc, "rpc"}, + {doRun, "run"}, + {doSect, "sect"}, + {doSeed, "seed"}, + {doSeek, "seek"}, + {doSemicol, ";"}, + {doSend, "send"}, + {doSeq, "seq"}, + {doSet, "set"}, + {doSetCol, "=:"}, + {doSetq, "setq"}, + {doShift, ">>"}, + {doSize, "size"}, + {doSkip, "skip"}, + {doSort, "sort"}, + {doSpace, "space"}, + {doSplit, "split"}, + {doSpQ, "sp?"}, + {doState, "state"}, + {doStem, "stem"}, + {doStr, "str"}, + {doStrip, "strip"}, + {doStrQ, "str?"}, + {doSub, "-"}, + {doSubQ, "sub?"}, + {doSum, "sum"}, + {doSuper, "super"}, + {doSym, "sym"}, + {doSymQ, "sym?"}, + {doSync, "sync"}, + {doSys, "sys"}, + {doT, "t"}, + {doTail, "tail"}, + {doTell, "tell"}, + {doText, "text"}, + {doThrow, "throw"}, + {doTick, "tick"}, + {doTill, "till"}, + {doTime, "time"}, + {doTouch, "touch"}, + {doTrace, "$"}, + {doTrim, "trim"}, + {doTry, "try"}, + {doType, "type"}, + {doUdp, "udp"}, + {doUnify, "unify"}, + {doUnless, "unless"}, + {doUntil, "until"}, + {doUp, "up"}, + {doUppQ, "upp?"}, + {doUppc, "uppc"}, + {doUse, "use"}, + {doUsec, "usec"}, + {doVal, "val"}, + {doWait, "wait"}, + {doWhen, "when"}, + {doWhile, "while"}, + {doWipe, "wipe"}, + {doWith, "with"}, + {doWr, "wr"}, + {doXchg, "xchg"}, + {doXor, "xor"}, + {doYoke, "yoke"}, + {doZap, "zap"}, + {doZero, "zero"}, +}; + +static any initSym(any v, char *s) { + any x, *h; + + h = Intern + ihash(x = mkName(s)); + x = consSym(v,x); + *h = cons(x,*h); + return x; +} + +void initSymbols(void) { + int i; + + Nil = symPtr(Avail), Avail = Avail->car->car; // Allocate 2 cells for NIL + val(Nil) = tail(Nil) = val(Nil+1) = tail(Nil+1) = Nil; + Zero = box(0); + One = box(2); + for (i = 0; i < IHASH; ++i) + Intern[i] = Transient[i] = Nil; + for (i = 0; i < EHASH; ++i) + Extern[i] = Nil; + initSym(mkStr(_OS), "*OS"); + DB = initSym(Nil, "*DB"); + Meth = initSym(box(num(doMeth)), "meth"); + Quote = initSym(box(num(doQuote)), "quote"); + T = initSym(Nil, "T"), val(T) = T; // Last protected symbol + + mkExt(val(DB) = DbVal = consStr(DbTail = box('1'))); + Extern['1'] = cons(DbVal, Nil); + + Solo = initSym(Zero, "*Solo"); + PPid = initSym(Nil, "*PPid"); + Pid = initSym(boxCnt(getpid()), "*Pid"); + At = initSym(Nil, "@"); + At2 = initSym(Nil, "@@"); + At3 = initSym(Nil, "@@@"); + This = initSym(Nil, "This"); + Dbg = initSym(Nil, "*Dbg"); + Zap = initSym(Nil, "*Zap"); + Ext = initSym(Nil, "*Ext"); + Scl = initSym(Zero, "*Scl"); + Class = initSym(Nil, "*Class"); + Run = initSym(Nil, "*Run"); + Hup = initSym(Nil, "*Hup"); + Sig1 = initSym(Nil, "*Sig1"); + Sig2 = initSym(Nil, "*Sig2"); + Up = initSym(Nil, "^"); + Err = initSym(Nil, "*Err"); + Msg = initSym(Nil, "*Msg"); + Uni = initSym(Nil, "*Uni"); + Led = initSym(Nil, "*Led"); + Tsm = initSym(Nil, "*Tsm"); + Adr = initSym(Nil, "*Adr"); + Fork = initSym(Nil, "*Fork"); + Bye = initSym(Nil, "*Bye"); // Last unremovable symbol + + for (i = 0; i < (int)(sizeof(Symbols)/sizeof(symInit)); ++i) + initSym(box(num(Symbols[i].code)), Symbols[i].name); +} diff --git a/src/utf2.c b/src/utf2.c @@ -0,0 +1,68 @@ +/* utf2.c + * 31mar05abu + * Convert process or file (ISO-8859-15) to stdout (UTF-8, 2-Byte) + */ + +#include <stdio.h> +#include <stdlib.h> +#include <unistd.h> +#include <errno.h> +#include <signal.h> +#include <sys/wait.h> + +// utf2 [-<cmd> [<arg> ..]] +// utf2 [<Infile/ISO-8859-15>] +int main(int ac, char *av[]) { + int c; + pid_t pid = 0; + FILE *fp = stdin; + + if (ac > 1) { + if (*av[1] == '-') { + int pfd[2]; + + if (pipe(pfd) < 0) { + fprintf(stderr, "utf2: Pipe error\n"); + return 1; + } + if ((pid = fork()) == 0) { + close(pfd[0]); + if (pfd[1] != STDOUT_FILENO) + dup2(pfd[1], STDOUT_FILENO), close(pfd[1]); + execvp(av[1]+1, av+1); + } + if (pid < 0) { + fprintf(stderr, "utf2: Fork error\n"); + return 1; + } + close(pfd[1]); + if (!(fp = fdopen(pfd[0], "r"))) { + fprintf(stderr, "utf2: Pipe open error\n"); + return 1; + } + } + else if (!(fp = fopen(av[1], "r"))) { + fprintf(stderr, "utf2: '%s' open error\n", av[1]); + return 1; + } + } + while ((c = getc_unlocked(fp)) != EOF) { + if (c == 0xA4) + putchar_unlocked(0xE2), putchar_unlocked(0x82), putchar_unlocked(0xAC); + else if (c >= 0x80) { + putchar_unlocked(0xC0 | c>>6 & 0x1F); + putchar_unlocked(0x80 | c & 0x3F); + } + else + putchar_unlocked(c); + } + if (pid) { + fclose(fp); + while (waitpid(pid, NULL, 0) < 0) + if (errno != EINTR) { + fprintf(stderr, "utf2: Pipe close error\n"); + return 1; + } + } + return 0; +} diff --git a/src/z3d.c b/src/z3d.c @@ -0,0 +1,468 @@ +/* 22apr08abu + * (c) Software Lab. Alexander Burger + */ + +#include "pico.h" + +#define SCL 1000000.0 + +typedef struct {double x, y, z;} vector; +typedef struct {vector a, b, c;} matrix; + +static bool Snap; +static int SnapD, Snap1h, Snap1v, Snap2h, Snap2v; +static double FocLen, PosX, PosY, PosZ, Pos6, Pos9, SnapX, SnapY, SnapZ; +static double Coeff1, Coeff2, Coeff4, Coeff5, Coeff6, Coeff7, Coeff8, Coeff9; + + +static any getVector(any lst, vector *dst) { + dst->x = numToDouble(car(lst)) / SCL, lst = cdr(lst); + dst->y = numToDouble(car(lst)) / SCL, lst = cdr(lst); + dst->z = numToDouble(car(lst)) / SCL; + return cdr(lst); +} + +static any putVector(vector *src, any lst) { + car(lst) = doubleToNum(src->x * SCL), lst = cdr(lst); + car(lst) = doubleToNum(src->y * SCL), lst = cdr(lst); + car(lst) = doubleToNum(src->z * SCL); + return cdr(lst); +} + +static any getMatrix(any lst, matrix *dst) { + return getVector(getVector(getVector(lst, &dst->a), &dst->b), &dst->c); +} + +static any putMatrix(matrix *src, any lst) { + return putVector(&src->c, putVector(&src->b, putVector(&src->a, lst))); +} + +static void xrot(matrix *p, double ca, double sa) { + matrix m = *p; + + p->b.x = ca * m.b.x - sa * m.c.x; + p->b.y = ca * m.b.y - sa * m.c.y; + p->b.z = ca * m.b.z - sa * m.c.z; + p->c.x = sa * m.b.x + ca * m.c.x; + p->c.y = sa * m.b.y + ca * m.c.y; + p->c.z = sa * m.b.z + ca * m.c.z; +} + +// (z3d:Xrot 'angle 'model) -> T +any Xrot(any ex) { + any x; + double a; + matrix m; + + a = evDouble(ex, x = cdr(ex)) / SCL; + x = EVAL(cadr(x)); + Touch(ex,x); + x = cdddr(val(x)); + getMatrix(x, &m), xrot(&m, cos(a), sin(a)), putMatrix(&m, x); + return T; +} + +static void yrot(matrix *p, double ca, double sa) { + matrix m = *p; + + p->a.x = ca * m.a.x + sa * m.c.x; + p->a.y = ca * m.a.y + sa * m.c.y; + p->a.z = ca * m.a.z + sa * m.c.z; + p->c.x = ca * m.c.x - sa * m.a.x; + p->c.y = ca * m.c.y - sa * m.a.y; + p->c.z = ca * m.c.z - sa * m.a.z; +} + +// (z3d:Yrot 'angle 'model) -> T +any Yrot(any ex) { + any x; + double a; + matrix m; + + a = evDouble(ex, x = cdr(ex)) / SCL; + x = EVAL(cadr(x)); + Touch(ex,x); + x = cdddr(val(x)); + getMatrix(x, &m), yrot(&m, cos(a), sin(a)), putMatrix(&m, x); + return T; +} + +static void zrot(matrix *p, double ca, double sa) { + matrix m = *p; + + p->a.x = ca * m.a.x + sa * m.b.x; + p->a.y = ca * m.a.y + sa * m.b.y; + p->a.z = ca * m.a.z + sa * m.b.z; + p->b.x = ca * m.b.x - sa * m.a.x; + p->b.y = ca * m.b.y - sa * m.a.y; + p->b.z = ca * m.b.z - sa * m.a.z; +} + +// (z3d:Zrot 'angle 'model) -> T +any Zrot(any ex) { + any x; + double a; + matrix m; + + a = evDouble(ex, x = cdr(ex)) / SCL; + x = EVAL(cadr(x)); + Touch(ex,x); + x = cdddr(val(x)); + getMatrix(x, &m), zrot(&m, cos(a), sin(a)), putMatrix(&m, x); + return T; +} + +// (z3d:Arot 'angle 'model) -> T +any Arot(any ex) { + any x; + double a, n; + matrix m; + vector pt; + + a = evDouble(ex, x = cdr(ex)) / SCL; + x = EVAL(cadr(x)); + Touch(ex,x); + x = cdddr(val(x)); + getVector(cddar(getMatrix(x, &m)), &pt); + n = sqrt(pt.x*pt.x + pt.y*pt.y + pt.z*pt.z); + pt.x /= n, pt.y /= n, pt.z /= n; // Axis unit vector + if ((n = sqrt(pt.y*pt.y + pt.z*pt.z)) == 0.0) // Axis parallel to x-axis + a *= pt.x, xrot(&m, cos(a), sin(a)); + else { + xrot(&m, pt.z/n, -pt.y/n); + yrot(&m, n, pt.x); + zrot(&m, cos(a), sin(a)); + yrot(&m, n, -pt.x); + xrot(&m, pt.z/n, pt.y/n); + } + putMatrix(&m, x); + return T; +} + +// (z3d:Rotate 'X 'Y 'Z 'model 'varX 'varY 'varZ ['flg]) -> T +any Rotate(any ex) { + any x; + double vx, vy, vz; + matrix m; + cell c1, c2, c3; + + vx = evDouble(ex, x = cdr(ex)) / SCL; + vy = evDouble(ex, x = cdr(x)) / SCL; + vz = evDouble(ex, x = cdr(x)) / SCL; + x = cdr(x), getMatrix(cdddr(val(EVAL(car(x)))), &m); + x = cdr(x), Push(c1, EVAL(car(x))); + NeedVar(ex,data(c1)); + x = cdr(x), Push(c2, EVAL(car(x))); + NeedVar(ex,data(c2)); + x = cdr(x), Push(c3, EVAL(car(x))); + NeedVar(ex,data(c3)); + if (isNil(EVAL(cadr(x)))) { + if (!isNil(data(c1))) + val(data(c1)) = doubleToNum((vx * m.a.x + vy * m.b.x + vz * m.c.x) * SCL); + if (!isNil(data(c2))) + val(data(c2)) = doubleToNum((vx * m.a.y + vy * m.b.y + vz * m.c.y) * SCL); + if (!isNil(data(c3))) + val(data(c3)) = doubleToNum((vx * m.a.z + vy * m.b.z + vz * m.c.z) * SCL); + } + else { + if (!isNil(data(c1))) + val(data(c1)) = doubleToNum((vx * m.a.x + vy * m.a.y + vz * m.a.z) * SCL); + if (!isNil(data(c2))) + val(data(c2)) = doubleToNum((vx * m.b.x + vy * m.b.y + vz * m.b.z) * SCL); + if (!isNil(data(c3))) + val(data(c3)) = doubleToNum((vx * m.c.x + vy * m.c.y + vz * m.c.z) * SCL); + } + drop(c1); + return T; +} + +static void _approach(any ex, double d, any dst, any src) { + any l1, l2; + int i; + double n; + + Touch(ex,dst); + l1 = val(dst); + Fetch(ex,src); + l2 = val(src); + for (i = 0; i < 12; ++i) { + n = numToDouble(car(l1)) / SCL; + car(l1) = doubleToNum((n + d * (numToDouble(car(l2)) / SCL - n)) * SCL); + l1 = cdr(l1), l2 = cdr(l2); + } + do { + while (!isSym(car(l1))) + if (!isCell(l1 = cdr(l1))) + return; + while (!isSym(car(l2))) + if (!isCell(l2 = cdr(l2))) + return; + _approach(ex, d, car(l1), car(l2)); + } while (isCell(l1 = cdr(l1)) && isCell(l2 = cdr(l2))); +} + +// (z3d:Approach 'num 'model 'model) -> T +any Approach(any ex) { + any x; + long n; + cell c1, c2; + + n = evCnt(ex, x = cdr(ex)); + x = cdr(x), Push(c1, EVAL(car(x))); + x = cdr(x), Push(c2, EVAL(car(x))); + _approach(ex, 1.0 / (double)n, data(c1), data(c2)); + drop(c1); + return T; +} + +// (z3d:Spot 'dx 'dy 'dz ['x 'y 'z]) -> (yaw . pitch) +any Spot(any ex) { + any x; + double dx, dy, dz; + cell c1; + + dx = evDouble(ex, x = cdr(ex)) / SCL; + dy = evDouble(ex, x = cdr(x)) / SCL; + dz = evDouble(ex, x = cdr(x)) / SCL; + + if (isCell(x = cdr(x))) { + dx -= evDouble(ex, x) / SCL; + dy -= evDouble(ex, x = cdr(x)) / SCL; + dz -= evDouble(ex, x = cdr(x)) / SCL; + } + + Push(c1, doubleToNum(atan2(dy,dx) * SCL)); + dx = sqrt(dx*dx + dy*dy + dz*dz); + data(c1) = cons(data(c1), doubleToNum(dx==0.0? 0.0 : asin(dz/dx)*SCL)); + return Pop(c1); +} + +static void rotate(vector *src, matrix *p, vector *dst) { + dst->x = src->x * p->a.x + src->y * p->b.x + src->z * p->c.x; + dst->y = src->x * p->a.y + src->y * p->b.y + src->z * p->c.y; + dst->z = src->x * p->a.z + src->y * p->b.z + src->z * p->c.z; +} + +#if 0 +/* (lst -- x y z) */ +void Locate(void) { + any lst; + vector pos, v, w; + matrix rot, r; + + lst = Tos; + getMatrix(getVector(car(lst), &pos), &rot); + while (isCell(lst = cdr(lst))) { + getMatrix(getVector(car(lst), &v), &r); + rotate(&v, &rot, &w); + pos.x += w.x, pos.y += w.y, pos.z += w.z; + v = r.a, rotate(&v, &rot, &r.a); + v = r.b, rotate(&v, &rot, &r.b); + v = r.c, rotate(&v, &rot, &r.c); + rot = r; + } + Tos = doubleToNum(pos.x) * SCL; + push(doubleToNum(pos.y)) * SCL; + push(doubleToNum(pos.z)) * SCL; +} +#endif + +static void shadowPt(double vx, double vy) { + double z; + + z = Coeff7 * vx + Coeff8 * vy - Pos9; + prn((int)(FocLen * (Coeff1 * vx + Coeff2 * vy) / z)); + prn((int)(FocLen * (Coeff4 * vx + Coeff5 * vy - Pos6) / z)); + prn(num(1000.0 * z)); +} + +static void transPt(double vx, double vy, double vz) { + double x, y, z; + int h, v, dh, dv, d; + + x = Coeff1 * vx + Coeff2 * vy; + y = Coeff4 * vx + Coeff5 * vy + Coeff6 * vz; + z = Coeff7 * vx + Coeff8 * vy + Coeff9 * vz; + prn(h = (int)(FocLen * x/z)); + prn(v = (int)(FocLen * y/z)); + prn(num(1000.0 * z)); + if (Snap) { + if ((dh = h - Snap1h) < 0) + dh = -dh; + if ((dv = v - Snap1v) < 0) + dv = -dv; + if ((d = dh>dv? dh+dv*41/100-dh/24 : dv+dh*41/100-dv/24) < SnapD) { + SnapD = d; + Snap2h = h; Snap2v = v; + SnapX = vx; SnapY = vy; SnapZ = vz; + } + } +} + +static void doDraw(any ex, any mdl, matrix *r, double x, double y, double z) { + any face, c1, c2, txt; + long n, pix; + double dx, dy, dz; + vector pos, pt1, pt2, pt3, v, w, nv; + matrix rot; + + Fetch(ex,mdl); + mdl = getMatrix(getVector(val(mdl), &pos), &rot); + if (!r) + r = &rot; + else { + v = pos, rotate(&v, r, &pos); + pos.x += x, pos.y += y, pos.z += z; + v = rot.a, rotate(&v, r, &rot.a); + v = rot.b, rotate(&v, r, &rot.b); + v = rot.c, rotate(&v, r, &rot.c); + } + dx = pos.x - PosX; + dy = pos.y - PosY; + dz = pos.z - PosZ; + + if ((z = Coeff7*dx + Coeff8*dy + Coeff9*dz) < 0.1) + return; + if (z < fabs(Coeff1*dx + Coeff2*dy)) + return; + if (z < fabs(Coeff4*dx + Coeff5*dy + Coeff6*dz)) + return; + + while (isCell(mdl)) { + face = car(mdl), mdl = cdr(mdl); + if (isSym(face)) + doDraw(ex, face, &rot, pos.x, pos.y, pos.z); + else { + c1 = car(face), face = cdr(face); + c2 = car(face), face = cdr(face); + if (!isSym(car(face))) + txt = Nil; + else + txt = car(face), face = cdr(face); + face = getVector(getVector(face, &v), &w); + if ((v.x || v.y || v.z) && (w.x || w.y || w.z)) + r = &rot, rotate(&v, r, &pt1), rotate(&w, r, &pt2); + else + rotate(&v, r, &pt1), rotate(&w, r, &pt2), r = &rot; + face = getVector(face, &v), rotate(&v, r, &pt3); + if (c2 == T) { + n = length(face) / 3; + prn(n+2); + shadowPt(pt1.x + dx + pt1.z + pos.z, pt1.y + dy); + pr(0,txt); + shadowPt(pt2.x + dx + pt2.z + pos.z, pt2.y + dy); + shadowPt(pt3.x + dx + pt3.z + pos.z, pt3.y + dy); + while (--n >= 0) { + face = getVector(face, &v), rotate(&v, r, &pt1); + shadowPt(pt1.x + dx + pt1.z + pos.z, pt1.y + dy); + } + prn(0); + } + else { + v.x = pt1.x - pt2.x; + v.y = pt1.y - pt2.y; + v.z = pt1.z - pt2.z; + w.x = pt3.x - pt2.x; + w.y = pt3.y - pt2.y; + w.z = pt3.z - pt2.z; + nv.x = v.y * w.z - v.z * w.y; + nv.y = v.z * w.x - v.x * w.z; + nv.z = v.x * w.y - v.y * w.x; + pt1.x += dx, pt1.y += dy, pt1.z += dz; + if (isNil(c1) && isNil(c2)) + pix = -1; // Transparent + else { + if (pt1.x * nv.x + pt1.y * nv.y + pt1.z * nv.z >= 0.0) { + if (isNil(c1)) + continue; // Backface culling + pix = unDig(c1) / 2; + n = 80 - num(14.14 * (nv.z-nv.x) / sqrt(nv.x*nv.x + nv.y*nv.y + nv.z*nv.z)); + } + else { + if (isNil(c2)) + continue; // Backface culling + pix = unDig(c2) / 2; + n = 80 + num(14.14 * (nv.z-nv.x) / sqrt(nv.x*nv.x + nv.y*nv.y + nv.z*nv.z)); + } + pix = ((pix >> 16) & 255) * n / 100 << 16 | + ((pix >> 8) & 255) * n / 100 << 8 | (pix & 255) * n / 100; + } + n = length(face) / 3; + prn(n+2); + transPt(pt1.x, pt1.y, pt1.z); + pr(0,txt); + transPt(pt2.x + dx, pt2.y + dy, pt2.z + dz); + transPt(pt3.x + dx, pt3.y + dy, pt3.z + dz); + while (--n >= 0) { + face = getVector(face, &v), rotate(&v, r, &pt1); + transPt(pt1.x + dx, pt1.y + dy, pt1.z + dz); + } + prn(pix); + } + } + } +} + +// (z3d:Draw 'foc 'yaw 'pitch 'x 'y 'z 'sky 'gnd ['h 'v]) -> NIL +// (z3d:Draw 'sym) -> NIL +// (z3d:Draw 'NIL) -> lst +any Draw(any ex) { + any x, y; + double a, sinY, cosY, sinP, cosP; + + x = cdr(ex); + if (isNil(y = EVAL(car(x)))) { + cell c1; + + prn(0); + if (!Snap) { + prn(32767); + return Nil; + } + prn(Snap2h), prn(Snap2v); + Push(c1, doubleToNum(SnapZ * SCL)); + data(c1) = cons(doubleToNum(SnapY * SCL), data(c1)); + data(c1) = cons(doubleToNum(SnapX * SCL), data(c1)); + return Pop(c1); + } + if (isSym(y)) { + doDraw(ex, y, NULL, 0.0, 0.0, 0.0); + return Nil; + } + FocLen = numToDouble(y) / SCL; + a = evDouble(ex, x = cdr(x)) / SCL, sinY = sin(a), cosY = cos(a); + a = evDouble(ex, x = cdr(x)) / SCL, sinP = sin(a), cosP = cos(a); + PosX = evDouble(ex, x = cdr(x)) / SCL; + PosY = evDouble(ex, x = cdr(x)) / SCL; + PosZ = evDouble(ex, x = cdr(x)) / SCL; + + Coeff1 = -sinY; + Coeff2 = cosY; + Coeff4 = cosY * sinP; + Coeff5 = sinY * sinP; + Coeff6 = -cosP; + Coeff7 = cosY * cosP; + Coeff8 = sinY * cosP; + Coeff9 = sinP; + + Pos6 = Coeff6 * PosZ; + Pos9 = Coeff9 * PosZ; + + if (cosP == 0.0) + prn(sinP > 0.0? +16383 : -16384); + else if ((a = FocLen * sinP/cosP) > +16383.0) + prn(+16383); + else if (a < -16384.0) + prn(-16384); + else + prn(num(a)); + prn(evCnt(ex, x = cdr(x))); + prn(evCnt(ex, x = cdr(x))); + x = cdr(x); + if (Snap = !isNil(y = EVAL(car(x)))) { + SnapD = 32767; + Snap1h = (int)xCnt(ex,y); + Snap1v = (int)evCnt(ex,cdr(x)); + } + return Nil; +} diff --git a/src/z3dClient.c b/src/z3dClient.c @@ -0,0 +1,532 @@ +/* 12nov09abu + * (c) Software Lab. Alexander Burger + */ + +#include <stdio.h> +#include <stdlib.h> +#include <sys/time.h> +#include <unistd.h> +#include <string.h> +#include <errno.h> + +#include <netdb.h> +#include <sys/socket.h> +#include <netinet/in.h> +#include <arpa/inet.h> + +#include <X11/Xlib.h> +#include <X11/Xutil.h> +#include <sys/shm.h> +#include <X11/extensions/XShm.h> + + +typedef unsigned char byte; +typedef struct {long h[2]; unsigned long z[2];} edge; + +/* Globals */ +static int Socket; +static Display *Disp; +static int Scrn; +static int Dpth; +static int PixSize; +static Colormap Cmap; +static GC Gc; +static Window Win; +static long long Tim; + +/* 3D-Environment */ +static int SizX, SizY, OrgX, OrgY, SnapX, SnapY; +static unsigned long *Zbuff; +static edge *Edges; +static XImage *Img; +static XShmSegmentInfo Info; + + +/* Error exit */ +static void giveup(char *msg) { + fprintf(stderr, "z3dClient: %s\r\n", msg); + exit(1); +} + +/* Memory allocation */ +void *alloc(long siz) { + void *p; + + if (!(p = malloc(siz))) + giveup("No memory"); + return p; +} + +static void paint(void) { + XEvent ev; + + while (XCheckTypedEvent(Disp, Expose, &ev)); + XShmPutImage(Disp, Win, Gc, Img, 0, 0, 0, 0, SizX, SizY, False); + if (SnapX != 32767) { + XSetFunction(Disp, Gc, GXinvert); + XFillRectangle(Disp, Win, Gc, OrgX+SnapX-3, OrgY+SnapY-3, 6, 6); + XSetFunction(Disp, Gc, GXcopy); + } + XSync(Disp,False); +} + +static void prLong(long n) { + int i; + char buf[8]; + + n = n >= 0? n * 2 : -n * 2 + 1; + if ((n & 0xFFFFFF00) == 0) + i = 2, buf[0] = 1*4, buf[1] = n; + else if ((n & 0xFFFF0000) == 0) + i = 3, buf[0] = 2*4, buf[1] = n, buf[2] = n>>8; + else if ((n & 0xFF000000) == 0) + i = 4, buf[0] = 3*4, buf[1] = n, buf[2] = n>>8, buf[3] = n>>16; + else + i = 5, buf[0] = 4*4, buf[1] = n, buf[2] = n>>8, buf[3] = n>>16, buf[4] = n>>24; + if (write(Socket, buf, i) <= 0) + giveup("Socket write error"); +} + + +static byte get1(void) { + static int n, cnt; + static byte buf[1024]; + + while (n == cnt) { + int fd; + fd_set fdSet; + + fd = ConnectionNumber(Disp); + FD_ZERO(&fdSet); + FD_SET(fd, &fdSet); + FD_SET(Socket, &fdSet); + while (select((fd > Socket? fd : Socket) + 1, &fdSet, NULL,NULL,NULL) < 0) + if (errno != EINTR) + giveup("Select error"); + if (FD_ISSET(fd, &fdSet)) { + XEvent ev; + + XNextEvent(Disp, &ev); + switch (ev.type) { + case Expose: + paint(); + break; + case KeyPress: + if (((XKeyEvent*)&ev)->state == 37) // Ctrl-Key + printf("Ok\n"); //#? + break; + case KeyRelease: + break; + case ButtonPress: + prLong('c'); // clk + prLong(((XButtonEvent*)&ev)->x - OrgX); + prLong(((XButtonEvent*)&ev)->y - OrgY); + break; + case MotionNotify: //#? + break; + } + } + if (FD_ISSET(Socket, &fdSet)) { + while ((cnt = read(Socket, buf, sizeof(buf))) < 0) + if (errno != EINTR) + giveup("Socket read error"); + if (cnt == 0) + exit(0); + n = 0; + } + } + return buf[n++]; +} + +static long getNum(void) { + int cnt = get1() / 4; + long n = get1(); + int i = 0; + + while (--cnt) + n |= get1() << (i += 8); + if (n & 1) + n = -n; + return n / 2; +} + +static void skipStr(void) { + int cnt = get1() / 4; + while (--cnt >= 0) + get1(); +} + +static long getColor(long c) { + XColor col; + + col.red = c >> 8 & 0xFF00; + col.green = c & 0xFF00; + col.blue = (c & 0xFF) << 8; + col.flags = DoRed | DoGreen | DoBlue; + if (!XAllocColor(Disp, Cmap, &col)) + giveup("Can't allocate color"); + return col.pixel; +} + +static void mkEdge(int x1, int y1, int z1, int x2, int y2, int z2) { + int a, dx, dy, dz, sx, xd, xe, sz, zd, ze; + edge *p; + + if (y2 < y1) { + a = x1, x1 = x2, x2 = a; + a = y1, y1 = y2, y2 = a; + a = z1, z1 = z2, z2 = a; + } + if (y1 > OrgY || ((y2 += OrgY) <= 0)) + return; + if ((dy = y2 - (y1 += OrgY)) == 0) + return; + dx = x2 - x1, dz = z2 - z1; + if (y1 < 0) { + x1 += -y1 * dx / dy; + z1 += -y1 * dz / dy; + y1 = 0; + if ((dy = y2) == 0) + return; + dx = x2 - x1, dz = z2 - z1; + } + if (y2 > SizY) { + x2 += (SizY - y2) * dx / dy; + z2 += (SizY - y2) * dz / dy; + y2 = SizY; + if ((dy = y2 - y1) == 0) + return; + dx = x2 - x1, dz = z2 - z1; + } + sx = 0; + if (dx > 0) + sx = 1; + else if (dx < 0) + dx = -dx, sx = -1; + xd = 0; + if (dx > dy) + xd = dx/dy, dx -= xd*dy, xd *= sx; + xe = (dx *= 2) - dy; + sz = 0; + if (dz > 0) + sz = 1; + else if (dz < 0) + dz = -dz, sz = -1; + zd = 0; + if (dz > dy) + zd = dz/dy, dz -= zd*dy, zd *= sz; + ze = (dz *= 2) - dy; + dy *= 2; + x1 += OrgX; + p = Edges + y1; + do { + if ((a = x1) < 0) + a = 0; + else if (a > SizX) + a = SizX; + if (a < p->h[1]) { + p->h[0] = a; + p->z[0] = z1; + } + else { + p->h[0] = p->h[1]; + p->z[0] = p->z[1]; + p->h[1] = a; + p->z[1] = z1; + } + ++p; + x1 += xd; + if (xe >= 0) + x1 += sx, xe -= dy; + xe += dx; + z1 += zd; + if (ze >= 0) + z1 += sz, ze -= dy; + ze += dz; + } while (++y1 < y2); +} + +static void zDots(long i, long h, long h2, unsigned long z, unsigned long z2) { + char *frame; + unsigned long *zbuff; + + i = i * SizX + h; + frame = Img->data + i * PixSize; + zbuff = Zbuff + i; + i = h2 - h; + switch (PixSize) { + case 1: + if (z < *zbuff) + *zbuff = z, *frame = 0; + if (z2 < *(zbuff += i)) + *zbuff = z2, *(frame + i) = 0; + break; + case 2: + if (z < *zbuff) + *zbuff = z, *(short*)frame = (short)0; + if (z2 < *(zbuff += i)) + *zbuff = z2, *(short*)(frame + 2 * i) = (short)0; + break; + case 3: + if (z < *zbuff) { + *zbuff = z; + frame[0] = 0; + frame[1] = 0; + frame[2] = 0; + } + if (z2 < *(zbuff += i)) { + *zbuff = z2; + frame += 3 * i; + frame[0] = 0; + frame[1] = 0; + frame[2] = 0; + } + break; + case 4: + if (z < *zbuff) + *zbuff = z, *(long*)frame = (long)0; + if (z2 < *(zbuff += i)) + *zbuff = z2, *(long*)(frame + 4 * i) = (long)0; + break; + } +} + +static void zLine(long pix, long v, long h, long h2, + unsigned long z, unsigned long z2) { + char *frame; + unsigned long *zbuff; + long d, e, dh, dz, sz; + + if (dh = h2 - h) { + v = v * SizX + h; + frame = Img->data + v * PixSize; + zbuff = Zbuff + v; + sz = 0; + if ((dz = z2 - z) > 0) + sz = 1; + else if (dz < 0) + dz = -dz, sz = -1; + d = 0; + if (dz > dh) + d = dz/dh, dz -= d*dh, d *= sz; + e = (dz *= 2) - dh; + dh *= 2; + switch (PixSize) { + case 1: + do { + if (z < *zbuff) + *zbuff = z, *frame = pix; + z += d; + if (e >= 0) + z += sz, e -= dh; + ++zbuff, ++frame; + e += dz; + } while (++h < h2); + break; + case 2: + do { + if (z < *zbuff) + *zbuff = z, *(short*)frame = (short)pix; + z += d; + if (e >= 0) + z += sz, e -= dh; + ++zbuff, frame += 2; + e += dz; + } while (++h < h2); + break; + case 3: + do { + if (z < *zbuff) { + *zbuff = z; + frame[0] = pix; + frame[1] = (pix >> 8); + frame[2] = (pix >> 16); + } + z += d; + if (e >= 0) + z += sz, e -= dh; + ++zbuff, frame += 3; + e += dz; + } while (++h < h2); + break; + case 4: + do { + if (z < *zbuff) + *zbuff = z, *(long*)frame = pix; + z += d; + if (e >= 0) + z += sz, e -= dh; + ++zbuff, frame += 4; + e += dz; + } while (++h < h2); + break; + } + } +} + +/*** Main entry point ***/ +int main(int ac, char *av[]) { + struct sockaddr_in addr; + struct hostent *hp; + XPixmapFormatValues *pmFormat; + long hor, sky, gnd, pix, v; + int n, i, x0, y0, z0, x1, y1, z1, x2, y2, z2; + char *frame; + edge *e; + long long t; + struct timeval tv; + + if (ac != 3) + giveup("Use: <host> <port>"); + + /* Open Connection */ + memset(&addr, 0, sizeof(addr)); + if ((long)(addr.sin_addr.s_addr = inet_addr(av[1])) == -1) { + if (!(hp = gethostbyname(av[1])) || hp->h_length == 0) + giveup("Can't get host"); + addr.sin_addr.s_addr = ((struct in_addr*)hp->h_addr_list[0])->s_addr; + } + if ((Socket = socket(AF_INET, SOCK_STREAM, 0)) < 0) + giveup("Can't create socket"); + addr.sin_family = AF_INET; + addr.sin_port = htons(atol(av[2])); + if (connect(Socket, (struct sockaddr*)&addr, sizeof(addr)) < 0) + giveup("Can't connect"); + + /* Open Display */ + if ((Disp = XOpenDisplay(NULL)) == NULL) + giveup("Can't open Display"); + Scrn = DefaultScreen(Disp); + Cmap = DefaultColormap(Disp,Scrn); + Dpth = PixSize = 0; + pmFormat = XListPixmapFormats(Disp, &n); + for (i = 0; i < n; i++) { + if (pmFormat[i].depth == 24) { + Dpth = 24; + if (PixSize != 4) + PixSize = (pmFormat[i].bits_per_pixel + 7) / 8 & ~8; + } + else if (pmFormat[i].depth == 16 && (PixSize < 3 || PixSize > 4)) { + Dpth = 16; + PixSize = (pmFormat[i].bits_per_pixel + 7) / 8 & ~8; + } + else if (pmFormat[i].depth == 8 && (PixSize < 2 || PixSize > 4)) { + Dpth = 8; + PixSize = (pmFormat[i].bits_per_pixel + 7) / 8 & ~8; + } + } + if (!Dpth) + giveup("Bad Display Depth"); + Gc = XCreateGC(Disp,RootWindow(Disp,Scrn), 0, NULL); + + OrgX = (SizX = getNum()) / 2; + OrgY = (SizY = getNum()) / 2; + + /* Create Window */ + Win = XCreateSimpleWindow(Disp, RootWindow(Disp,Scrn), 0, 0, SizX, SizY, + 1, BlackPixel(Disp,Scrn), WhitePixel(Disp,Scrn) ); + XStoreName(Disp, Win, "PicoLisp z3d"); + XSelectInput(Disp, Win, + ExposureMask | + KeyPressMask | KeyReleaseMask | + ButtonPressMask | + PointerMotionMask ); + XMapWindow(Disp, Win); + + /* Create Image */ + SizX = SizX + 3 & ~3; + SizY = SizY + 3 & ~3; + Zbuff = alloc(SizX * SizY * sizeof(unsigned long)); + Edges = alloc(SizY * sizeof(edge)); + if (!XShmQueryExtension(Disp) || + !(Img = XShmCreateImage(Disp, DefaultVisual(Disp, Scrn), + Dpth, ZPixmap, NULL, &Info, SizX, SizY )) || + (Info.shmid = shmget(IPC_PRIVATE, + SizX * SizY * PixSize, IPC_CREAT | 0777 )) < 0 || + (Info.shmaddr = Img->data = + shmat(Info.shmid, 0, 0) ) == (char*)-1 || + !XShmAttach(Disp, &Info) ) + giveup("Can't create XImage"); + + /* Main loop */ + for (;;) { + prLong('o'); // ok + hor = getNum() + OrgY; + sky = getColor(getNum()); + gnd = getColor(getNum()); + for (v = 0; v < SizY; ++v) { + pix = v < hor? sky : gnd; + frame = Img->data + v * SizX * PixSize; + switch (PixSize) { + case 1: + memset(frame, pix, SizX); + break; + case 2: + pix |= pix<<16; + i = 0; + do + *(long*)frame = pix, frame += 4; + while ((i+=2) < SizX); + break; + case 3: + i = 0; + do { + frame[0] = pix; + frame[1] = (pix >> 8); + frame[2] = (pix >> 16); + frame += 3; + } while (++i < SizX); + break; + case 4: + i = 0; + do + *(long*)frame = pix, frame += 4; + while (++i < SizX); + break; + } + } + memset(Zbuff, 0xFF, SizX * SizY * sizeof(unsigned long)); + + while (n = getNum()) { + memset(Edges, 0, SizY * sizeof(edge)); + x0 = x1 = getNum(); + y0 = y1 = getNum(); + z0 = z1 = getNum(); + skipStr(); + for (;;) { + x2 = getNum(); + y2 = getNum(); + z2 = getNum(); + mkEdge(x1, y1, z1, x2, y2, z2); + if (--n == 0) + break; + x1 = x2, y1 = y2, z1 = z2; + } + mkEdge(x2, y2, z2, x0, y0, z0); + i = 0, e = Edges; + if ((pix = getNum()) < 0) { + do // Transparent + if (e->h[1]) + zDots(i, e->h[0], e->h[1], e->z[0], e->z[1]); + while (++e, ++i < SizY); + } + else { + pix = getColor(pix); // Face color + do + if (e->h[1]) + zLine(pix, i, e->h[0], e->h[1], e->z[0], e->z[1]); + while (++e, ++i < SizY); + } + } + if ((SnapX = getNum()) != 32767) + SnapY = getNum(); + paint(); + gettimeofday(&tv,NULL), t = tv.tv_sec * 1000LL + tv.tv_usec / 1000; + if (Tim > t) { + tv.tv_sec = 0, tv.tv_usec = (Tim - t) * 1000; + select(0, NULL, NULL, NULL, &tv); + t = Tim; + } + Tim = t + 40; + } +} diff --git a/src64/Makefile b/src64/Makefile @@ -0,0 +1,65 @@ +# 03mar10abu +# (c) Software Lab. Alexander Burger + +.SILENT: + +bin = ../bin +lib = ../lib + +ifeq ($(shell uname), Linux) + OS = Linux + SYS = linux + ARCH = x86-64 + LINK-FLAGS = -rdynamic -lc -lm -ldl + DYNAMIC-LIB-FLAGS = -shared -export-dynamic + STRIP = strip +else +ifeq ($(shell uname), Darwin) + OS = Darwin + SYS = darwin + ARCH = x86-64 + export MACOSX_DEPLOYMENT_TARGET=10.4 + LINK-FLAGS = -lc -lm -ldl + DYNAMIC-LIB-FLAGS = -dynamiclib -undefined dynamic_lookup -export-dynamic + STRIP = : +endif +endif + +baseFiles = version.l glob.l main.l sys/$(SYS).code.l \ + gc.l apply.l flow.l sym.l subr.l big.l io.l db.l net.l err.l + +picolisp: $(bin)/picolisp $(lib)/ext $(lib)/ht + +all: picolisp + +$(bin)/picolisp: $(ARCH).$(SYS).base.o + mkdir -p $(bin) $(lib) + gcc -o $(bin)/picolisp $(LINK-FLAGS) $(ARCH).$(SYS).base.o + $(STRIP) $(bin)/picolisp + +$(lib)/ext: $(ARCH).$(SYS).ext.o + gcc -o $(lib)/ext $(DYNAMIC-LIB-FLAGS) $(ARCH).$(SYS).ext.o + $(STRIP) $(lib)/ext + +$(lib)/ht: $(ARCH).$(SYS).ht.o + gcc -o $(lib)/ht $(DYNAMIC-LIB-FLAGS) $(ARCH).$(SYS).ht.o + $(STRIP) $(lib)/ht + +.s.o: + as -o $*.o $*.s + +$(ARCH).$(SYS).base.s: $(baseFiles) + ./mkAsm $(ARCH) $(SYS) $(OS) base $(lib)/tags $(baseFiles) + +$(ARCH).$(SYS).ext.s: ext.l + ./mkAsm $(ARCH) $(SYS) $(OS) ext "" -fpic ext.l + +$(ARCH).$(SYS).ht.s: ht.l + ./mkAsm $(ARCH) $(SYS) $(OS) ht "" -fpic ht.l + + +# Clean up +clean: + rm -f *.s *.o + +# vi:noet:ts=4:sw=4 diff --git a/src64/apply.l b/src64/apply.l @@ -0,0 +1,1606 @@ +# 22sep09abu +# (c) Software Lab. Alexander Burger + +(code 'applyXYZ_E 0) + ld C (Y) # Get 'foo' + do + cnt C # Short number? + if nz # Yes + push (EnvApply) # Build apply frame + link + sym S # Align stack to cell boundary + if nz + push ZERO + end + push Nil # Init CDR + push C # 'fun' + ld E S # 'exe in E + do + cmp Y Z # Any args? + while ne # Yes + sub Y I + push (Y) # Next arg + push ZERO # Dummy symbol's tail + push Nil # Init CDR + lea A (S II) # Value address + push A # CAR + ld (S V) S # Store CDR of previous cell + loop + link + ld (EnvApply) L # Close apply frame + call (C) # Eval SUBR + drop + pop (EnvApply) + ret + end + big C # Undefined if bignum + jnz undefinedCX + atom C # Cell? + if z # Yes + # Apply EXPR + push X + ld X (C) # Parameter list in X + push (EnvBind) # Build bind frame + link + push (At) # Bind At + push At + do + atom X # More parameters? + while z # Yes + ld E (X) # Get symbol + ld X (X CDR) + push (E) # Save old value + push E # Save symbol + cmp Y Z # More args? + if ne # Yes + sub Y I + ld (E) (Y) # Set new value to next arg + else + ld (E) Nil # New value NIL + end + loop + cmp X Nil # NIL-terminated parameter list? + if eq # Yes + link + ld (EnvBind) L # Close bind frame + push 0 # Init env swap + ld Z (C CDR) # Body in Z + prog Z # Run body + pop A # Drop env swap + pop L # Get link + do # Unbind symbols + pop X # Next symbol + pop (X) # Restore value + cmp S L # More? + until eq # No + pop L # Restore link + pop (EnvBind) # Restore bind link + pop X + ret + end + # Non-NIL parameter + cmp X At # '@'? + if ne # No + push (X) # Save last parameter's old value + push X # and the last parameter + ld (X) Nil # Set new value to NIL + link + ld (EnvBind) L # Close bind frame + push 0 # Init env swap + ld Z (C CDR) # Body in Z + prog Z # Run body + pop A # Drop env swap + pop L # Get link + do # Unbind symbols + pop X # Next symbol + pop (X) # Restore value + cmp S L # More? + until eq # No + pop L # Restore link + pop (EnvBind) # Restore bind link + pop X + ret + end + # Evaluated argument list + link + ld (EnvBind) L # Close bind frame + push 0 # Init env swap + push (EnvNext) # Save current 'next' + push (EnvArgs) # and varArgs base + cmp Y Z # Any args? + if eq # No + ld (EnvArgs) 0 + ld (EnvNext) 0 + else + link # Build varArgs frame + do + sub Y I + push (Y) # Push next argument + cmp Y Z # More args? + until eq # No + ld (EnvArgs) S # Set new varArgs base + ld (EnvNext) L # Set new 'next' + link # Close varArgs frame + end + ld Z (C CDR) # Body in Z + prog Z # Run body + null (EnvNext) # VarArgs? + if nz # Yes + drop # Drop varArgs + end + pop (EnvArgs) # Restore varArgs base + pop (EnvNext) # and 'next' + pop A # Drop env swap + pop L # Get link + do # Unbind symbols + pop X # Next symbol + pop (X) # Restore value + cmp S L # More? + until eq # No + pop L # Restore link + pop (EnvBind) # Restore bind link + pop X + ret + end + ld A (C) # Else symbolic, get value + cmp A doMeth # Method? + if eq # Yes + sub Y I # First arg + ld E (Y) # Get object + num E # Need symbol + jnz symErrEX + sym E + jz symErrEX + sym (E TAIL) # External symbol? + if nz # Yes + call dbFetchEX # Fetch it + end + push X + push Z # Save arg pointers + push Y + ld Y C # 'msg' + ld Z Nil # No classes + call methodEY_FCYZ # Found? + jne msgErrYX # No + xchg Z (S I) # 'cls' + xchg Y (S) # 'key' + push (EnvMeth) # Method frame + ld (EnvMeth) S + ld X (C) # Parameter list in X + push (EnvBind) # Build bind frame + link + push (At) # Bind At + push At + push (This) # Bind This + push This + ld (This) (Y) # to object + do + atom X # More parameters? + while z # Yes + ld E (X) # Get symbol + ld X (X CDR) + push (E) # Save old value + push E # Save symbol + cmp Y Z # More args? + if ne # Yes + sub Y I + ld (E) (Y) # Set new value to next arg + else + ld (E) Nil # New value NIL + end + loop + cmp X Nil # NIL-terminated parameter list? + if eq # Yes + link + ld (EnvBind) L # Close bind frame + push 0 # Init env swap + ld Z (C CDR) # Body in Z + prog Z # Run body + pop A # Drop env swap + pop L # Get link + do # Unbind symbols + pop X # Next symbol + pop (X) # Restore value + cmp S L # More? + until eq # No + pop L # Restore link + pop (EnvBind) # Restore bind link + pop (EnvMeth) # and method link + pop A # Drop frame + pop A + pop X + ret + end + # Non-NIL parameter + cmp X At # '@'? + if ne # No + push (X) # Save last parameter's old value + push X # and the last parameter + ld (X) Nil # Set new value to NIL + link + ld (EnvBind) L # Close bind frame + push 0 # Init env swap + ld Z (C CDR) # Body in Z + prog Z # Run body + pop A # Drop env swap + pop L # Get link + do # Unbind symbols + pop X # Next symbol + pop (X) # Restore value + cmp S L # More? + until eq # No + pop L # Restore link + pop (EnvBind) # Restore bind link + pop (EnvMeth) # and method link + pop A # Drop frame + pop A + pop X + ret + end + # Evaluated argument list + link + ld (EnvBind) L # Close bind frame + push 0 # Init env swap + push (EnvNext) # Save current 'next' + push (EnvArgs) # and varArgs base + cmp Y Z # Any args? + if eq # No + ld (EnvArgs) 0 + ld (EnvNext) 0 + else + link # Build varArgs frame + do + sub Y I + push (Y) # Push next argument + cmp Y Z # More args? + until eq # No + ld (EnvArgs) S # Set new varArgs base + ld (EnvNext) L # Set new 'next' + link # Close varArgs frame + end + ld Z (C CDR) # Body in Z + prog Z # Run body + null (EnvNext) # VarArgs? + if nz # Yes + drop # Drop varArgs + end + pop (EnvArgs) # Restore varArgs base + pop (EnvNext) # and 'next' + pop A # Drop env swap + pop L # Get link + do # Unbind symbols + pop X # Next symbol + pop (X) # Restore value + cmp S L # More? + until eq # No + pop L # Restore link + pop (EnvBind) # Restore bind link + pop (EnvMeth) # and method link + pop A # Drop frame + pop A + pop X + ret + end + cmp A (A) # Auto-symbol? + if eq # Yes + call sharedLibC_FA # Try dynamic load + jz undefinedCX + end + ld C A + loop + +(code 'applyVarXYZ_E 0) + ld C (Y) # Get 'foo' + do + cnt C # Short number? + if nz # Yes + push (EnvApply) # Build apply frame + link + sym S # Align stack to cell boundary + if nz + push ZERO + end + push Nil # Init CDR + push C # 'fun' + ld E S # 'exe in E + do + cmp Y Z # Any args? + while ne # Yes + sub Y I + push ((Y)) # CAR of next arg + push ZERO # Dummy symbol's tail + push Nil # Init CDR + lea A (S II) # Value address + push A # CAR + ld (S V) S # Store CDR of previous cell + loop + link + ld (EnvApply) L # Close apply frame + call (C) # Eval SUBR + drop + pop (EnvApply) + ret + end + big C # Undefined if bignum + jnz undefinedCX + atom C # Cell? + if z # Yes + # Apply EXPR + push X + ld X (C) # Parameter list in X + push (EnvBind) # Build bind frame + link + push (At) # Bind At + push At + do + atom X # More parameters? + while z # Yes + ld E (X) # Get symbol + ld X (X CDR) + push (E) # Save old value + push E # Save symbol + cmp Y Z # More args? + if ne # Yes + sub Y I + ld (E) ((Y)) # Set new value to CAR of next arg + else + ld (E) Nil # New value NIL + end + loop + cmp X Nil # NIL-terminated parameter list? + if eq # Yes + link + ld (EnvBind) L # Close bind frame + push 0 # Init env swap + ld Z (C CDR) # Body in Z + prog Z # Run body + pop A # Drop env swap + pop L # Get link + do # Unbind symbols + pop X # Next symbol + pop (X) # Restore value + cmp S L # More? + until eq # No + pop L # Restore link + pop (EnvBind) # Restore bind link + pop X + ret + end + # Non-NIL parameter + cmp X At # '@'? + if ne # No + push (X) # Save last parameter's old value + push X # and the last parameter + ld (X) Nil # Set new value to NIL + link + ld (EnvBind) L # Close bind frame + push 0 # Init env swap + ld Z (C CDR) # Body in Z + prog Z # Run body + pop A # Drop env swap + pop L # Get link + do # Unbind symbols + pop X # Next symbol + pop (X) # Restore value + cmp S L # More? + until eq # No + pop L # Restore link + pop (EnvBind) # Restore bind link + pop X + ret + end + # Evaluated argument list + link + ld (EnvBind) L # Close bind frame + push 0 # Init env swap + push (EnvNext) # Save current 'next' + push (EnvArgs) # and varArgs base + cmp Y Z # Any args? + if eq # No + ld (EnvArgs) 0 + ld (EnvNext) 0 + else + link # Build varArgs frame + do + sub Y I + push ((Y)) # Push CAR of next argument + cmp Y Z # More args? + until eq # No + ld (EnvArgs) S # Set new varArgs base + ld (EnvNext) L # Set new 'next' + link # Close varArgs frame + end + ld Z (C CDR) # Body in Z + prog Z # Run body + null (EnvNext) # VarArgs? + if nz # Yes + drop # Drop varArgs + end + pop (EnvArgs) # Restore varArgs base + pop (EnvNext) # and 'next' + pop A # Drop env swap + pop L # Get link + do # Unbind symbols + pop X # Next symbol + pop (X) # Restore value + cmp S L # More? + until eq # No + pop L # Restore link + pop (EnvBind) # Restore bind link + pop X + ret + end + ld A (C) # Else symbolic, get value + cmp A doMeth # Method? + if eq # Yes + sub Y I # First arg + ld E ((Y)) # Get object + num E # Need symbol + jnz symErrEX + sym E + jz symErrEX + sym (E TAIL) # External symbol? + if nz # Yes + call dbFetchEX # Fetch it + end + push X + push Z # Save arg pointers + push Y + ld Y C # 'msg' + ld Z Nil # No classes + call methodEY_FCYZ # Found? + jne msgErrYX # No + xchg Z (S I) # 'cls' + xchg Y (S) # 'key' + push (EnvMeth) # Method frame + ld (EnvMeth) S + ld X (C) # Parameter list in X + push (EnvBind) # Build bind frame + link + push (At) # Bind At + push At + push (This) # Bind This + push This + ld (This) ((Y)) # to object + do + atom X # More parameters? + while z # Yes + ld E (X) # Get symbol + ld X (X CDR) + push (E) # Save old value + push E # Save symbol + cmp Y Z # More args? + if ne # Yes + sub Y I + ld (E) ((Y)) # Set new value to CAR of next arg + else + ld (E) Nil # New value NIL + end + loop + cmp X Nil # NIL-terminated parameter list? + if eq # Yes + link + ld (EnvBind) L # Close bind frame + push 0 # Init env swap + ld Z (C CDR) # Body in Z + prog Z # Run body + pop A # Drop env swap + pop L # Get link + do # Unbind symbols + pop X # Next symbol + pop (X) # Restore value + cmp S L # More? + until eq # No + pop L # Restore link + pop (EnvBind) # Restore bind link + pop (EnvMeth) # and method link + pop A # Drop frame + pop A + pop X + ret + end + # Non-NIL parameter + cmp X At # '@'? + if ne # No + push (X) # Save last parameter's old value + push X # and the last parameter + ld (X) Nil # Set new value to NIL + link + ld (EnvBind) L # Close bind frame + push 0 # Init env swap + ld Z (C CDR) # Body in Z + prog Z # Run body + pop A # Drop env swap + pop L # Get link + do # Unbind symbols + pop X # Next symbol + pop (X) # Restore value + cmp S L # More? + until eq # No + pop L # Restore link + pop (EnvBind) # Restore bind link + pop (EnvMeth) # and method link + pop A # Drop frame + pop A + pop X + ret + end + # Evaluated argument list + link + ld (EnvBind) L # Close bind frame + push 0 # Init env swap + push (EnvNext) # Save current 'next' + push (EnvArgs) # and varArgs base + cmp Y Z # Any args? + if eq # No + ld (EnvArgs) 0 + ld (EnvNext) 0 + else + link # Build varArgs frame + do + sub Y I + push ((Y)) # Push CAR of next argument + cmp Y Z # More args? + until eq # No + ld (EnvArgs) S # Set new varArgs base + ld (EnvNext) L # Set new 'next' + link # Close varArgs frame + end + ld Z (C CDR) # Body in Z + prog Z # Run body + null (EnvNext) # VarArgs? + if nz # Yes + drop # Drop varArgs + end + pop (EnvArgs) # Restore varArgs base + pop (EnvNext) # and 'next' + pop A # Drop env swap + pop L # Get link + do # Unbind symbols + pop X # Next symbol + pop (X) # Restore value + cmp S L # More? + until eq # No + pop L # Restore link + pop (EnvBind) # Restore bind link + pop (EnvMeth) # and method link + pop A # Drop frame + pop A + pop X + ret + end + cmp A (A) # Auto-symbol? + if eq # Yes + call sharedLibC_FA # Try dynamic load + jz undefinedCX + end + ld C A + loop + +# (apply 'fun 'lst ['any ..]) -> any +(code 'doApply 2) + push X + push Y + push Z + ld X E # Keep expression in X + ld Z (E CDR) # Z on args + ld E (Z) + eval # Eval 'fun' + link + push E + ld Y S # Pointer to 'fun' in Y + ld Z (Z CDR) # Second arg + ld E (Z) + eval+ # Eval 'lst' + do + ld Z (Z CDR) # Args + atom Z # More? + while z # Yes + push E # Save 'lst' + ld E (Z) + eval+ # Eval next arg + xchg E (S) # Keep 'lst' in E + loop + do + atom E # Expand 'lst' + while z + push (E) + ld E (E CDR) + loop + ld Z S # Z on last argument + link # Close frame + call applyXYZ_E # Apply + drop + pop Z + pop Y + pop X + ret + +# (pass 'fun ['any ..]) -> any +(code 'doPass 2) + push X + push Y + push Z + ld X E # Keep expression in X + ld Z (E CDR) # Z on args + ld E (Z) + eval # Eval 'fun' + link + push E # Push 'fun' + ld Y S # Pointer to 'fun' in Y + do # 'any' args + ld Z (Z CDR) # Any? + atom Z + while z # Yes + ld E (Z) + eval+ # Eval next 'lst' + push E + loop + ld C (EnvNext) # VarArgs + do + cmp C (EnvArgs) # Any? + while ne # Yes + sub C I + push (C) # Next arg + loop + ld Z S # Z on last argument + link # Close frame + call applyXYZ_E # Apply + drop + pop Z + pop Y + pop X + ret + +# (maps 'fun 'sym ['lst ..]) -> any +(code 'doMaps 2) + push X + push Y + push Z + ld X E # Keep expression in X + ld Z (E CDR) # Z on args + ld E (Z) + ld Z (Z CDR) + eval # Eval 'fun' + link + push E # Save 'fun' + ld Y S # Pointer to 'fun' in Y + ld E (Z) + ld Z (Z CDR) + eval+ # Eval 'sym' + push E # <Y -I> 'sym' + do # 'lst' args + atom Z # More 'lst' args? + while z # Yes + ld E (Z) + eval+ # Eval next 'lst' + push E + ld Z (Z CDR) + loop + link # <L I> Last argument + ld E (Y -I) # Get 'sym' + num E # Need symbol + jnz symErrEX + sym E + jz symErrEX + sym (E TAIL) # External symbol? + if nz # Yes + call dbFetchEX # Fetch it + end + ld E (E TAIL) # Get property list + off E SYM # Clear 'extern' tag + ld (Y -I) E + ld E Nil # Preset return value + do + atom (Y -I) # First 'lst' done? + while z # No + push Y + lea Z (L I) # Last arg + call applyVarXYZ_E # Apply + pop Y + lea Z (L I) # Last arg + do + ld (Z) ((Z) CDR) # Pop all lists + add Z I + cmp Z Y # Reached 'fun'? + until eq # Yes + loop + drop + pop Z + pop Y + pop X + ret + +# (map 'fun 'lst ..) -> lst +(code 'doMap 2) + push X + push Y + push Z + ld X E # Keep expression in X + ld Z (E CDR) # Z on args + ld E (Z) + ld Z (Z CDR) + eval # Eval 'fun' + link + push E # Push 'fun' + ld Y S # Pointer to 'fun' in Y + do # 'lst' args + ld E (Z) + eval+ # Eval next 'lst' + push E + ld Z (Z CDR) + atom Z # More 'lst' args? + until nz # No + link # <L I> Last argument + ld E Nil # Preset return value + do + atom (Y -I) # First 'lst' done? + while z # No + push Y + lea Z (L I) # Last arg + call applyXYZ_E # Apply + pop Y + lea Z (L I) # Last arg + do + ld (Z) ((Z) CDR) # Pop all lists + add Z I + cmp Z Y # Reached 'fun'? + until eq # Yes + loop + drop + pop Z + pop Y + pop X + ret + +# (mapc 'fun 'lst ..) -> lst +(code 'doMapc 2) + push X + push Y + push Z + ld X E # Keep expression in X + ld Z (E CDR) # Z on args + ld E (Z) + ld Z (Z CDR) + eval # Eval 'fun' + link + push E # Push 'fun' + ld Y S # Pointer to 'fun' in Y + do # 'lst' args + ld E (Z) + eval+ # Eval next 'lst' + push E + ld Z (Z CDR) + atom Z # More 'lst' args? + until nz # No + link # <L I> Last argument + ld E Nil # Preset return value + do + atom (Y -I) # First 'lst' done? + while z # No + push Y + lea Z (L I) # Last arg + call applyVarXYZ_E # Apply + pop Y + lea Z (L I) # Last arg + do + ld (Z) ((Z) CDR) # Pop all lists + add Z I + cmp Z Y # Reached 'fun'? + until eq # Yes + loop + drop + pop Z + pop Y + pop X + ret + +# (maplist 'fun 'lst ..) -> lst +(code 'doMaplist 2) + push X + push Y + push Z + ld X E # Keep expression in X + ld Z (E CDR) # Z on args + ld E (Z) + ld Z (Z CDR) + eval # Eval 'fun' + link + push E # Push 'fun' + ld Y S # Pointer to 'fun' in Y + do # 'lst' args + ld E (Z) + eval+ # Eval next 'lst' + push E + ld Z (Z CDR) + atom Z # More 'lst' args? + until nz # No + push Nil # <L I> Result + link # <L II> Last argument + push 0 # <L -I> Result tail + do + atom (Y -I) # First 'lst' done? + while z # No + push Y + lea Z (L II) # Last arg + call applyXYZ_E # Apply + pop Y + call consE_C # Cons with NIL + ld (C) E + ld (C CDR) Nil + null (L -I) # Result tail? + if z # No + ld (L I) C # Store result + else + ld ((L -I) CDR) C # Set new CDR of result tail + end + ld (L -I) C # Store result tail + lea Z (L II) # Last arg + do + ld (Z) ((Z) CDR) # Pop all lists + add Z I + cmp Z Y # Reached 'fun'? + until eq # Yes + loop + ld E (L I) # Result + drop + pop Z + pop Y + pop X + ret + +# (mapcar 'fun 'lst ..) -> lst +(code 'doMapcar 2) + push X + push Y + push Z + ld X E # Keep expression in X + ld Z (E CDR) # Z on args + ld E (Z) + ld Z (Z CDR) + eval # Eval 'fun' + link + push E # Push 'fun' + ld Y S # Pointer to 'fun' in Y + do # 'lst' args + ld E (Z) + eval+ # Eval next 'lst' + push E + ld Z (Z CDR) + atom Z # More 'lst' args? + until nz # No + push Nil # <L I> Result + link # <L II> Last argument + push 0 # <L -I> Result tail + do + atom (Y -I) # First 'lst' done? + while z # No + push Y + lea Z (L II) # Last arg + call applyVarXYZ_E # Apply + pop Y + call consE_C # Cons with NIL + ld (C) E + ld (C CDR) Nil + null (L -I) # Result tail? + if z # No + ld (L I) C # Store result + else + ld ((L -I) CDR) C # Set new CDR of result tail + end + ld (L -I) C # Store result tail + lea Z (L II) # Last arg + do + ld (Z) ((Z) CDR) # Pop all lists + add Z I + cmp Z Y # Reached 'fun'? + until eq # Yes + loop + ld E (L I) # Result + drop + pop Z + pop Y + pop X + ret + +# (mapcon 'fun 'lst ..) -> lst +(code 'doMapcon 2) + push X + push Y + push Z + ld X E # Keep expression in X + ld Z (E CDR) # Z on args + ld E (Z) + ld Z (Z CDR) + eval # Eval 'fun' + link + push E # Push 'fun' + ld Y S # Pointer to 'fun' in Y + do # 'lst' args + ld E (Z) + eval+ # Eval next 'lst' + push E + ld Z (Z CDR) + atom Z # More 'lst' args? + until nz # No + push Nil # <L I> Result + link # <L II> Last argument + push 0 # <L -I> Result tail + do + atom (Y -I) # First 'lst' done? + while z # No + push Y + lea Z (L II) # Last arg + call applyXYZ_E # Apply + pop Y + atom E # Got cell? + if z # Yes + null (L -I) # Result tail? + if z # No + ld (L I) E # Store result + else + ld A (L -I) # Else get result tail + do + atom (A CDR) # Find last cell + while z + ld A (A CDR) + loop + ld (A CDR) E # Set new CDR + end + ld (L -I) E # Store result tail + end + lea Z (L II) # Last arg + do + ld (Z) ((Z) CDR) # Pop all lists + add Z I + cmp Z Y # Reached 'fun'? + until eq # Yes + loop + ld E (L I) # Result + drop + pop Z + pop Y + pop X + ret + +# (mapcan 'fun 'lst ..) -> lst +(code 'doMapcan 2) + push X + push Y + push Z + ld X E # Keep expression in X + ld Z (E CDR) # Z on args + ld E (Z) + ld Z (Z CDR) + eval # Eval 'fun' + link + push E # Push 'fun' + ld Y S # Pointer to 'fun' in Y + do # 'lst' args + ld E (Z) + eval+ # Eval next 'lst' + push E + ld Z (Z CDR) + atom Z # More 'lst' args? + until nz # No + push Nil # <L I> Result + link # <L II> Last argument + push 0 # <L -I> Result tail + do + atom (Y -I) # First 'lst' done? + while z # No + push Y + lea Z (L II) # Last arg + call applyVarXYZ_E # Apply + pop Y + atom E # Got cell? + if z # Yes + null (L -I) # Result tail? + if z # No + ld (L I) E # Store result + else + ld A (L -I) # Else get result tail + do + atom (A CDR) # Find last cell + while z + ld A (A CDR) + loop + ld (A CDR) E # Set new CDR + end + ld (L -I) E # Store result tail + end + lea Z (L II) # Last arg + do + ld (Z) ((Z) CDR) # Pop all lists + add Z I + cmp Z Y # Reached 'fun'? + until eq # Yes + loop + ld E (L I) # Result + drop + pop Z + pop Y + pop X + ret + +# (filter 'fun 'lst ..) -> lst +(code 'doFilter 2) + push X + push Y + push Z + ld X E # Keep expression in X + ld Z (E CDR) # Z on args + ld E (Z) + ld Z (Z CDR) + eval # Eval 'fun' + link + push E # Push 'fun' + ld Y S # Pointer to 'fun' in Y + do # 'lst' args + ld E (Z) + eval+ # Eval next 'lst' + push E + ld Z (Z CDR) + atom Z # More 'lst' args? + until nz # No + push Nil # <L I> Result + link # <L II> Last argument + push 0 # <L -I> Result tail + do + atom (Y -I) # First 'lst' done? + while z # No + push Y + lea Z (L II) # Last arg + call applyVarXYZ_E # Apply + pop Y + cmp E Nil # NIL? + if ne # No + call consE_C # Cons with NIL + ld (C) ((Y -I)) # Element of first 'lst' + ld (C CDR) Nil + null (L -I) # Result tail? + if z # No + ld (L I) C # Store result + else + ld ((L -I) CDR) C # Set new CDR of result tail + end + ld (L -I) C # Store result tail + end + lea Z (L II) # Last arg + do + ld (Z) ((Z) CDR) # Pop all lists + add Z I + cmp Z Y # Reached 'fun'? + until eq # Yes + loop + ld E (L I) # Result + drop + pop Z + pop Y + pop X + ret + +# (extract 'fun 'lst ..) -> lst +(code 'doExtract 2) + push X + push Y + push Z + ld X E # Keep expression in X + ld Z (E CDR) # Z on args + ld E (Z) + ld Z (Z CDR) + eval # Eval 'fun' + link + push E # Push 'fun' + ld Y S # Pointer to 'fun' in Y + do # 'lst' args + ld E (Z) + eval+ # Eval next 'lst' + push E + ld Z (Z CDR) + atom Z # More 'lst' args? + until nz # No + push Nil # <L I> Result + link # <L II> Last argument + push 0 # <L -I> Result tail + do + atom (Y -I) # First 'lst' done? + while z # No + push Y + lea Z (L II) # Last arg + call applyVarXYZ_E # Apply + pop Y + cmp E Nil # NIL? + if ne # No + call consE_C # Cons with NIL + ld (C) E + ld (C CDR) Nil + null (L -I) # Result tail? + if z # No + ld (L I) C # Store result + else + ld ((L -I) CDR) C # Set new CDR of result tail + end + ld (L -I) C # Store result tail + end + lea Z (L II) # Last arg + do + ld (Z) ((Z) CDR) # Pop all lists + add Z I + cmp Z Y # Reached 'fun'? + until eq # Yes + loop + ld E (L I) # Result + drop + pop Z + pop Y + pop X + ret + +# (seek 'fun 'lst ..) -> lst +(code 'doSeek 2) + push X + push Y + push Z + ld X E # Keep expression in X + ld Z (E CDR) # Z on args + ld E (Z) + ld Z (Z CDR) + eval # Eval 'fun' + link + push E # Push 'fun' + ld Y S # Pointer to 'fun' in Y + do # 'lst' args + ld E (Z) + eval+ # Eval next 'lst' + push E + ld Z (Z CDR) + atom Z # More 'lst' args? + until nz # No + link # <L I> Last argument + ld E Nil # Preset return value + do + atom (Y -I) # First 'lst' done? + while z # No + push Y + lea Z (L I) # Last arg + call applyXYZ_E # Apply + pop Y + cmp E Nil # NIL? + if ne # No + ld E (Y -I) # Return first 'lst' + break T + end + lea Z (L I) # Last arg + do + ld (Z) ((Z) CDR) # Pop all lists + add Z I + cmp Z Y # Reached 'fun'? + until eq # Yes + loop + drop + pop Z + pop Y + pop X + ret + +# (find 'fun 'lst ..) -> any +(code 'doFind 2) + push X + push Y + push Z + ld X E # Keep expression in X + ld Z (E CDR) # Z on args + ld E (Z) + ld Z (Z CDR) + eval # Eval 'fun' + link + push E # Push 'fun' + ld Y S # Pointer to 'fun' in Y + do # 'lst' args + ld E (Z) + eval+ # Eval next 'lst' + push E + ld Z (Z CDR) + atom Z # More 'lst' args? + until nz # No + link # <L I> Last argument + ld E Nil # Preset return value + do + atom (Y -I) # First 'lst' done? + while z # No + push Y + lea Z (L I) # Last arg + call applyVarXYZ_E # Apply + pop Y + cmp E Nil # NIL? + if ne # No + ld E ((Y -I)) # Return CAR of first 'lst' + break T + end + lea Z (L I) # Last arg + do + ld (Z) ((Z) CDR) # Pop all lists + add Z I + cmp Z Y # Reached 'fun'? + until eq # Yes + loop + drop + pop Z + pop Y + pop X + ret + +# (pick 'fun 'lst ..) -> any +(code 'doPick 2) + push X + push Y + push Z + ld X E # Keep expression in X + ld Z (E CDR) # Z on args + ld E (Z) + ld Z (Z CDR) + eval # Eval 'fun' + link + push E # Push 'fun' + ld Y S # Pointer to 'fun' in Y + do # 'lst' args + ld E (Z) + eval+ # Eval next 'lst' + push E + ld Z (Z CDR) + atom Z # More 'lst' args? + until nz # No + link # <L I> Last argument + ld E Nil # Preset return value + do + atom (Y -I) # First 'lst' done? + while z # No + push Y + lea Z (L I) # Last arg + call applyVarXYZ_E # Apply + pop Y + cmp E Nil # NIL? + break ne # No + lea Z (L I) # Last arg + do + ld (Z) ((Z) CDR) # Pop all lists + add Z I + cmp Z Y # Reached 'fun'? + until eq # Yes + loop + drop + pop Z + pop Y + pop X + ret + +# (cnt 'fun 'lst ..) -> cnt +(code 'doCnt 2) + push X + push Y + push Z + ld X E # Keep expression in X + ld Z (E CDR) # Z on args + ld E (Z) + ld Z (Z CDR) + eval # Eval 'fun' + link + push E # Push 'fun' + ld Y S # Pointer to 'fun' in Y + do # 'lst' args + ld E (Z) + eval+ # Eval next 'lst' + push E + ld Z (Z CDR) + atom Z # More 'lst' args? + until nz # No + link # <L I> Last argument + push ZERO # <L -I> Result + do + atom (Y -I) # First 'lst' done? + while z # No + push Y + lea Z (L I) # Last arg + call applyVarXYZ_E # Apply + pop Y + cmp E Nil # NIL? + if ne # No + add (S) (hex "10") # Increment count + end + lea Z (L I) # Last arg + do + ld (Z) ((Z) CDR) # Pop all lists + add Z I + cmp Z Y # Reached 'fun'? + until eq # Yes + loop + pop E # Get result + drop + pop Z + pop Y + pop X + ret + +# (sum 'fun 'lst ..) -> num +(code 'doSum 2) + push X + push Y + push Z + ld X E # Keep expression in X + ld Z (E CDR) # Z on args + ld E (Z) + ld Z (Z CDR) + eval # Eval 'fun' + link + push E # Push 'fun' + ld Y S # Pointer to 'fun' in Y + do # 'lst' args + ld E (Z) + eval+ # Eval next 'lst' + push E + ld Z (Z CDR) + atom Z # More 'lst' args? + until nz # No + push ZERO # <L II> Safe + push ZERO # <L I> Result + link # <L III> Last argument + do + atom (Y -I) # First 'lst' done? + while z # No + push Y + lea Z (L III) # Last arg + call applyVarXYZ_E # Apply + pop Y + num E # Number? + if nz # Yes + ld (L II) E # Save + ld A (L I) # Result so far + call addAE_A # Add + ld (L I) A # Result + end + lea Z (L III) # Last arg + do + ld (Z) ((Z) CDR) # Pop all lists + add Z I + cmp Z Y # Reached 'fun'? + until eq # Yes + loop + ld E (L I) # Result + drop + pop Z + pop Y + pop X + ret + +# (maxi 'fun 'lst ..) -> any +(code 'doMaxi 2) + push X + push Y + push Z + ld X E # Keep expression in X + ld Z (E CDR) # Z on args + ld E (Z) + ld Z (Z CDR) + eval # Eval 'fun' + link + push E # Push 'fun' + ld Y S # Pointer to 'fun' in Y + do # 'lst' args + ld E (Z) + eval+ # Eval next 'lst' + push E + ld Z (Z CDR) + atom Z # More 'lst' args? + until nz # No + push Nil # <L II> Value + push Nil # <L I> Result + link # <L III> Last argument + do + atom (Y -I) # First 'lst' done? + while z # No + push Y + lea Z (L III) # Last arg + call applyVarXYZ_E # Apply + ld Y E # Keep + ld A (L II) # Maximal value + call compareAE_F # Compare with current + if lt + ld (L I) (((S) -I)) # New result + ld (L II) Y # New maximum + end + pop Y + lea Z (L III) # Last arg + do + ld (Z) ((Z) CDR) # Pop all lists + add Z I + cmp Z Y # Reached 'fun'? + until eq # Yes + loop + ld E (L I) # Result + drop + pop Z + pop Y + pop X + ret + +# (mini 'fun 'lst ..) -> any +(code 'doMini 2) + push X + push Y + push Z + ld X E # Keep expression in X + ld Z (E CDR) # Z on args + ld E (Z) + ld Z (Z CDR) + eval # Eval 'fun' + link + push E # Push 'fun' + ld Y S # Pointer to 'fun' in Y + do # 'lst' args + ld E (Z) + eval+ # Eval next 'lst' + push E + ld Z (Z CDR) + atom Z # More 'lst' args? + until nz # No + push TSym # <L II> Value + push Nil # <L I> Result + link # <L III> Last argument + do + atom (Y -I) # First 'lst' done? + while z # No + push Y + lea Z (L III) # Last arg + call applyVarXYZ_E # Apply + ld Y E # Keep + ld A (L II) # Minimal value + call compareAE_F # Compare with current + if gt + ld (L I) (((S) -I)) # New result + ld (L II) Y # New minimum + end + pop Y + lea Z (L III) # Last arg + do + ld (Z) ((Z) CDR) # Pop all lists + add Z I + cmp Z Y # Reached 'fun'? + until eq # Yes + loop + ld E (L I) # Result + drop + pop Z + pop Y + pop X + ret + +# (fish 'fun 'any) -> lst +(code 'doFish 2) + push X + push Y + push Z + ld X E # Keep expression in X + ld Z (E CDR) # Z on args + ld E (Z) + eval # Eval 'fun' + link + push E # Push 'fun' + ld Y S # Pointer to 'fun' in Y + ld Z (Z CDR) # Second arg + ld E (Z) + eval+ # Eval 'any' + push ZERO # <L III> Apply arg + push E # <L II> 'any' + push Nil # <L I> Result + link # Close frame + ld A (L II) # Get 'any' + call fishAXY # Fish for results + ld E (L I) # Result + drop + pop Z + pop Y + pop X + ret + +(code 'fishAXY 0) + push A # Save arg + push Y + lea Z (L III) # Set apply arg + ld (Z) A + call applyXYZ_E # Apply + pop Y + pop A + cmp E Nil # NIL? + if ne # No + call cons_C # New cell + ld (C) A # Cons arg + ld (C CDR) (L I) # into result + ld (L I) C + ret + end + atom A # Cell? + jnz ret # No + cmp (A CDR) Nil # CDR? + if ne # Yes + push A + ld A (A CDR) + call fishAXY # Recurse on CDR + pop A + end + ld A (A) + jmp fishAXY # Recurse on CAR + +# (by 'fun1 'fun2 'lst ..) -> lst +(code 'doBy 2) + push X + push Y + push Z + ld X E # Keep expression in X + ld Z (E CDR) # Z on args + ld E (Z) + ld Z (Z CDR) + eval # Eval 'fun1' + link + push E # Push 'fun1' + ld E (Z) + ld Z (Z CDR) + eval+ # Eval 'fun2' + xchg E (S) # Push + push E # Push 'fun1' + ld Y S # Pointer to 'fun1' in Y + do # 'lst' args + ld E (Z) + eval+ # Eval next 'lst' + push E + ld Z (Z CDR) + atom Z # More 'lst' args? + until nz # No + push Nil # <L I> Result + link # <L II> Last argument + push 0 # <L -I> Result tail + do + atom (Y -I) # First 'lst' done? + while z # No + push Y + lea Z (L II) # Last arg + call applyVarXYZ_E # Apply + pop Y + call consE_C # Cons with element from first 'lst' + ld (C) E + ld (C CDR) ((Y -I)) + call consC_A # Concat to result + ld (A) C + ld (A CDR) Nil + null (L -I) # Result tail? + if z # No + ld (L I) A # Store result + else + ld ((L -I) CDR) A # Set new CDR of result tail + end + ld (L -I) A # Store result tail + lea Z (L II) # Last arg + do + ld (Z) ((Z) CDR) # Pop all lists + add Z I + cmp Z Y # Reached 'fun1'? + until eq # Yes + loop + ld Z Y # Point to 'fun1' + add Y I # Pointer to 'fun2' in Y + ld (Z) (L I) # Result + call applyXYZ_E # Apply + ld C E # Remove CARs in result list + do + atom C # More elements? + while z # Yes + ld (C) ((C) CDR) + ld C (C CDR) + loop + drop + pop Z + pop Y + pop X + ret + +# vi:et:ts=3:sw=3 diff --git a/src64/arch/x86-64.l b/src64/arch/x86-64.l @@ -0,0 +1,772 @@ +# 07mar10abu +# (c) Software Lab. Alexander Burger + +# Byte order +(on *LittleEndian) + +# Register assignments +(de *Registers + (A . "%rax") (C . "%rdx") (E . "%rbx") + (B . "%al") (D "%rax" . "%rdx") + (X . "%r13") (Y . "%r14") (Z . "%r15") + (L . "%rbp") (S . "%rsp") + (F . T) ) +# NULL: %r12 +# Temporary: %r10 %r11 +# Block operations: %rcx %rsi %rdi +# C arguments: %rdi %rsi %rdx %rcx %r8 %r9 + +# Addressing modes +(de byteReg (Reg) + (cdr + (assoc Reg + (quote + ("%rax" . "%al") + ("%al" . "%al") + ("%rdx" . "%dl") + ("%rbx" . "%bl") + ("%r12" . "%r12b") + ("%r13" . "%r13b") + ("%r14" . "%r14b") + ("%r15" . "%r15b") + ("%rbp" . "%bpl") + ("%rsp" . "%spl") ) ) ) ) + +(de byteVal (Adr) + (if (= "%r12" Adr) + "$0" # %r12b needs 3 bytes + (or + (byteReg Adr) # Register + Adr ) ) ) # Byte address + +(de lowByte (Adr) + (or + (byteReg Adr) # Register + Adr ) ) # Word address + +(de highWord (S) + (cond + ((= `(char "(") (char S)) + (pack "8" S) ) + ((>= `(char "9") (char S) `(char "0")) + (pack "8+" S) ) + (T (pack S "+8")) ) ) + +(de immediate (Src) + (setq Src (chop Src)) + (when (= "$" (pop 'Src)) + (and (= "~" (car Src)) (pop 'Src)) + (format (pack Src)) ) ) + +(de target (Adr F) + (if + (or + (not *FPic) + (= `(char ".") (char Adr)) # Local label ".1" + (use (@L @N) + (and + (match '(@L "_" @N) (chop Adr)) # Local jump "foo_22" + (= @L (chop *Label)) + (format (pack @N)) ) ) ) + Adr + (ifn F + (pack Adr "@plt") + (prinst "mov" (pack Adr "@GOTPCREL(%rip)") "%r10") + "(%r10)") ) ) + +(de src (Src S) + (cond + ((=0 S) (if (= "$0" Src) "%r12" Src)) # Immediate + ((not S) Src) # Register + ((=T S) # Direct + (if (and *FPic (not (pre? "(" Src))) + (pack Src "@GOTPCREL(%rip)") + (pack "$" Src) ) ) + ((not (car S)) + (ifn (and *FPic (=T (cdr S))) + (pack (cdr Src) "(" (car Src) ")") + (prinst "add" (pack (cdr Src) "@GOTPCREL(%rip)") (car Src)) + (pack "(" (car Src) ")") ) ) + ((=T (car S)) + (ifn *FPic + (if (cdr S) + (pack (car Src) "+" (cdr Src)) + (car Src) ) + (prinst "mov" (pack (car Src) "@GOTPCREL(%rip)") "%r10") + (pack (cdr Src) "(%r10)") ) ) + (T + (prinst "mov" (src (car Src) (car S)) "%r10") + (ifn (and *FPic (=T (cdr S))) + (pack (cdr Src) "(%r10)") + (prinst "add" (pack (cdr Src) "@GOTPCREL(%rip)") "%r10") + "(%r10)" ) ) ) ) + +(de lea (Src S Reg) + (cond + ((not S) (prinst "mov" Src Reg)) # Register + ((=T S) (prinst "mov" (src Src T) Reg)) # Direct + ((not (car S)) + (cond + ((and *FPic (=T (cdr S))) + (prinst "add" (pack (cdr Src) "@GOTPCREL(%rip)") (car Src)) + (prinst "mov" (pack "(" (car Src) ")") Reg) ) + ((cdr Src) + (prinst "lea" (pack (cdr Src) "(" (car Src) ")") Reg) ) + (T (prinst "mov" (car Src) Reg)) ) ) + ((=T (car S)) + (ifn *FPic + (prinst "lea" + (if (cdr S) + (pack (car Src) "+" (cdr Src)) + (car Src) ) + Reg ) + (prinst "mov" (pack (car Src) "@GOTPCREL(%rip)") Reg) + (prinst "lea" (pack (cdr Src) "(%r10)") Reg) ) ) + (T (prinst "mov" (src (car Src) (car S)) Reg)) ) ) + +(de dst (Dst D) + (cond + ((not D) Dst) # Register + ((not (car D)) + (ifn (and *FPic (=T (cdr D))) + (pack (cdr Dst) "(" (car Dst) ")") + (prinst "add" (pack (cdr Dst) "@GOTPCREL(%rip)") (car Dst)) + (pack "(" (car Dst) ")") ) ) + ((=T (car D)) + (ifn *FPic + (if (cdr D) + (pack (car Dst) "+" (cdr Dst)) + (car Dst) ) + (prinst "mov" (pack (car Dst) "@GOTPCREL(%rip)") "%r11") + (pack (cdr Dst) "(%r11)") ) ) + (T + (prinst "mov" (dst (car Dst) (car D)) "%r11") + (ifn (and *FPic (=T (cdr D))) + (pack (cdr Dst) "(%r11)") + (prinst "add" (pack (cdr Dst) "@GOTPCREL(%rip)") "%r11") + "(%r11)" ) ) ) ) + +(de dstSrc (Cmd Dst Src) + (cond + ((= "%al" Dst) + (prinst Cmd (byteVal Src) "%al") ) + ((= "%al" Src) + (prinst Cmd "%al" (byteVal Dst)) ) + ((and (immediate Src) (not (>= 2147483647 @ -2147483648))) + (prinst "mov" Src "%r10") + (prinst Cmd "%r10" Dst) ) + ((or (pre? "%" Src) (pre? "%" Dst)) + (prinst Cmd Src Dst) ) + ((pre? "$" Src) + (prinst (pack Cmd "q") Src Dst) ) + (T + (prinst "mov" Src "%r10") + (prinst Cmd "%r10" Dst) ) ) ) + +(de dstSrcByte (Cmd Dst Src) + (cond + ((= "%r12" Src) + (prinst Cmd "%r12b" (lowByte Dst)) ) + ((and (immediate Src) (>= 255 @ 0)) + (prinst (pack Cmd "b") Src (lowByte Dst)) ) + (T (dstSrc Cmd Dst Src)) ) ) + +(de dstDst (Cmd Dst Dst2) + (cond + ((= "%al" Dst) + (prinst Cmd (byteVal Dst2) "%al") ) + ((= "%al" Dst2) + (prinst Cmd "%al" (byteVal Dst)) ) + ((or (pre? "%" Dst) (pre? "%" Dst2)) + (prinst Cmd Dst2 Dst) ) + (T + (prinst "mov" Dst "%r10") + (prinst Cmd "%r10" Dst2) + (prinst "mov" "%r10" Dst) ) ) ) + +(de dstShift (Cmd Dst Src) + (if (pre? "$" Src) + (prinst (pack Cmd (unless (pre? "%" Dst) "q")) Src Dst) + (prinst "mov" (byteVal Src) "%cl") + (prinst (pack Cmd (unless (pre? "%" Dst) "q")) "%cl" Dst) ) ) + + +### Instruction set ### +(asm nop () + (prinst "nop") ) + +# Move data +(asm ld (Dst D Src S) + (setq Dst (dst Dst D) Src (src Src S)) + (cond + ((= "%al" Dst) + (prinst "mov" (byteVal Src) "%al") ) + ((= "%al" Src) + (prinst "mov" "%al" (byteVal Dst)) ) + ((pair Dst) + (prinst "mov" (if (= "$0" Src) "%r12" Src) (car Dst)) + (prinst "mov" (if (= "$0" Src) "%r12" (highWord Src)) (cdr Dst)) ) + ((pair Src) + (prinst "mov" (car Src) Dst) + (prinst "mov" (cdr Src) (highWord Dst)) ) + ((or (pre? "%" Src) (pre? "%" Dst)) + (prinst "mov" Src Dst) ) + ((pre? "$" Src) + (prinst "movq" Src Dst) ) + (T + (prinst "mov" Src "%r10") + (prinst "mov" "%r10" Dst) ) ) ) + +(asm ld2 (Src S) + (prinst "movswq" (src Src S) "%rax") ) + +(asm ld4 (Src S) + (prinst "movslq" (src Src S) "%rax") ) + +(de _cmov (Cmd Jmp) + (setq Dst (dst Dst D) Src (src Src S)) + (when (pre? "$" Src) + (prinst "mov" Src "%r10") + (setq Src "%r10") ) + (if (pre? "%" Dst) + (prinst Cmd Src Dst) + (warn "Using suboptimal emulation code") + (prinst Jmp "1f") + (if (pre? "%" Src) + (prinst "movq" Src Dst) + (prinst "mov" Src "%r10") + (prinst "mov" "%r10" Dst) ) + (prinl "1:") ) ) + +(asm ldc (Dst D Src S) + (_cmov "cmovcq" "jnc") ) + +(asm ldnc (Dst D Src S) + (_cmov "cmovncq" "jc") ) + +(asm ldz (Dst D Src S) + (_cmov "cmovzq" "jnz") ) + +(asm ldnz (Dst D Src S) + (_cmov "cmovnzq" "jz") ) + +(asm lea (Dst D Src S) + (setq Dst (dst Dst D) Src (src Src S)) + (if (pre? "%" Dst) + (prinst "lea" Src Dst) + (prinst "lea" Src "%r11") + (prinst "mov" "%r11" Dst) ) ) + +(asm st2 (Dst D) + (prinst "movw" "%ax" (dst Dst D)) ) + +(asm st4 (Dst D) + (prinst "movl" "%eax" (dst Dst D)) ) + +(asm xchg (Dst D Dst2 D2) + (dstDst "xchg" (dst Dst D) (src Dst2 D2)) ) + +(asm movm (Dst D Src S End E) + (setq Dst (dst Dst D)) + (prinst (if (pre? "%" Dst) "mov" "lea") Dst "%rdi") + (lea Src S "%rsi") + (prinst "lea" (src End E) "%rcx") + (prinst "sub" "%rsi" "%rcx") + (prinst "cld") + (prinst "rep movsb") ) + +(asm movn (Dst D Src S Cnt C) + (lea Dst D "%rdi") + (lea Src S "%rsi") + (prinst "mov" (src Cnt C) "%rcx") + (prinst "cld") + (prinst "rep movsb") ) + +(asm mset (Dst D Cnt C) + (prinst (if (pre? "%" Dst) "mov" "lea") Dst "%rdi") + (prinst "mov" (src Cnt C) "%rcx") + (prinst "cld") + (prinst "rep stosb") ) + + +# Arithmetics +(asm add (Dst D Src S) + (setq Dst (dst Dst D) Src (src Src S)) + (ifn (pair Dst) + (dstSrc "add" Dst Src) + (prinst "add" Src (car Dst)) + (prinst "adc" "%r12" (cdr Dst)) ) ) + +(asm addc (Dst D Src S) + (setq Dst (dst Dst D) Src (src Src S)) + (ifn (pair Dst) + (dstSrc "adc" Dst Src) + (prinst "adc" Src (car Dst)) + (prinst "adc" "%r12" (cdr Dst)) ) ) + + +(asm sub (Dst D Src S) + (setq Dst (dst Dst D) Src (src Src S)) + (ifn (pair Dst) + (dstSrc "sub" Dst Src) + (prinst "sub" Src (car Dst)) + (prinst "sbb" "%r12" (cdr Dst)) ) ) + +(asm subc (Dst D Src S) + (setq Dst (dst Dst D) Src (src Src S)) + (ifn (pair Dst) + (dstSrc "sbb" Dst Src) + (prinst "sbb" Src (car Dst)) + (prinst "sbb" "%r12" (cdr Dst)) ) ) + +(asm not (Dst D) + (if (pre? "%" (setq Dst (dst Dst D))) + (prinst "not" Dst) + (prinst "notq" Dst) ) ) + +(asm neg (Dst D) + (if (pre? "%" (setq Dst (dst Dst D))) + (prinst "neg" Dst) + (prinst "negq" Dst) ) ) + +(asm and (Dst D Src S) + (dstSrc "and" (dst Dst D) (src Src S)) ) + +(asm or (Dst D Src S) + (dstSrcByte "or" (dst Dst D) (src Src S)) ) + +(asm xor (Dst D Src S) + (dstSrcByte "xor" (dst Dst D) (src Src S)) ) + +(asm off (Dst D Src S) + (dstSrcByte "and" (dst Dst D) (src Src S)) ) + +(asm test (Dst D Src S) + (dstSrcByte "test" (dst Dst D) (src Src S)) ) + +(asm shl (Dst D Src S) + (dstShift "shl" (dst Dst D) (src Src S)) ) + +(asm shr (Dst D Src S) + (dstShift "shr" (dst Dst D) (src Src S)) ) + +(asm rol (Dst D Src S) + (dstShift "rol" (dst Dst D) (src Src S)) ) + +(asm ror (Dst D Src S) + (dstShift "ror" (dst Dst D) (src Src S)) ) + +(asm rcl (Dst D Src S) + (dstShift "rcl" (dst Dst D) (src Src S)) ) + +(asm rcr (Dst D Src S) + (dstShift "rcr" (dst Dst D) (src Src S)) ) + +(asm mul (Src S) + (ifn (pre? "$" (setq Src (src Src S))) + (prinst "mulq" Src) + (prinst "mov" Src "%r10") + (prinst "mul" "%r10") ) ) + +(asm div (Src S) + (ifn (pre? "$" (setq Src (src Src S))) + (prinst "divq" Src) + (prinst "mov" Src "%r10") + (prinst "div" "%r10") ) ) + +(asm zxt () # 8 bit -> 64 bit + (prinst "movzx" "%al" "%rax") ) + +(asm sxt () # 8 bit -> 64 bit + (prinst "movsx" "%al" "%rax") ) + +(asm int () # 32 bit -> 64 bit + (prinst "movsx" "%eax" "%rax") ) + + +(asm setc () + (prinst "stc") ) + +(asm clrc () + (prinst "clc") ) + +(asm setz () + (prinst "or" "%r12" "%r12") ) + +(asm clrz () + (prinst "cmp" "%rsp" "%r12") ) + + +# Comparisons +(asm cmp (Dst D Src S) + (dstSrc "cmp" (dst Dst D) (src Src S)) ) + +(asm cmp4 (Src S) + (prinst "cmp" (src Src S) "%eax") ) + +(asm cmpm (Dst D Src S End E) + (setq Dst (dst Dst D)) + (prinst (if (pre? "%" Dst) "mov" "lea") Dst "%rsi") + (lea Src S "%rdi") + (prinst "lea" End "%rcx") + (prinst "sub" "%rsi" "%rcx") + (prinst "cld") + (prinst "repnz cmpsb") ) + +(asm cmpn (Dst D Src S Cnt C) + (setq Dst (dst Dst D)) + (prinst (if (pre? "%" Dst) "mov" "lea") Dst "%rsi") + (lea Src S "%rdi") + (prinst "mov" (src Cnt C) "%rcx") + (prinst "cld") + (prinst "repnz cmpsb") ) + +(asm slen (Dst D Src S) + (setq Dst (dst Dst D)) + (prinst "cld") + (prinst "xor" "%rcx" "%rcx") + (prinst "not" "%rcx") + (lea Src S "%rdi") + (prinst "xchg" "%al" "%r12b") + (prinst "repnz scasb") + (prinst "xchg" "%al" "%r12b") + (prinst "not" "%rcx") + (prinst "dec" "%rcx") + (prinst "mov" "%rcx" Dst) ) + +(asm memb (Src S Cnt C) + (prinst "cld") + (lea Src S "%rdi") + (setq Cnt (src Cnt C)) + (prinst "mov" Cnt "%rcx") + (prinst "repnz scasb") + (unless S (prinst "cmovzq" "%rdi" Src)) + (unless C (prinst "cmovzq" "%rcx" Cnt)) ) + +(asm null (Src S) + (prinst "cmp" "%r12" (src Src S)) ) + +(asm zero (Src S) + (prinst "cmpq" "$2" (src Src S)) ) + +(asm nul4 () + (prinst "cmp" "%r12d" "%eax") ) + + +# Byte addressing +(asm set (Dst D Src S) + (setq Dst (dst Dst D) Src (src Src S)) + (cond + ((= "%r12" Src) + (prinst "mov" "%r12b" (lowByte Dst)) ) + ((or (pre? "$" Src) (pre? "%" Src) (pre? "%" Dst)) + (prinst "movb" Src Dst) ) + (T + (prinst "mov" Src "%r10b") + (prinst "mov" "%r10b" Dst) ) ) ) + +(asm nul (Src S) + (prinst "cmp" "%r12b" (src Src S)) ) + + +# Types +(asm cnt (Src S) + (prinst "testb" "$0x02" (lowByte (src Src S))) ) + +(asm big (Src S) + (prinst "testb" "$0x04" (lowByte (src Src S))) ) + +(asm num (Src S) + (prinst "testb" "$0x06" (lowByte (src Src S))) ) + +(asm sym (Src S) + (prinst "testb" "$0x08" (lowByte (src Src S))) ) + +(asm atom (Src S) + (prinst "testb" "$0x0E" (lowByte (src Src S))) ) + + +# Flow Control +(asm call (Adr A) + (nond + (A (prinst "call" (target Adr))) + ((=T A) (prinst "call" (pack "*" Adr))) + (NIL + (prinst "mov" (target Adr T) "%r10") + (prinst "call" "*%r10") ) ) ) + +(asm jmp (Adr A) + (nond + (A (prinst "jmp" (target Adr))) + ((=T A) (prinst "jmp" (pack "*" Adr))) + (NIL + (prinst "mov" (target Adr T) "%r10") + (prinst "jmp" "*%r10") ) ) ) + +(de _jmp (Opc Opc2) + (ifn A + (prinst Opc (target Adr)) + (prinst Opc2 "1f") + (ifn (=T A) + (prinst "jmp" (pack "*" Adr)) + (prinst "mov" (target Adr T) "%r10") + (prinst "jmp" "*%r10") ) + (prinl "1:") ) ) + +(asm jz (Adr A) + (_jmp "jz" "jnz") ) + +(asm jeq (Adr A) + (_jmp "jz" "jnz") ) + +(asm jnz (Adr A) + (_jmp "jnz" "jz") ) + +(asm jne (Adr A) + (_jmp "jnz" "jz") ) + +(asm js (Adr A) + (_jmp "js" "jns") ) + +(asm jns (Adr A) + (_jmp "jns" "js") ) + +(asm jsz (Adr A) + (_jmp "jle" "jg") ) + +(asm jnsz (Adr A) + (_jmp "jg" "jle") ) + +(asm jc (Adr A) + (_jmp "jc" "jnc") ) + +(asm jlt (Adr A) + (_jmp "jc" "jnc") ) + +(asm jnc (Adr A) + (_jmp "jnc" "jc") ) + +(asm jge (Adr A) + (_jmp "jnc" "jc") ) + +(asm jcz (Adr A) + (_jmp "jbe" "ja") ) + +(asm jle (Adr A) + (_jmp "jbe" "ja") ) + +(asm jncz (Adr A) + (_jmp "ja" "jbe") ) + +(asm jgt (Adr A) + (_jmp "ja" "jbe") ) + +(asm cc (Adr A Arg M) + (unless (== 'cc (caar (seek '((L) (== (cadr L) *Statement)) *Program))) + (prinst "mov" "%rdx" "%r12") ) + (let Reg '("%rdi" "%rsi" "%rdx" "%rcx" "%r8" "%r9") + (if (lst? Arg) + (let Lea NIL + (when (nth Arg 7) + (setq # Maximally 6 args in registers + Arg (append (head 6 Arg) (reverse (tail -6 Arg))) + M (append (head 6 M) (reverse (tail -6 M))) ) ) + (mapc + '((Src S) + (if (== '& Src) + (on Lea) + (unless (= "$0" Src) # Keep for 'xor' later + (setq Src + (src + (recur (Src) + (cond + ((= "%rdx" Src) "%r12") + ((atom Src) Src) + (T (cons (recurse (car Src)) (recurse (cdr Src)))) ) ) + S ) ) ) + (cond + ((not Reg) # 'Src' not stack-relative here! + (ifn Lea + (prinst "pushq" Src) + (prinst "lea" Src "%rax") + (prinst "pushq" "%rax") ) ) + ((= "$0" Src) + (prinst "xor" (car Reg) (pop 'Reg)) ) + ((= "$pop" Src) + (prinst "pop" (pop 'Reg)) ) + (T (prinst (if Lea "lea" "mov") Src (pop 'Reg))) ) + (off Lea) ) ) + Arg + M ) + # Don't use SSE registers if varargs + (when (member Adr '("printf" "fprintf" "sprintf")) + (prinst "xor" "%rax" "%rax") ) ) + (for R Reg + (prinst "cmp" "%rsp" Arg) + (prinst "jz" "1f") + (prinst "pop" R) ) + (prinl "1:") + # Don't use SSE registers if varargs + (prinst "xor" "%rax" "%rax") ) ) + ((get 'call 'asm) Adr A) + (if (lst? Arg) + (when (gt0 (- (length Arg) 6)) + (prinst "lea" (pack (* @ 8) "(%rsp)") "%rsp") ) + (prinst "mov" Arg "%rsp") ) + (unless (== 'cc (caadr (memq *Statement *Program))) + (prinst "mov" "%r12" "%rdx") + (prinst "xor" "%r12" "%r12") ) ) + +(asm ret () + (unless + (and + (seek '((L) (== (cadr L) *Statement)) *Program) + (not (memq (caar @) '`(cons ': (cdr *Transfers)))) ) + (prinst "rep") ) + (prinst "ret") ) + +(asm begin (N) + (prinst "push" "%rbx") + (prinst "push" "%r12") + (prinst "xor" "%r12" "%r12") # NULL register + (when (>= N 6) # Z + (prinst "push" "%r15") + (prinst "mov" "%r9" "%r15") ) + (when (>= N 5) # Y + (prinst "push" "%r14") + (prinst "mov" "%r8" "%r14") ) + (when (>= N 4) # X + (prinst "push" "%r13") + (prinst "mov" "%rcx" "%r13") ) + (and (>= N 3) (prinst "mov" "%rdx" "%rbx")) # E + (and (>= N 2) (prinst "mov" "%rsi" "%rdx")) # C + (and (>= N 1) (prinst "mov" "%rdi" "%rax")) ) # A + +(asm return (N) + (and (>= N 4) (prinst "pop" "%r13")) + (and (>= N 5) (prinst "pop" "%r14")) + (and (>= N 6) (prinst "pop" "%r15")) + (prinst "pop" "%r12") + (prinst "pop" "%rbx") + (prinst "ret") ) + + +# Stack Manipulations +(asm push (Src S) + (setq Src (src Src S)) + (cond + ((=T Src) (prinst "pushf")) + ((pre? "%" Src) (prinst "push" Src)) + (T (prinst "pushq" Src)) ) ) + +(asm pop (Dst D) + (setq Dst (dst Dst D)) + (cond + ((=T Dst) (prinst "popf")) + ((pre? "%" Dst) (prinst "pop" Dst)) + (T (prinst "popq" Dst)) ) ) + +(asm link () + (prinst "push" "%rbp") + (prinst "mov" "%rsp" "%rbp") ) + +(asm tuck (Src S) + (setq Src (src Src S)) + (prinst "mov" "(%rsp)" "%rbp") + (if (or (pre? "$" Src) (pre? "%" Src)) + (prinst "movq" Src "(%rsp)") + (prinst "mov" Src "%r10") + (prinst "mov" "%r10" "(%rsp)") ) ) + +(asm drop () + (prinst "mov" "(%rbp)" "%rsp") + (prinst "pop" "%rbp") ) + +# Evaluation +(asm eval () + (prinst "test" "$0x06" "%bl") # Number? + (prinst "jnz" "1f") # Yes: Skip + (prinst "test" "$0x08" "%bl") # Symbol? + (prinst "cmovnzq" "(%rbx)" "%rbx") # Yes: Get value + (prinst "jnz" "1f") # and skip + (prinst "call" (target 'evListE_E)) # Else evaluate list + (prinl "1:") ) + +(asm eval+ () + (prinst "test" "$0x06" "%bl") # Number? + (prinst "jnz" "1f") # Yes: Skip + (prinst "test" "$0x08" "%bl") # Symbol? + (prinst "cmovnzq" "(%rbx)" "%rbx") # Yes: Get value + (prinst "jnz" "1f") # and skip + (prinst "push" "%rbp") # Else 'link' + (prinst "mov" "%rsp" "%rbp") + (prinst "call" (target 'evListE_E)) # Evaluate list + (prinst "pop" "%rbp") + (prinl "1:") ) + +(asm eval/ret () + (prinst "test" "$0x06" "%bl") # Number? + (prinst "jnz" "ret") # Yes: Return + (prinst "test" "$0x08" "%bl") # Symbol? + (prinst "jz" 'evListE_E) # No: Evaluate list + (prinst "movq" "(%rbx)" "%rbx") # Get value + (prinst "ret") ) + +(asm exec (Reg) + (prinl "1:") # do + (prinst "mov" # ld E (R) + (pack "(" Reg ")") + "%rbx" ) + (prinst "test" "$0x0E" "%bl") # atom E + (prinst "jnz" "2f") + (prinst "call" (target 'evListE_E)) # evList + (prinl "2:") + (prinst "mov" # ld R (R CDR) + (pack "8(" Reg ")") + Reg ) + (prinst "testb" # atom R + "$0x0E" + (byteReg Reg) ) + (prinst "jz" "1b") ) # until nz + +(asm prog (Reg) + (prinl "1:") # do + (prinst "mov" # ld E (R) + (pack "(" Reg ")") + "%rbx" ) + (prinst "test" "$0x06" "%bl") # eval + (prinst "jnz" "2f") + (prinst "test" "$0x08" "%bl") + (prinst "cmovnzq" "(%rbx)" "%rbx") + (prinst "jnz" "2f") + (prinst "call" (target 'evListE_E)) + (prinl "2:") + (prinst "mov" # ld R (R CDR) + (pack "8(" Reg ")") + Reg ) + (prinst "testb" # atom R + "$0x0E" + (byteReg Reg) ) + (prinst "jz" "1b") ) # until nz + + +# System +(asm init () + (prinst "xor" "%r12" "%r12") # Init NULL register + (prinst "mov" "(%rsi)" "%r10") # Get command + (ifn *FPic + (prinst "mov" "%r10" "AV0") + (prinst "mov" "AV0@GOTPCREL(%rip)" "%r11") + (prinst "mov" "%r10" "(%r11)") ) + (prinst "lea" "8(%rsi)" "%r10") # Get argument vector + (ifn *FPic + (prinst "mov" "%r10" "AV") + (prinst "mov" "AV@GOTPCREL(%rip)" "%r11") + (prinst "mov" "%r10" "(%r11)") ) ) + + +### Optimizer ### +# Replace the the next 'cnt' elements with 'lst' +(de optimize (L)) #> (cnt . lst) + +# vi:et:ts=3:sw=3 diff --git a/src64/big.l b/src64/big.l @@ -0,0 +1,2673 @@ +# 02mar10abu +# (c) Software Lab. Alexander Burger + +### Destructive primitives ### +# Remove leading zeroes +(code 'zapZeroA_A 0) + push A # Save number + ld C S # Short-tail in C + ld E C # Null-tail in E + do + cnt (A BIG) # Last cell? + while z # No + null (A DIG) # Null digit? + if nz # No + ld E C # New null-tail + end + lea C (A BIG) # New short-tail + ld A (C) # Next cell + loop + zero (A BIG) # Trailing short zero? + if eq # Yes + ld A (A DIG) + null A # Null digit? + if nz # No + test A (hex "F000000000000000") # Fit in short number? + if z # Yes + shl A 4 # Make short number + or A CNT + ld (C) A # Store in short-tail + end + else + ld A ((E) DIG) # Digit in null-tail + test A (hex "F000000000000000") # Fit in short number? + if nz # No + ld (C) ZERO # Trim short-tail + else + shl A 4 # Make short number + or A CNT + ld (E) A # Store in null-tail + end + end + end + pop A # Result + ret + +# Multiply (unsigned) number by 2 +(code 'twiceA_A 0) + cnt A # A short? + if nz # Yes + xor A 3 # Prepare tag bit + shl A 1 # Shift left + jnc Ret # Done + rcr A 1 # Else normalize + shr A 3 + jmp boxNumA_A # Return bignum + end + push A # Save bignum + ld C (A DIG) # Lowest digit + shl C 1 # Shift left + do + push F # Save carry + ld (A DIG) C # Store digit + ld E (A BIG) # Next cell + cnt E # End of bignum? + while z # No + ld A E + ld C (A DIG) # Next digit + pop F + rcl C 1 # Rotate left + loop + shr E 4 # Normalize + pop F + rcl E 1 # Rotate left + test E (hex "F000000000000000") # Fit in short number? + if z # Yes + shl E 4 # Make short number + or E CNT + else + call boxNumE_E # New cell + end + ld (A BIG) E # Store in final cell + pop A # Return bignum + ret + +# Divide (unsigned) number by 2 +(code 'halfA_A 0) + cnt A # A short? + if nz # Yes + shr A 1 # Shift right + off A 9 # Clear lowest bit and tag + or A CNT # Make short number + ret + end + ld C (A DIG) # Lowest digit + ld E (A BIG) # Next cell + cnt E # Any? + if nz # No + shr E 5 # Normalize and shift right + if nz # Non-empty + rcr C 1 # Rotate right + else + rcr C 1 # Rotate right + test C (hex "F000000000000000") # Fit in short number? + if z # Yes + shl C 4 # Return short number + or C CNT + ld A C + ret + end + end + ld (A DIG) C # Store lowest digit + shl E 4 # Make short number + or E CNT + ld (A BIG) E # Store in the cell + ret + end + push A # Save bignum + do + test (E DIG) 1 # Shift bit? + if nz # Yes + setc + end + rcr C 1 # Rotate right with carry + ld (A DIG) C # Store digit + ld C (E BIG) # More cells? + cnt C + while z # Yes + ld A E # Advance pointers + ld E C + ld C (A DIG) # Next digit + loop + shr C 5 # Normalize and shift right + if nz # Non-empty + rcr (E DIG) 1 # Shift previous digit + shl C 4 # Make short number + or C CNT + else + ld C (E DIG) # Shift previous digit + rcr C 1 + test C (hex "F000000000000000") # Fit in short number? + if z # Yes + shl C 4 # Make short number + or C CNT + ld (A BIG) C + pop A # Return bignum + ret + end + ld (E DIG) C + ld C ZERO + end + ld (E BIG) C # Store in the cell + pop A # Return bignum + ret + +# Multiply (unsigned) number by 10 +(code 'tenfoldA_A 0) + cnt A # A short? + if nz # Yes + shr A 4 # Normalize + mul 10 # Multiply by 10 + test A (hex "F000000000000000") # Fit in short number? + jnz boxNumA_A # No: Return bignum + shl A 4 # Make short number + or A CNT + ret + end + push X + push A # Save bignum + ld X A # Bignum in X + ld A (X DIG) # Multiply lowest digit by 10 + mul 10 + do + ld (X DIG) A # Store lower word + ld E C # Keep upper word in E + ld A (X BIG) # Next cell + cnt A # End of bignum? + while z # No + ld X A + ld A (X DIG) # Next digit + mul 10 # Multiply by 10 + add D E # Add previous upper word + loop + shr A 4 # Normalize + mul 10 # Multiply by 10 + add A E # Add previous upper word + test A (hex "F000000000000000") # Fit in short number? + if z # Yes + shl A 4 # Make short number + or A CNT + else + call boxNumA_A # Return bignum + end + ld (X BIG) A # Store in final cell + pop A # Return bignum + pop X + ret + +### Non-destructive primitives ### +# Multiply (unsigned) number by 2 +(code 'shluA_A 0) + cnt A # A short? + if nz # Yes + xor A 3 # Prepare tag bit + shl A 1 # Shift left + jnc Ret # Done + rcr A 1 # Else normalize + shr A 3 + jmp boxNumA_A # Return bignum + end + call boxNum_E # Build new head + ld (E DIG) (A DIG) # Lowest digit + link + push E # <L I> Result + link + shl (E DIG) 1 # Shift left + push F # Save carry + do + ld A (A BIG) # Next cell + cnt A # End of bignum? + while z # No + call boxNum_C # Build next cell + ld (E BIG) C + ld E (A DIG) # Next digit + pop F + rcl E 1 # Rotate left + push F # Save carry + ld (C DIG) E + ld E C + loop + shr A 4 # Normalize + pop F + rcl A 1 # Rotate left + test A (hex "F000000000000000") # Fit in short number? + if z # Yes + shl A 4 # Make short number + or A CNT + else + call boxNumA_A # New cell + end + ld (E BIG) A # Store in final cell + ld A (L I) # Return bignum + drop + ret + +# Divide (unsigned) number by 2 +(code 'shruA_A 0) + cnt A # A short? + if nz # Yes + shr A 1 # Shift right + off A 9 # Clear lowest bit and tag + or A CNT # Make short number + ret + end + ld E (A BIG) # Next cell + cnt E # Any? + if nz # No + ld C (A DIG) # Lowest digit + shr E 5 # Normalize and shift right + if nz # Non-empty + rcr C 1 # Rotate right + else + rcr C 1 # Rotate right + test C (hex "F000000000000000") # Fit in short number? + if z # Yes + shl C 4 # Return short number + or C CNT + ld A C + ret + end + end + shl E 4 # Make short number + or E CNT + jmp consNumCE_A # Return bignum + end + call boxNum_C # Build new head + ld (C DIG) (A DIG) # Lowest digit + link + push C # <L I> Result + link + do + test (E DIG) 1 # Shift bit? + if nz # Yes + setc + end + rcr (C DIG) 1 # Rotate right with carry + cnt (E BIG) # More cells? + while z # Yes + call boxNum_A # Build next digit + ld (A DIG) (E DIG) + ld (C BIG) A + ld E (E BIG) # Advance pointers + ld C A + loop + ld A (E BIG) # Final short number + shr A 5 # Normalize and shift right + if nz # Non-empty + ld E (E DIG) # Shift previous digit + rcr E 1 + shl A 4 # Make short number + or A CNT + call consNumEA_E # Last cell + ld (C BIG) E # Store in the cell + else + ld E (E DIG) # Shift previous digit + rcr E 1 + test E (hex "F000000000000000") # Fit in short number? + if z # Yes + shl E 4 # Make short number + or E CNT + ld (C BIG) E + ld A (L I) # Return bignum + drop + ret + end + call boxNum_A # New cell + ld (A DIG) E + ld (C BIG) A + end + ld A (L I) # Return bignum + drop + ret + +# Bitwise AND of two (unsigned) numbers +(code 'anduAE_A 0) + cnt A # A short? + if nz # Yes + cnt E # E also short? + if z # No + ld E (E DIG) # Get digit + shl E 4 # Make short number + or E CNT + end + and A E # Return short number + ret + end + # A is big + cnt E # E short? + if nz # Yes + ld A (A DIG) # Get digit + shl A 4 # Make short number + or A CNT + and A E # Return short number + ret + end + # Both are big + push X + link + push ZERO # <L I> Result + link + ld C (A DIG) # AND first digits + and C (E DIG) + call boxNum_X # Make bignum + ld (X DIG) C + ld (L I) X # Init result + do + ld A (A BIG) # Get tails + ld E (E BIG) + cnt A # End of A? + if nz # Yes + cnt E # Also end of E? + if z # No + ld E (E DIG) # Get digit + shl E 4 # Make short number + or E CNT + end + and A E # Concat short + ld (X BIG) A + ld A (L I) # Return bignum + drop + pop X + jmp zapZeroA_A # Remove leading zeroes + end + cnt E # End of E? + if nz # Yes + ld A (A DIG) # Get digit + shl A 4 # Make short number + or A CNT + and A E # Concat short + ld (X BIG) A + ld A (L I) # Return bignum + drop + pop X + jmp zapZeroA_A # Remove leading zeroes + end + ld C (A DIG) # AND digits + and C (E DIG) + call consNumCE_C # New bignum cell + ld (X BIG) C # Concat to result + ld X C + loop + +# Bitwise OR of two (unsigned) numbers +(code 'oruAE_A 0) + cnt A # A short? + if nz # Yes + cnt E # E also short? + if nz # Yes + or A E # Return short number + ret + end + shr A 4 # Normalize + or A (E DIG) # OR digit + ld E (E BIG) # Rest of E + jmp consNumAE_A # Append rest + end + # A is big + cnt E # E short? + if nz # Yes + shr E 4 # Normalize + or E (A DIG) # OR digit + ld A (A BIG) # Rest of A + jmp consNumEA_A # Append rest + end + # Both are big + push X + link + push ZERO # <L I> Result + link + ld C (A DIG) # OR first digits + or C (E DIG) + call boxNum_X # Make bignum + ld (X DIG) C + ld (L I) X # Init result + do + ld A (A BIG) # Get tails + ld E (E BIG) + cnt A # End of A? + if nz # Yes + cnt E # Also end of E? + if nz # Yes + or A E # Concat short number + else + shr A 4 # Normalize + or A (E DIG) # OR digit + ld E (E BIG) # Rest of E + call consNumAE_A # Append rest + end + ld (X BIG) A + ld A (L I) # Return bignum + drop + pop X + ret + end + cnt E # End of E? + if nz # Yes + shr E 4 # Normalize + or E (A DIG) # OR digit + ld A (A BIG) # Rest of A + call consNumEA_A # Append rest + ld (X BIG) A + ld A (L I) # Return bignum + drop + pop X + ret + end + ld C (A DIG) # OR digits + or C (E DIG) + call consNumCE_C # New bignum cell + ld (X BIG) C # Concat to result + ld X C + loop + +# Bitwise XOR of two (unsigned) numbers +(code 'xoruAE_A 0) + cnt A # A short? + if nz # Yes + cnt E # E also short? + if nz # Yes + xor A E # Return short number + or A CNT + ret + end + shr A 4 # Normalize + xor A (E DIG) # XOR digit + ld E (E BIG) # Rest of E + call consNumAE_A # Append rest + jmp zapZeroA_A # Remove leading zeroes + end + # A is big + cnt E # E short? + if nz # Yes + shr E 4 # Normalize + xor E (A DIG) # XOR digit + ld A (A BIG) # Rest of A + call consNumEA_A # Append rest + jmp zapZeroA_A # Remove leading zeroes + end + # Both are big + push X + link + push ZERO # <L I> Result + link + ld C (A DIG) # XOR first digits + xor C (E DIG) + call boxNum_X # Make bignum + ld (X DIG) C + ld (L I) X # Init result + do + ld A (A BIG) # Get tails + ld E (E BIG) + cnt A # End of A? + if nz # Yes + cnt E # Also end of E? + if nz # Yes + xor A E # Concat short number + or A CNT + else + shr A 4 # Normalize + xor A (E DIG) # XOR digit + ld E (E BIG) # Rest of E + call consNumAE_A # Append rest + end + ld (X BIG) A + ld A (L I) # Return bignum + drop + pop X + jmp zapZeroA_A # Remove leading zeroes + end + cnt E # End of E? + if nz # Yes + shr E 4 # Normalize + xor E (A DIG) # XOR digit + ld A (A BIG) # Rest of A + call consNumEA_A # Append rest + ld (X BIG) A + ld A (L I) # Return bignum + drop + pop X + jmp zapZeroA_A # Remove leading zeroes + end + ld C (A DIG) # XOR digits + xor C (E DIG) + call consNumCE_C # New bignum cell + ld (X BIG) C # Concat to result + ld X C + loop + +# Add two (unsigned) numbers +(code 'adduAE_A 0) + cnt A # A short? + if nz # Yes + cnt E # E also short? + jz 10 # No: Jump + off E CNT # Else clear tag + add A E # Add short numbers + jnc Ret # Done + rcr A 1 # Get top bit + shr A 3 # Normalize + jmp boxNumA_A # Return bignum + end + # A is big + cnt E # E short? + if nz # Yes + xchg A E # Exchange args +10 shr A 4 # Normalize short + add A (E DIG) # Add first digit + ld E (E BIG) # Tail in E + jnc consNumAE_A # Cons new cell if no carry + call consNumAE_A # Else build new head + link + push A # <L I> Result + link + do + cnt E # Short number? + if nz # Yes + add E (hex "10") # Add carry + if nc # No further carry + ld (A BIG) E # Append it + else # Again carry + rcr E 1 # Get top bit + shr E 3 # Normalize + call boxNum_C # New cell + ld (C DIG) E + ld (A BIG) C # Append it + end + ld A (L I) # Return bignum + drop + ret + end + ld C (E DIG) # Next digit + ld E (E BIG) + add C 1 # Add carry + if nc # None + call consNumCE_E # New last cell + ld (A BIG) E + ld A (L I) # Return bignum + drop + ret + end + call consNumCE_C # New cell + ld (A BIG) C # Append it + ld A C # Tail of result + loop + end + # Both are big + push X + link + push ZERO # <L I> Result + link + ld C (A DIG) # Add first digits + add C (E DIG) + push F # Save carry + call boxNum_X # Make bignum + ld (X DIG) C + ld (L I) X # Init result + do + ld A (A BIG) # Get tails + ld E (E BIG) + cnt A # End of A? + if nz # Yes + cnt E # Also end of E? + jz 20 # No: Jump + shr A 4 # Normalize A + shr E 4 # Normalize E + pop F + addc A E # Add final shorts with carry + shl A 4 + if nc + or A CNT # Make short number + else # Again carry + rcr A 1 # Get top bit + shr A 3 # Normalize + call boxNumA_A # Make bignum + end + ld (X BIG) A + ld A (L I) # Return bignum + drop + pop X + ret + end + cnt E # End of E? + if nz # Yes + xchg A E # Exchange args +20 shr A 4 # Normalize A + pop F + addc A (E DIG) # Add next digit with carry + do + ld E (E BIG) + if nc # No carry + call consNumAE_A # Append rest + ld (X BIG) A + ld A (L I) # Return bignum + drop + pop X + ret + end + call consNumAE_A # New cell + ld (X BIG) A # Concat to result + ld X A # Pointer to last cell + cnt E # End of E? + if nz # Yes + add E (hex "10") # Add carry + if nc # No further carry + ld (X BIG) E # Append it + else # Again carry + rcr E 1 # Get top bit + shr E 3 # Normalize + call boxNum_C # New cell + ld (C DIG) E + ld (X BIG) C # Append it + end + ld A (L I) # Return bignum + drop + pop X + ret + end + ld A (E DIG) # Add carry to next digit + add A 1 + loop + end + ld C (A DIG) # Add digits + pop F + addc C (E DIG) + push F + call consNumCE_C # New bignum cell + ld (X BIG) C # Concat to result + ld X C + loop + +# Subtract two (unsigned) numbers +(code 'subuAE_A 0) + cnt A # A short? + if nz # Yes + cnt E # E also short? + if nz # Yes + off E CNT # Clear tag + sub A E # Subtract short numbers + jnc Ret # Done + xor A -16 # 2-complement + add A (hex "18") + ret + end + xchg A E # Exchange args + call 10 # Subtract short from big + zero A # Zero? + if ne # No + or A SIGN # Set negative + end + ret + end + # A is big + cnt E # E short? + if nz # Yes +10 shr E 4 # Normalize short + ld C (A DIG) + sub C E # Subtract from first digit + ld E (A BIG) # Tail in E + if nc # No borrow + zero E # Leading zero? + jne consNumCE_A # No: Cons new cell + test C (hex "F000000000000000") # Fit in short number? + jnz consNumCE_A # No: Cons new cell + ld A C # Get digit + shl A 4 # Make short number + or A CNT + ret + end + call consNumCE_A # Else build new head + link + push A # <L I> Result + link + do + cnt E # Short number? + if nz # Yes + sub E (hex "10") # Subtract borrow + if c # Again borrow: Must be the first pass + ld A C # C still has lowest digit + neg A # Negate + shl A 4 + or A (| SIGN CNT) # Make short negative number + drop + ret + end + ld (A BIG) E # Append it + ld A (L I) # Return bignum + drop + jmp zapZeroA_A # Remove leading zeroes + end + ld C (E DIG) # Next digit + ld E (E BIG) + sub C 1 # Subtract borrow + if nc # None + call consNumCE_E # New last cell + ld (A BIG) E # Append it + ld A (L I) # Return bignum + drop + jmp zapZeroA_A # Remove leading zeroes + end + call consNumCE_C # New cell + ld (A BIG) C # Append it + ld A C # Tail of result + loop + end + # Both are big + push X + link + push ZERO # <L I> Result + link + ld C (A DIG) # Subtract first digits + sub C (E DIG) + push F # Save borrow + ld A (A BIG) # Get tail + call consNumCA_C # First bignum cell + ld (L I) C # Init result + do + ld X C # Keep last cell in X + ld E (E BIG) # Get tail + cnt E # End of E? + if nz # Yes + shr E 4 # Normalize E + do + cnt A # Also end of A? + while z # No + ld C (A DIG) # Subtract final digit with borrow + ld A (A BIG) # Next cell + pop F + subc C E # Borrow again? + if nc # No + call consNumCA_C # Final new bignum tail + ld (X BIG) C # Concat to result +20 ld A (L I) # Return bignum + drop + pop X + jmp zapZeroA_A # Remove leading zeroes + end + push F # Save borrow + call consNumCA_C # New bignum tail + ld (X BIG) C # Concat to result + ld X C # Keep last cell + ld E 0 + loop + shr A 4 # Normalize A + break T + end + cnt A # End of A? + if nz # Yes + shr A 4 # Normalize A + do + pop F + subc A (E DIG) # Subtract next digit with borrow + push F + call boxNum_C # New bignum tail + ld (C DIG) A + ld (X BIG) C # Concat to result + ld X C # Keep last cell + ld E (E BIG) # Next cell + ld A 0 + cnt E # Also end of E? + until nz # Yes + shr E 4 # Normalize E + break T + end + ld C (A DIG) # Subtract digits + pop F + subc C (E DIG) + push F # Save borrow + ld A (A BIG) + call consNumCA_C # New bignum cell + ld (X BIG) C # Concat to result + loop + pop F + subc A E # Subtract final shorts with borrow + push F # Save borrow + shl A 4 + or A CNT # Make short number + ld (X BIG) A + pop F # Borrow? + jnc 20 # No + ld A (L I) # Get result + ld E A # 2-complement + do + not (E DIG) # Invert + ld C (E BIG) # Next digit + cnt C # Done? + while z # No + ld E C # Next digit + loop + xor C -16 # Invert final short + ld (E BIG) C + ld E A # Result again + do + add (E DIG) 1 # Increment + jnc 90 # Skip if no carry + ld C (E BIG) # Next digit + cnt C # Done? + while z # No + ld E C # Next digit + loop + add C (hex "10") # Increment final short + ld (E BIG) C +90 drop + pop X + call zapZeroA_A # Remove leading zeroes + or A SIGN # Set negative + ret + +# Multiply two (unsigned) numbers +(code 'muluAE_A 0) + cnt A # A short? + if nz # Yes + zero A # Multiply with zero? + jeq ret # Yes: Return zero + shr A 4 # Normalize + cnt E # E also short? + if nz # Yes + xchg A E + shr A 4 # Normalize + mul E # Multiply + if nc # Only lower word + test A (hex "F000000000000000") # Fit in short number? + if z # Yes + shl A 4 # Make short number + or A CNT + ret + end + end + shl C 4 # Make short number + or C CNT + jmp consNumAC_A # Return bignum + end +10 push X + push Y + push Z + ld Y A # Save digit in Y + mul (E DIG) # Multiply lowest digit + call boxNum_X # First cell + ld (X DIG) A + link + push X # <L I> Safe + link + ld Z C # Keep upper word in Z + do + ld E (E BIG) + cnt E # End of bignum? + while z # No + ld A (E DIG) # Get next digit + mul Y # Multiply digit + add D Z # Add previous upper word + ld Z C + call boxNum_C # Next cell + ld (C DIG) A + ld (X BIG) C + ld X C + loop + ld A Y # Retrieve digit + shr E 4 # Normalize + mul E # Multiply + add D Z # Add previous upper word + if z # Only lower word + test A (hex "F000000000000000") # Fit in short number? + if z # Yes + shl A 4 # Make short number + or A CNT +20 ld (X BIG) A # Store in final cell + ld A (L I) # Return bignum + drop + pop Z + pop Y + pop X + ret + end + end + shl C 4 # Make short number + or C CNT + call consNumAC_A # Return bignum + jmp 20 + end + # A is big + cnt E # E short? + if nz # Yes + zero E # Multiply with zero? + jeq ret # Yes: Return zero + xchg A E # Exchange args + shr A 4 # Normalize + jmp 10 + end + # Both are big + push X + push Y + push Z + ld Y A # Arg1 in Y + ld Z E # Arg2 in Z + call boxNum_X # Zero bignum + ld (X DIG) 0 + link + push X # <L I> Safe + link + push X # <L -I> Safe index + push Y # <L -II> Arg1 index + do + ld A (Y DIG) # Multiply digits + mul (Z DIG) + add D (X DIG) # Add lower word to safe + do + ld (X DIG) A # Store lower word + ld E C # Keep upper word in E + ld A (X BIG) # Next safe cell + cnt A # End of safe? + if nz # Yes + call boxNum_A # Extend safe + ld (A DIG) 0 + ld (X BIG) A + end + ld X A + ld Y (Y BIG) # Next cell of Arg1 + cnt Y # End of bignum? + while z # No + ld A (Y DIG) # Multiply digits + mul (Z DIG) + add D (X DIG) # Add safe + addc D E # plus carry + loop + ld A Y # Final short number + shr A 4 # Normalize + mul (Z DIG) + add D (X DIG) # Add safe + addc D E # plus carry + ld (X DIG) A + if nz # Uppper word + ld A (X BIG) # Next safe cell + cnt A # End of safe? + if nz # Yes + call boxNum_A # Extend safe + ld (A DIG) 0 + ld (X BIG) A + end + ld (A DIG) C # Store uppper word + end + ld Y (L -II) # Get Arg1 index + ld X ((L -I) BIG) # Advance safe index + ld (L -I) X + ld Z (Z BIG) # Next cell of Arg2 + cnt Z # End of bignum? + until nz # Yes + ld A Z + shr A 4 # Normalize + ld Z A + mul (Y DIG) # Multiply digit + add D (X DIG) # Add lower word to safe + do + ld (X DIG) A # Store lower word + ld E C # Keep upper word in E + ld A (X BIG) # Next safe cell + cnt A # End of safe? + if nz # Yes + call boxNum_A # Extend safe + ld (A DIG) 0 + ld (X BIG) A + end + ld X A + ld Y (Y BIG) # Next cell of Arg1 + cnt Y # End of bignum? + while z # No + ld A (Y DIG) # Multiply digit + mul Z + add D (X DIG) # Add safe + addc D E # plus carry + loop + ld A Y # Final short number + shr A 4 # Normalize + mul Z # Multiply digit + add D (X DIG) # Add safe + addc D E # plus carry + ld (X DIG) A + if nz # Uppper word + ld A (X BIG) # Next safe cell + cnt A # End of safe? + if nz # Yes + call boxNum_A # Extend safe + ld (A DIG) 0 + ld (X BIG) A + end + ld (A DIG) C # Store uppper word + end + ld A (L I) # Return bignum + drop + pop Z + pop Y + pop X + jmp zapZeroA_A # Remove leading zeroes + +# Divide two (unsigned) numbers +(code 'divuAE_AC 0) + cnt A # A short? + if nz # Yes + cnt E # E also short? + if nz # Yes + shr A 4 # Normalize A + ld C 0 + shr E 4 # Normalize E + div E # Divide + shl A 4 # Make short number + or A CNT # Quotient + shl C 4 + or C CNT # Remainder + ret + end + ld C A + ld A ZERO # Else return zero + ret + end + link + push ZERO # <L III> Quotient + push A # <L II> Dividend + push E # <L I> Divisor + link + # Calculate dividend's bit count + ld C 0 # Counter + do + cnt (A BIG) # Last cell? + while z # No + add C 64 # Increment by digit size + ld A (A BIG) + loop + zero (A BIG) # Last short zero? + if eq # Yes + ld A (A DIG) # Take last digit + else + add C 64 # Increment for last digit + ld A (A BIG) # Take last short + shr A 4 # Normalize + end + do + add C 1 # Increment counter + shr A 1 # More bits? + until z # No + # Subtract divisor's bit count + cnt E # E short? + if nz # Yes + shr E 4 # Normalize + do + sub C 1 # Decrement counter + shr E 1 # More bits? + until z # No + else + do + cnt (E BIG) # Last cell? + while z # No + sub C 64 # Decrement by digit size + ld E (E BIG) + loop + zero (E BIG) # Last short zero? + if eq # Yes + ld E (E DIG) # Take last digit + else + sub C 64 # Decrement for last digit + ld E (E BIG) # Take last short + shr E 4 # Normalize + end + do + sub C 1 # Decrement counter + shr E 1 # More bits? + until z # No + end + push C # <L -I> Shift offsets + add C 1 + push C # <L -II> + sub (L -I) 1 # Any shift? + if ns # Yes + ld A (L I) # Get divisor + call shluA_A # Shift (non-destructive) + ld (L I) A + ld C (L -I) # Shift offset + do + cmp C 64 # More than 64 bits? + while ge # Yes + sub C 64 # Decrement shift count by digit size + ld E 0 # Cons zero + call consNumEA_A + loop + ld (L I) A # Save shifted divisor + ld (L -I) C # Save remaining count + do + sub (L -I) 1 # Shift remaining bits? + while ns # Yes + call twiceA_A # Shift divisor left (destructive) + ld (L I) A # Save again + loop + end + do + sub (L -II) 1 # Division steps? + while ns # Yes + ld A (L III) # Get quotient + call twiceA_A # Shift (destructive) + ld (L III) A + ld E (L II) # Get dividend + ld A (L I) # and divisor + call cmpuAE_F # Divisor <= dividend? + if le # Yes + ld A (L II) # Subtract divisor from dividend + ld E (L I) + call subuAE_A + ld (L II) A # Save dividend + ld A (L III) # Quotient + cnt A # Short? + if nz # Yes + add B (hex "10") # Increment short + ld (L III) A + else + add (A DIG) 1 # Increment digit + end + end + ld A (L I) # Divisor + call shruA_A # Shift divisor right (non-destructive) + ld (L I) A + loop + ld A (L III) # Return quotient in A + ld C (L II) # and remainder in C + drop + ret + +# Increment a (signed) number +(code 'incE_A 0) + ld A ONE + test E SIGN # Positive? + jz adduAE_A # Increment + off E SIGN # Make positive + call subuAE_A # Subtract + zero A # Zero? + if ne # No + or A SIGN # Negate again + end + ret + +# Decrement a (signed) number +(code 'decE_A 0) + ld A ONE + test E SIGN # Positive? + if z # Yes + xchg A E + jmp subuAE_A # Decrement + end + off E SIGN # Make positive + call adduAE_A # Add + or A SIGN # Negate again + ret + +# Add two (signed) numbers +(code 'addAE_A 0) + test A SIGN # Positive? + if z # Yes + test E SIGN # Arg also positive? + jz adduAE_A # Add [+ A E] + off E SIGN # [+ A -E] + jmp subuAE_A # Sub + end + # Result negatve + test E SIGN # Arg positive? + if z # [+ -A E] + off A SIGN + call subuAE_A # Sub + else # [+ -A -E] + off A SIGN + off E SIGN + call adduAE_A # Add + end + zero A # Zero? + if ne # No + xor A SIGN # Negate + end + ret + +# Subtract to (signed) numbers +(code 'subAE_A 0) + test A SIGN # Positive? + if z # Yes + test E SIGN # Arg also positive? + jz subuAE_A # Sub [- A E] + off E SIGN # [- A -E] + jmp adduAE_A # Add + end + # Result negatve + test E SIGN # Arg positive? + if z # [- -A E] + off A SIGN + call adduAE_A # Add + else # [- -A -E] + off A SIGN + off E SIGN + call subuAE_A # Sub + end + zero A # Zero? + if ne # No + xor A SIGN # Negate + end + ret + +### Comparisons ### +(code 'cmpNumAE_F 0) + test A SIGN # A positive? + if z # Yes + test E SIGN # E also positive? + jz cmpuAE_F # Yes [A E] + clrc # gt [A -E] + ret + end + # A negative + test E SIGN # E positive? + if z # Yes + or B B # nz [-A E] + setc # lt + ret + end + xchg A E # [-A -E] + off A SIGN + off E SIGN + +# Compare two (unsigned) numbers +(code 'cmpuAE_F 0) + cnt A # A short? + if nz # Yes + cnt E # E also short? + if nz # Yes + cmp A E # F + ret + end + or B B # nz (E is big) + setc # lt + ret + end + # A is big + cnt E # E short? + if nz # Yes + clrc # gt (E is short) + ret + end + # Both are big + push X + push Y + ld X 0 # Clear reverse pointers + ld Y 0 + do + ld C (A BIG) # Tails equal? + cmp C (E BIG) + if eq # Yes + do + ld C (A DIG) # Compare digits + cmp C (E DIG) + while eq + null X # End of reversed list? + if z # Yes + pop Y # eq + pop X + ret + end + ld C (X BIG) # Restore A + ld (X BIG) A + ld A X + ld X C + ld C (Y BIG) # Restore E + ld (Y BIG) E + ld E Y + ld Y C + loop + push F + break T + end + cnt C # End of A? + if nz # Yes + cnt (E BIG) # Also end of E? + if nz # Yes + cmp C (E BIG) # F + else + or B B # nz (E is bigger) + setc # lt + end + push F + break T + end + cnt (E BIG) # End of E? + if nz # Yes + clrc # gt + push F + break T + end + ld (A BIG) X # Reverse A + ld X A + ld A C + ld C (E BIG) # Reverse E + ld (E BIG) Y + ld Y E + ld E C + loop + do + null X # Reversed? + while nz # Yes + ld C (X BIG) # Restore A + ld (X BIG) A + ld A X + ld X C + ld C (Y BIG) # Restore E + ld (Y BIG) E + ld E Y + ld Y C + loop + pop F # Return flags + pop Y + pop X + ret + +### Conversions ### +# Make number from symbol +(code 'symToNumXA_FE 0) + link + push ZERO # <L I> Safe + link + push A # <L -I> Scale + push 0 # <L -II> Sign flag + push 0 # <L -III> Fraction flag + ld C 0 + call symByteCX_FACX # Get first byte + jz 99 # None + do + cmp B 32 # Skip white space + while le + call symByteCX_FACX # Next byte + jz 99 # None + loop + cmp B (char "+") # Plus sign? + jz 10 # Yes + cmp B (char "-") # Plus sign? + if eq # Yes + or (L -II) 1 # Set Sign +10 call symByteCX_FACX # Next byte + jz 99 # None + end + sub A (char "0") # First digit + cmp A 10 # Too big? + jnc 99 # Return NO + shl A 4 # Make short number + or A CNT + ld (L I) A # Save + do + call symCharCX_FACX # More? + while nz # Yes + test (L -III) 1 # Fraction? + if nz # Yes + null (L -I) # Scale? + if z # No + sub A (char "0") # Next digit + cmp A 10 # Too big? + jnc 99 # Return NO + cmp A 5 # Round? + if ge # Yes + ld A ONE # Increment + ld E (L I) + push C + call adduAE_A + pop C + ld (L I) A + end + do + call symByteCX_FACX # More? + while nz # Yes + sub A (char "0") # Next digit + cmp A 10 # Too big? + jnc 99 # Return NO + loop + break T + end + end + cmp A (Sep0) # Decimal separator? + if eq # Yes + test (L -III) 1 # Fraction? + jnz 99 # Return NO + or (L -III) 1 # Set Fraction + else + cmp A (Sep3) # Thousand separator? + if ne # No + sub A (char "0") # Next digit + cmp A 10 # Too big? + jnc 99 # Return NO + push C # Save symByte args + push X + push A # Save digit + ld A (L I) # Multiply number by 10 + call tenfoldA_A + ld (L I) A # Save + pop E # Get digit + shl E 4 # Make short number + or E CNT + call adduAE_A # Add to number + ld (L I) A # Save again + pop X # Pop symByte args + pop C + test (L -III) 1 # Fraction? + if nz # Yes + sub (L -I) 1 # Decrement Scale + end + end + end + loop + test (L -III) 1 # Fraction? + if nz # Yes + do + sub (L -I) 1 # Decrement Scale + while nc # >= 0 + ld A (L I) # Multiply number by 10 + call tenfoldA_A + ld (L I) A # Save + loop + end + ld E (L I) # Get result + test (L -II) 1 # Sign? + if nz # Yes + zero E # Zero? + if ne # No + xor E SIGN # Negate + end + end + setc # Return YES +99 drop + ret + +# Format number to output, length, or symbol +(code 'fmtNum0AE_E 0) + ld (Sep3) 0 # Thousand separator 0 + ld (Sep0) 0 # Decimal separator 0 +(code 'fmtNumAE_E) + push C + push X + push Y + push Z + link + push ZERO # <L I> Name + link + push A # <L -I> Scale + ld A E # Get number + cnt A # Short number? + if nz # Yes + push 16 # <L -II> mask + else + push 1 # <L -II> mask + end + shr B 3 # Get sign bit + push A # <L -III> Sign flag + off E SIGN + # Calculate buffer size + ld A 19 # Decimal length of 'cnt' (60 bit) + ld C E # Get number + do + cnt C # Last digit? + while z # No + add A 20 # Add decimal length of 'digit' (64 bit) + ld C (C BIG) + loop + add A 17 # Round up + ld C 0 # Divide by 18 + div 18 + shl A 3 # Word count + sub S A # Space for incrementor + ld (S) 1 # Init to '1' + ld X S # Keep pointer to incrementor in X + sub S A # <S III> Accumulator + ld (S) 0 # Init to '0' + push S # <S II> Top of accumulator + push X # <S I> Pointer to incrementor + push X # <S> Top of incrementor + do + cnt E # Short number? + ldnz Z E # Yes + if z + ld Z (E DIG) # Digit in Z + end + do + ld A Z # Current digit + test A (L -II) # Test next bit with mask + if nz + # Add incrementor to accumulator + ld C 0 # Carry for BCD addition + lea X (S III) # Accumulator + ld Y (S I) # Incrementor + do + cmp X (S II) # X > Top of accumulator? + if gt # Yes + add (S II) 8 # Extend accumulator + ld (X) 0 # with '0' + end + ld A (X) + add A (Y) # Add BCD + add A C # Add BCD-Carry + ld C 0 # Clear BCD-Carry + cmp A 1000000000000000000 # BCD overflow? + if nc # Yes + sub A 1000000000000000000 + ld C 1 # Set BCD-Carry + end + ld (X) A # Store BCD digit in accumulator + add X 8 + add Y 8 + cmp Y (S) # Reached top of incrementor? + until gt # Yes + null C # BCD-Carry? + if ne # Yes + add (S II) 8 # Extend accumulator + ld (X) 1 # With '1' + end + end + # Shift incrementor left + ld C 0 # Clear BCD-Carry + ld Y (S I) # Incrementor + do + ld A (Y) + add A A # Double + add A C # Add BCD-Carry + ld C 0 # Clear BCD-Carry + cmp A 1000000000000000000 # BCD overflow? + if nc # Yes + sub A 1000000000000000000 + ld C 1 # Set BCD-Carry + end + ld (Y) A # Store BCD digit in incrementor + add Y 8 + cmp Y (S) # Reached top of incrementor? + until gt # Yes + null C # BCD-Carry? + if ne # Yes + add (S) 8 # Extend incrementor + ld (Y) 1 # With '1' + end + shl (L -II) 1 # Shift bit mask + until z + cnt E # Short number? + while z # No + ld E (E BIG) # Next digit + cnt E # Short number? + if nz # Yes + ld A 16 # Mask + else + ld A 1 + end + ld (L -II) A # Set bit mask + loop + ld Y (S II) # Top of accumulator + lea Z (S III) # Accumulator + null (L -I) # Scale negative? + if s # Yes + cmp (L -I) -1 # Direct print? + if eq # Yes + test (L -III) 1 # Sign? + if nz # Yes + ld B (char "-") # Output sign + call (EnvPutB) + end + ld A (Y) # Output highest word + call outWordA + do + sub Y 8 # More? + cmp Y Z + while ge # Yes + ld A (Y) # Output words in reverse order + ld E 100000000000000000 # Digit scale + do + ld C 0 # Divide by digit scale + div E + push C # Save remainder + add B (char "0") # Output next digit + call (EnvPutB) + cmp E 1 # Done? + while ne # No + ld C 0 # Divide digit scale by 10 + ld A E + div 10 + ld E A + pop A # Get remainder + loop + loop + else # Calculate length + ld A Y # Top of accumulator + sub A Z # Accumulator + shr A 3 # Number of accumulator words + mul 18 # Number of digits + ld E A + ld A (Y) # Length of highest word + do + add E 1 # Increment length + ld C 0 # Divide by 10 + div 10 + null A # Done? + until z # Yes + test (L -III) 1 # Sign? + if nz # Yes + add E 1 # Space for '-' + end + shl E 4 # Make short number + or E CNT + end + drop + else + ld C 4 # Build name + lea X (L I) + test (L -III) 1 # Sign? + if nz # Yes + ld B (char "-") # Insert sign + call byteSymBCX_CX + end + push C # Save name index + ld A Y # Top of accumulator + sub A Z # Accumulator + shr A 3 # Number of accumulator words + mul 18 # Number of digits + ld E A # Calculate length-1 + ld A (Y) # Highest word + do + ld C 0 # Divide by 10 + div 10 + null A # Done? + while nz # No + add E 1 # Increment length + loop + pop C # Restore name index + sub E (L -I) # Scale + ld (L -I) E # Decrement by Length-1 + if lt # Scale < 0 + ld B (char "0") # Prepend '0' + call byteSymBCX_CX + ld A (Sep0) # Prepend decimal separator + call charSymACX_CX + do + cmp (L -I) -1 # Scale + while lt + add (L -I) 1 # Increment scale + ld B (char "0") # Ouput zeroes + call byteSymBCX_CX + loop + end + ld A (Y) # Pack highest word + call fmtWordACX_CX + do + sub Y 8 # More? + cmp Y Z + while ge # Yes + ld A (Y) # Pack words in reverse order + ld E 100000000000000000 # Digit scale + do + push A + call fmtScaleCX_CX # Handle scale character(s) + pop A + push C # Save name index + ld C 0 # Divide by digit scale + div E + xchg C (S) # Save remainder, restore name index + add B (char "0") # Pack next digit + call byteSymBCX_CX + cmp E 1 # Done? + while ne # No + push C # Save name index + ld C 0 # Divide digit scale by 10 + ld A E + div 10 + pop C # Restore name index + ld E A + pop A # Get remainder + loop + loop + ld X (L I) # Get name + drop + call consSymX_E + end + pop Z + pop Y + pop X + pop C + ret + +(code 'fmtWordACX_CX 0) + cmp A 9 # Single digit? + if gt # No + ld E C # Save C + ld C 0 # Divide by 10 + div 10 + push C # Save remainder + ld C E # Restore C + call fmtWordACX_CX # Recurse + call fmtScaleCX_CX # Handle scale character(s) + pop A + end + add B (char "0") # Make ASCII digit + jmp byteSymBCX_CX + +(code 'fmtScaleCX_CX 0) + null (L -I) # Scale null? + if z # Yes + ld A (Sep0) # Output decimal separator + call charSymACX_CX + else + null (Sep3) # Thousand separator? + if nz # Yes + ld A (L -I) # Scale > 0? + null A + if nsz # Yes + push C + ld C 0 # Modulus 3 + div 3 + null C + pop C + if z + ld A (Sep3) # Output thousand separator + call charSymACX_CX + end + end + end + end + sub (L -I) 1 # Decrement scale + ret + +# (format 'num ['cnt ['sym1 ['sym2]]]) -> sym +# (format 'sym ['cnt ['sym1 ['sym2]]]) -> num +(code 'doFormat 2) + push X + push Y + ld X E + ld Y (E CDR) # Y on args + ld E (Y) # Eval first + eval + link + push E # <L I> 'num' | 'sym' + link + atom E # Need atom + jz atomErrEX + ld Y (Y CDR) # Second arg + ld E (Y) + eval # Eval 'cnt' + cmp E Nil # Any? + if eq # No + ld E 0 # Zero + else + call xCntEX_FE # Extract 'cnt' + end + push E # <L -I> Scale + push (char ".") # <L -II> Sep0 + push 0 # Sep3 + ld Y (Y CDR) # Third arg? + atom Y + if z # Yes + ld E (Y) + eval # Eval 'sym1' + num E # Need symbol + jnz symErrEX + sym E + jz symErrEX + call firstCharE_A + ld (L -II) A # Sep0 + ld Y (Y CDR) # Fourth arg? + atom Y + if z # Yes + ld E (Y) + eval # Eval 'sym2' + num E # Need symbol + jnz symErrEX + sym E + jz symErrEX + call firstCharE_A + ld (S) A + end + end + pop (Sep3) # Get Sep3 + pop (Sep0) # and Sep0 + pop A # Get scale + ld E (L I) # Get 'num' | 'sym' + num E # Number? + if nz # Yes + call fmtNumAE_E # Convert to string + else + ld X (E TAIL) + call nameX_X # Get name + call symToNumXA_FE # Convert to number + if nc # Failed + ld E Nil + end + end + drop + pop Y + pop X + ret + +### Arithmetics ### +# (+ 'num ..) -> num +(code 'doAdd 2) + push X + push Y + ld X E + ld Y (E CDR) # Y on args + ld E (Y) + eval # Eval first arg + cmp E Nil + if ne # Non-NIL + num E # Number? + jz numErrEX # No + link + push ZERO # <L II> Safe + push E # <L I> Result + link + do + ld Y (Y CDR) # More args? + atom Y + while z # Yes + ld E (Y) + eval # Eval next arg + cmp E Nil + jz 10 # Abort if NIL + num E # Number? + jz numErrEX # No + ld (L II) E # Save arg + ld A (L I) # Result + call addAE_A # Add + ld (L I) A # Result + loop + ld E (L I) # Result +10 drop + end + pop Y + pop X + ret + +# (- 'num ..) -> num +(code 'doSub 2) + push X + push Y + ld X E + ld Y (E CDR) # Y on args + ld E (Y) + eval # Eval first arg + cmp E Nil + if ne # Non-NIL + num E # Number? + jz numErrEX # No + ld Y (Y CDR) # More than one arg? + atom Y + if nz # No: Unary minus + zero E # Zero? + if ne # No + xor E SIGN # Negate + end + else + link + push ZERO # <L II> Safe + push E # <L I> Result + link + do + ld E (Y) + eval # Eval next arg + cmp E Nil + jz 10 # Abort if NIL + num E # Number? + jz numErrEX # No + ld (L II) E # Save arg + ld A (L I) # Result + call subAE_A # Subtract + ld (L I) A # Result + ld Y (Y CDR) # More args? + atom Y + until nz # No + ld E (L I) # Result +10 drop + end + end + pop Y + pop X + ret + +# (inc 'num) -> num +# (inc 'var ['num]) -> num +(code 'doInc 2) + push X + push Y + ld X E + ld Y (E CDR) # Y on args + ld E (Y) + eval # Eval first arg + cmp E Nil + if ne # Non-NIL + link + push E # <L I/II> First arg + link + num E # Number? + if nz # Yes + call incE_A # Increment it + else + call checkVarEX + sym E # Symbol? + if nz # Yes + sym (E TAIL) # External symbol? + if nz # Yes + call dbTouchEX # Touch it + end + end + ld Y (Y CDR) # Next arg? + atom Y + if nz # No + ld E (E) # Get VAL + cmp E Nil # NIL? + ldz A E + if ne # No + num E # Number? + jz numErrEX # No + call incE_A # Increment it + ld ((L I)) A # Set new value + end + else + ld E (Y) + eval # Eval next arg + tuck E # <L I> Second arg + link + ld A ((L II)) # First arg's VAL + cmp A Nil # NIL? + if ne # No + num A # Number? + jz numErrAX # No + ld E (L I) # Second arg + cmp E Nil # NIL? + ldz A E + if ne # No + num E + jz numErrEX # No + call addAE_A # Add + ld ((L II)) A # Set new value + end + end + end + end + ld E A # Get result + drop + end + pop Y + pop X + ret + +# (dec 'num) -> num +# (dec 'var ['num]) -> num +(code 'doDec 2) + push X + push Y + ld X E + ld Y (E CDR) # Y on args + ld E (Y) + eval # Eval first arg + cmp E Nil + if ne # Non-NIL + link + push E # <L I/II> First arg + link + num E # Number? + if nz # Yes + call decE_A # Decrement it + else + call checkVarEX + sym E # Symbol? + if nz # Yes + sym (E TAIL) # External symbol? + if nz # Yes + call dbTouchEX # Touch it + end + end + ld Y (Y CDR) # Next arg? + atom Y + if nz # No + ld E (E) # Get VAL + cmp E Nil # NIL? + ldz A E + if ne # No + num E # Number? + jz numErrEX # No + call decE_A # Decrement it + ld ((L I)) A # Set new value + end + else + ld E (Y) + eval # Eval next arg + tuck E # <L I> Second arg + link + ld A ((L II)) # First arg's VAL + cmp A Nil # NIL? + if ne # No + num A # Number? + jz numErrAX # No + ld E (L I) # Second arg + cmp E Nil # NIL? + ldz A E + if ne # No + num E + jz numErrEX # No + call subAE_A # Subtract + ld ((L II)) A # Set new value + end + end + end + end + ld E A # Get result + drop + end + pop Y + pop X + ret + +# (* 'num ..) -> num +(code 'doMul 2) + push X + push Y + ld X E + ld Y (E CDR) # Y on args + ld E (Y) + eval # Eval first arg + cmp E Nil + if ne # Non-NIL + num E # Number? + jz numErrEX # No + ld B 0 # Init sign + test E SIGN + if nz + off E SIGN + add B 1 + end + link + push ZERO # <L II> Safe + push E # <L I> Result + link + push A # <L -I> Sign flag + do + ld Y (Y CDR) # More args? + atom Y + while z # Yes + ld E (Y) + eval # Eval next arg + cmp E Nil + jz 10 # Abort if NIL + num E # Number? + jz numErrEX # No + test E SIGN # Arg negative? + if nz # Yes + off E SIGN # Make argument positive + xor (L -I) 1 # Toggle result sign + end + ld (L II) E # Save arg + ld A (L I) # Result + call muluAE_A # Multiply + ld (L I) A # Result + loop + ld E (L I) # Result + test (L -I) 1 # Sign? + if nz # Yes + zero E # Zero? + if ne # No + or E SIGN # Set negative + end + end +10 drop + end + pop Y + pop X + ret + +# (*/ 'num1 ['num2 ..] 'num3) -> num +(code 'doMulDiv 2) + push X + push Y + ld X E + ld Y (E CDR) # Y on args + ld E (Y) + eval # Eval first arg + cmp E Nil + if ne # Non-NIL + num E # Number? + jz numErrEX # No + ld B 0 # Init sign + test E SIGN + if nz + off E SIGN + add B 1 + end + link + push ZERO # <L II> Safe + push E # <L I> Result + link + push A # <L -I> Sign flag + do + ld Y (Y CDR) # Next arg + ld E (Y) + eval # Eval next arg + cmp E Nil + jz 10 # Abort if NIL + num E # Number? + jz numErrEX # No + test E SIGN # Arg negative? + if nz # Yes + off E SIGN # Make argument positive + xor (L -I) 1 # Toggle result sign + end + ld (L II) E # Save arg + atom (Y CDR) # More args? + while z # Yes + ld A (L I) # Result + call muluAE_A # Multiply + ld (L I) A # Result + loop + zero E # Zero? + jeq divErrX # Yes + ld A E # Last argument + call shruA_A # / 2 + ld E (L I) # Product + call adduAE_A # Add for rounding + ld E (L II) # Last argument + call divuAE_AC # Divide + ld E A # Result + test (L -I) 1 # Sign? + if nz # Yes + zero E # Zero? + if ne # No + or E SIGN # Set negative + end + end +10 drop + end + pop Y + pop X + ret + +# (/ 'num ..) -> num +(code 'doDiv 2) + push X + push Y + ld X E + ld Y (E CDR) # Y on args + ld E (Y) + eval # Eval first arg + cmp E Nil + if ne # Non-NIL + num E # Number? + jz numErrEX # No + ld B 0 # Init sign + test E SIGN + if nz + off E SIGN + add B 1 + end + link + push ZERO # <L II> Safe + push E # <L I> Result + link + push A # <L -I> Sign flag + do + ld Y (Y CDR) # More args? + atom Y + while z # Yes + ld E (Y) + eval # Eval next arg + cmp E Nil + jz 10 # Abort if NIL + num E # Number? + jz numErrEX # No + zero E # Zero? + jeq divErrX # Yes + test E SIGN # Arg negative? + if nz # Yes + off E SIGN # Make argument positive + xor (L -I) 1 # Toggle result sign + end + ld (L II) E # Save arg + ld A (L I) # Result + call divuAE_AC # Divide + ld (L I) A # Result + loop + ld E (L I) # Result + test (L -I) 1 # Sign? + if nz # Yes + zero E # Zero? + if ne # No + or E SIGN # Set negative + end + end +10 drop + end + pop Y + pop X + ret + +# (% 'num ..) -> num +(code 'doRem 2) + push X + push Y + ld X E + ld Y (E CDR) # Y on args + ld E (Y) + eval # Eval first arg + cmp E Nil + if ne # Non-NIL + num E # Number? + jz numErrEX # No + ld B 0 # Init sign + test E SIGN + if nz + off E SIGN + ld B 1 + end + link + push ZERO # <L II> Safe + push E # <L I> Result + link + push A # <L -I> Sign flag + do + ld Y (Y CDR) # More args? + atom Y + while z # Yes + ld E (Y) + eval # Eval next arg + cmp E Nil + jz 10 # Abort if NIL + num E # Number? + jz numErrEX # No + zero E # Zero? + jeq divErrX # Yes + off E SIGN # Make argument positive + ld (L II) E # Save arg + ld A (L I) # Result + call divuAE_AC # Divide + ld (L I) C # Result + loop + ld E (L I) # Result + test (L -I) 1 # Sign? + if nz # Yes + zero E # Zero? + if ne # No + or E SIGN # Set negative + end + end +10 drop + end + pop Y + pop X + ret + +# (>> 'cnt 'num) -> num +(code 'doShift 2) + push X + push Y + ld X E + ld Y (E CDR) # Y on args + call evCntXY_FE # Get shift count + link + push ZERO # <L I> Safe + link + push E # <L -I> Shift count + ld Y (Y CDR) # Second arg + ld E (Y) + eval # Eval number + cmp E Nil # Any? + if nz # Yes + num E # Number? + jz numErrEX # No + ld A E # Number in A + off A SIGN # Make positive + and E SIGN # Sign bit + push E # <L -II> Sign bit + null (L -I) # Shift count? + if nz # Yes + if ns # Positive + call shruA_A # Non-destructive + ld (L I) A + do + sub (L -I) 1 # Shift count? + while nz + call halfA_A # Shift right (destructive) + ld (L I) A + loop + else + call shluA_A # Non-destructive + ld (L I) A + do + add (L -I) 1 # Shift count? + while nz + call twiceA_A # Shift left (destructive) + ld (L I) A + loop + end + end + zero A # Result zero? + if ne # No + or A (L -II) # Sign bit + end + ld E A # Get result + end + drop + pop Y + pop X + ret + +# (lt0 'any) -> num | NIL +(code 'doLt0 2) + ld E (E CDR) # Get arg + ld E (E) + eval # Eval it + num E # Number? + jz retNil + test E SIGN # Negative? + jz retNil + ret # Yes: Return num + +# (ge0 'any) -> num | NIL +(code 'doGe0 2) + ld E (E CDR) # Get arg + ld E (E) + eval # Eval it + num E # Number? + jz retNil + test E SIGN # Positive? + jnz retNil + ret # Yes: Return num + +# (gt0 'any) -> num | NIL +(code 'doGt0 2) + ld E (E CDR) # Get arg + ld E (E) + eval # Eval it + num E # Number? + jz retNil + zero E # Zero? + jeq retNil + test E SIGN # Positive? + jnz retNil + ret # Yes: Return num + +# (abs 'num) -> num +(code 'doAbs 2) + push X + ld X E + ld E (E CDR) # Get arg + ld E (E) + eval # Eval it + cmp E Nil # Any? + if nz # Yes + num E # Number? + jz numErrEX # No + off E SIGN # Clear sign + end + pop X + ret + +### Bit operations ### +# (bit? 'num ..) -> num | NIL +(code 'doBitQ 2) + push X + push Y + ld X E + ld Y (E CDR) # Y on args + ld E (Y) + eval # Eval first arg + num E # Number? + jz numErrEX # No + off E SIGN # Clear sign + link + push E # <L I> Bit mask + link + do + ld Y (Y CDR) # More args? + atom Y + while z # Yes + ld E (Y) + eval # Eval next arg + cmp E Nil + while ne # Abort if NIL + num E # Number? + jz numErrEX # No + off E SIGN # Clear sign + ld C (L I) # Get mask + do + cnt C # C short? + while z # No + cnt E # E short? + jnz 10 # Yes: Return NIL + ld A (E DIG) # Get digit + and A (C DIG) # Match? + cmp A (C DIG) + jnz 10 # No: Return NIL + ld C (C BIG) + ld E (E BIG) + loop + cnt E # E also short? + if z # No + shr C 4 # Normalize + ld E (E DIG) # Get digit + end + and E C # Match? + cmp E C + if ne # No +10 ld E Nil # Return NIL + drop + pop Y + pop X + ret + end + loop + ld E (L I) # Return bit mask + drop + pop Y + pop X + ret + +# (& 'num ..) -> num +(code 'doBitAnd 2) + push X + push Y + ld X E + ld Y (E CDR) # Y on args + ld E (Y) + eval # Eval first arg + cmp E Nil + if ne # Non-NIL + num E # Number? + jz numErrEX # No + off E SIGN # Clear sign + link + push ZERO # <L II> Safe + push E # <L I> Result + link + do + ld Y (Y CDR) # More args? + atom Y + while z # Yes + ld E (Y) + eval # Eval next arg + cmp E Nil + jz 10 # Abort if NIL + num E # Number? + jz numErrEX # No + off E SIGN # Clear sign + ld (L II) E # Save arg + ld A (L I) # Result + call anduAE_A # Bitwise AND + ld (L I) A # Result + loop + ld E (L I) # Result +10 drop + end + pop Y + pop X + ret + +# (| 'num ..) -> num +(code 'doBitOr 2) + push X + push Y + ld X E + ld Y (E CDR) # Y on args + ld E (Y) + eval # Eval first arg + cmp E Nil + if ne # Non-NIL + num E # Number? + jz numErrEX # No + off E SIGN # Clear sign + link + push ZERO # <L II> Safe + push E # <L I> Result + link + do + ld Y (Y CDR) # More args? + atom Y + while z # Yes + ld E (Y) + eval # Eval next arg + cmp E Nil + jz 10 # Abort if NIL + num E # Number? + jz numErrEX # No + off E SIGN # Clear sign + ld (L II) E # Save arg + ld A (L I) # Result + call oruAE_A # Bitwise OR + ld (L I) A # Result + loop + ld E (L I) # Result +10 drop + end + pop Y + pop X + ret + +# (x| 'num ..) -> num +(code 'doBitXor 2) + push X + push Y + ld X E + ld Y (E CDR) # Y on args + ld E (Y) + eval # Eval first arg + cmp E Nil + if ne # Non-NIL + num E # Number? + jz numErrEX # No + off E SIGN # Clear sign + link + push ZERO # <L II> Safe + push E # <L I> Result + link + do + ld Y (Y CDR) # More args? + atom Y + while z # Yes + ld E (Y) + eval # Eval next arg + cmp E Nil + jz 10 # Abort if NIL + num E # Number? + jz numErrEX # No + off E SIGN # Clear sign + ld (L II) E # Save arg + ld A (L I) # Result + call xoruAE_A # Bitwise XOR + ld (L I) A # Result + loop + ld E (L I) # Result +10 drop + end + pop Y + pop X + ret + +### Random generator ### +(code 'initSeedE_E 0) + push C # Counter + ld C 0 + do + atom E # Cell? + while z # Yes + push E # Recurse on CAR + ld E (E) + call initSeedE_E + add C E + pop E # Loop on CDR + ld E (E CDR) + loop + cmp E Nil # NIL? + if ne # No + num E # Need number + if z # Must be symbol + ld E (E TAIL) + call nameE_E # Get name + end + do + cnt E # Short? + while z # No + add C (E DIG) # Add next digit + ld E (E BIG) + loop + add C E # Add final short + end + ld E C # Return counter + pop C + ret + +# (seed 'any) -> cnt +(code 'doSeed 2) + ld E (E CDR) # Get arg + ld E (E) + eval # Eval it + call initSeedE_E # Initialize 'Seed' + ld A 6364136223846793005 # Multiplier + mul E # times 'Seed' + add D 1 # plus 1 + ld (Seed) D # Save + ld E (Seed 4) # Get high halfword + off E 7 # Keep sign + or E CNT # Make short number + ret + +# (rand ['cnt1 'cnt2] | ['T]) -> cnt | flg +(code 'doRand 2) + push X + push Y + ld X E + ld Y (E CDR) # Y on args + ld A 6364136223846793005 # Multiplier + mul (Seed) # times 'Seed' + add D 1 # plus 1 + ld (Seed) D # Save + ld E (Y) + eval # Eval first arg + cmp E Nil # Any + if eq # No + ld E (Seed 4) # Get high halfword + off E 7 # Keep sign + or E CNT # Make short number + pop Y + pop X + ret + end + cmp E TSym # Boolean + if eq + ld A (Seed) + rcl A 1 # Highest bit? + if nc # No + ld E Nil # Return NIL + end # else return T + pop Y + pop X + ret + end + call xCntEX_FE # Get cnt1 + push E # Save it + ld Y (Y CDR) # Second arg + call evCntXY_FE # Get cnt2 + add E 1 # Seed % (cnt2 + 1 - cnt1) + cnt1 + sub E (S) + ld A (Seed 4) # Get high halfword + ld C 0 + div E # Modulus in C + pop E # + cnt1 + add E C + pop Y + pop X + jmp boxCntE_E # Return short number + +# vi:et:ts=3:sw=3 diff --git a/src64/db.l b/src64/db.l @@ -0,0 +1,2249 @@ +# 08mar10abu +# (c) Software Lab. Alexander Burger + +# 6 bytes in little endian format +# Get block address from buffer +(code 'getAdrZ_A 0) + ld B (Z 5) # Highest byte + zxt + shl A 8 + ld B (Z 4) + shl A 8 + ld B (Z 3) + shl A 8 + ld B (Z 2) + shl A 8 + ld B (Z 1) + shl A 8 + ld B (Z) # Lowest byte + ret + +# Set block address in buffer +(code 'setAdrAZ 0) + ld (Z) B # Lowest byte + shr A 8 + ld (Z 1) B + shr A 8 + ld (Z 2) B + shr A 8 + ld (Z 3) B + shr A 8 + ld (Z 4) B + shr A 8 + ld (Z 5) B # Highest byte + ret + +(code 'setAdrAS 0) + ld (S (+ I 2)) B # Write block address to stack + shr A 8 + ld (S (+ I 3)) B + shr A 8 + ld (S (+ I 4)) B + shr A 8 + ld (S (+ I 5)) B + shr A 8 + ld (S (+ I 6)) B + shr A 8 + ld (S (+ I 7)) B # Highest byte + ret + +# Read file number from 'Buf' into 'DbFile' +(code 'dbfBuf_AF 0) + ld B (Buf 1) # Two bytes little endian + zxt + shl A 8 + ld B (Buf) + shl A 6 # 'dbFile' index + cmp A (DBs) # Local file? + jge retc # No + add A (DbFiles) # Get DB file + ld (DbFile) A # Set current + ret # 'nc' + +# Build external symbol name +(code 'extNmCE_X 0) + ld X C # Get object ID into X + and X (hex "FFFFF") # Lowest 20 bits + shr C 20 # Middle part of object ID + ld A C + and A (hex "FFF") # Lowest 12 bits + shl A 28 + or X A # into X + shr C 12 # Rest of object ID + shl C 48 + or X C # into X + ld A E # Get file number + and A (hex "FF") # Lowest 8 bits + shl A 20 # Insert + or X A # into X + shr E 8 # Rest of file number + shl E 40 + or X E # into X + shl X 4 # Make short name + or X CNT + ret + +# Pack external symbol name +(code 'packExtNmX_E) + link + push ZERO # <L I> Name + link + call fileObjX_AC # Get file and object ID + push C # Save object ID + ld C 4 # Build name + lea X (L I) + null A # Any? + if nz # Yes + call packAoACX_CX # Pack file number + end + pop A # Get object ID + call packOctACX_CX # Pack it + call cons_E # Cons symbol + ld (E) (L I) # Set name + or E SYM # Make symbol + ld (E) E # Set value to itself + drop + ret + +(code 'packAoACX_CX 0) + cmp A 15 # Single digit? + if gt # No + push A # Save + shr A 4 # Divide by 16 + call packAoACX_CX # Recurse + pop A + and B 15 # Get remainder + end + add B (char "@") # Make ASCII letter + jmp byteSymBCX_CX # Pack byte + +(code 'packOctACX_CX 0) + cmp A 7 # Single digit? + if gt # No + push A # Save + shr A 3 # Divide by 8 + call packOctACX_CX # Recurse + pop A + and B 7 # Get remainder + end + add B (char "0") # Make ASCII digit + jmp byteSymBCX_CX # Pack byte + +# Chop external symbol name +(code 'chopExtNmX_E) + call fileObjX_AC # Get file and object ID + ld X A # Keep file in X + call oct3C_CA # Get lowest octal digits + call consA_E # Final cell + ld (E) A + ld (E CDR) Nil + link + push E # <L I> Result + link + do + shr C 3 # Higher octal digits? + while nz # Yes + call oct3C_CA # Get next three digits + call consA_E # Cons into result + ld (E) A + ld (E CDR) (L I) + ld (L I) E + loop + null X # File number? + if nz # Yes + ld E 0 # Build A-O encoding + ld A 0 + do + ld B X # Next hax digit + and B 15 # Lowest four bits + add B (char "@") # Make ASCII letter + or E B + shr X 4 # More hax digits? + while nz # Yes + shl E 8 # Shift result + loop + shl E 4 # Make short name + or E CNT + call cons_A # Make transient symbol + ld (A) E # Set name + or A SYM # Make symbol + ld (A) A # Set value to itself + call consA_E # Cons into result + ld (E) A + ld (E CDR) (L I) + ld (L I) E + end + ld E (L I) # Get result + drop + ret + +(code 'oct3C_CA 0) + ld A 0 + ld B C # Lowest octal digit + and B 7 + add B (char "0") # Make ASCII digit + ld E A + shr C 3 # Next digit? + if nz # Yes + ld B C # Second octal digit + and B 7 + add B (char "0") # Make ASCII digit + shl E 8 + or E B + shr C 3 # Next digit? + if nz # Yes + ld B C # Hightest octal digit + and B 7 + add B (char "0") # Make ASCII digit + shl E 8 + or E B + end + end + shl E 4 # Make short name + or E CNT + call cons_A # Make transient symbol + ld (A) E # Set name + or A SYM # Make symbol + ld (A) A # Set value to itself + ret + +# Get file and object ID from external symbol name +(code 'fileObjX_AC 0) + shl X 2 # Strip status bits + shr X 6 # Normalize + ld C X # Get object ID + and C (hex "FFFFF") # Lowest 20 bits + shr X 20 # Get file number + ld A X + and A (hex "FF") # Lowest 8 bits + shr X 8 # More? + if nz # Yes + ld E X # Rest in E + and E (hex "FFF") # Middle 12 bits of object ID + shl E 20 + or C E # into C + shr X 12 # High 8 bits of file number + ld E X # into E + and E (hex "FF") # Lowest 8 bits + shl E 8 + or A E # into A + shr X 8 # Rest of object ID + shl X 32 + or C X # into C + end + ret + +# Get file and object ID from external symbol +(code 'fileObjE_AC 0) + push X + ld X (E TAIL) + call nameX_X # Get name + call fileObjX_AC + pop X + ret + +# Get dbFile index and block index from external symbol +(code 'dbFileBlkY_AC 0) + push X + ld X Y # Name in X + call fileObjX_AC + shl A 6 # 'dbFile' index + shl C 6 # Block index + pop X + ret + +(code 'rdLockDb) + cmp (Solo) TSym # Already locked whole DB? + if ne # No + ld A (| F_RDLCK (hex "10000")) # Read lock, length 1 + ld C ((DbFiles)) # Descriptor of first file + jmp lockFileAC + end + ret + +(code 'wrLockDb) + cmp (Solo) TSym # Already locked whole DB? + if ne # No + ld A (| F_WRLCK (hex "10000")) # Write lock, length 1 + ld C ((DbFiles)) # Descriptor of first file + jmp lockFileAC + end + ret + +(code 'rwUnlockDbA) + cmp (Solo) TSym # Already locked whole DB? + if ne # No + null A # Length zero? + if z # Yes + push X + push Y + ld X (DbFiles) # Iterate DB files + ld Y (DBs) # Count + do + sub Y VIII # Done? + while ne # No + add X VIII # Skip first, increment by sizeof(dbFile) + nul (X (+ IV 0)) # This one locked? + if nz # Yes + ld A (| F_UNLCK (hex "00000")) # Unlock, length 0 + ld C (X) # File descriptor + call unLockFileAC + set (X (+ IV 0)) 0 # Clear lock entry + end + loop + pop Y + pop X + ld (Solo) ZERO # Reset solo mode + ld A 0 # Length zero again + end + or A F_UNLCK + ld C ((DbFiles)) # Unlock first file + call unLockFileAC + end + ret + +(code 'tryLockCE_FA) + do + ld (Flock L_START) C # Start position ('l_whence' is SEEK_SET) + ld (Flock L_LEN) E # Length + ld A F_WRLCK # Write lock + st2 (Flock) # 'l_type' + cc fcntl(((DbFile)) F_SETLK Flock) # Try to lock + nul4 # OK? + if ns # Yes + set ((DbFile) (+ IV 0)) 1 # Set lock flag + null C # 'Start position is zero? + if z # Yes + ld (Solo) TSym # Set solo mode + else + cmp (Solo) TSym # Already locked whole DB? + if ne # No + ld (Solo) Nil # Clear solo mode + end + end + setz + ret # 'z' + end + call errno_A + cmp A EINTR # Interrupted? + if ne # No + cmp A EACCES # Locked by another process? + if ne # No + cmp A EAGAIN # Memory-mapped by another process? + jne lockErr # No + end + end + #? ld A F_WRLCK # Write lock + #? st2 (Flock) # 'l_type' + ld (Flock L_START) C # Start position ('l_whence' is SEEK_SET) + ld (Flock L_LEN) E # Length + do + cc fcntl(((DbFile)) F_GETLK Flock) # Try to get lock + nul4 # OK? + while s # No + call errno_A + cmp A EINTR # Interrupted? + jne lockErr # No + loop + ld2 (Flock) # Get 'l_type' + cmp B F_UNLCK # Locked by another process? + until ne # Yes + ld4 (Flock L_PID) # Return PID + ret # 'nz' + +(code 'jnlFileno_A) + cc fileno((DbJnl)) # Get fd + ret + +(code 'logFileno_A) + cc fileno((DbLog)) # Get fd + ret + +(code 'lockJnl) + call jnlFileno_A # Get fd + ld C A # into C + jmp wrLockFileC # Write lock journal + +(code 'unLockJnl) + cc fflush((DbJnl)) # Flush journal + call jnlFileno_A # Get fd + ld C A # into C + ld A (| F_UNLCK (hex "00000")) # Unlock, length 0 + jmp unLockFileAC # Unlock journal + +(code 'setBlockAC_Z 0) + add A (DbFiles) # Get DB file +: setBlkAC_Z + ld (DbFile) A # Set current + ld (BlkIndex) C # Set block index + ld A (A III) # Block size + ld Z (DbBlock) # Get block buffer in Z + add A Z # Caclulate data end + ld (BufEnd) A + ret + +(code 'rdBlockLinkZ_Z) + ld A (BlkLink) # Next block +(code 'rdBlockIndexAZ_Z) + ld (BlkIndex) A # Set block index + ld Z (DbBlock) # Block buffer in Z +(code 'rdBlockZ_Z) + ld A (DbFile) # Get current file + ld C (A III) # Block size + ld E (BlkIndex) # Get block index in E + shl E (A II) # Shift for current file + call blkPeekCEZ # Read block + call getAdrZ_A # Get link address + off A BLKTAG + ld (BlkLink) A # Store as next block + add Z BLK # Point to block data + ret + +(code 'blkPeekCEZ) + cc pread(((DbFile)) Z C E) # Read C bytes from pos E into buffer Z + cmp A C # OK? + jne dbRdErr # No + ret + +(code 'wrBlockZ) + ld A (DbFile) # Get current file + ld C (A III) # Block size + ld E (BlkIndex) # Get block index in E + shl E (A II) # Shift for current file +(code 'blkPokeCEZ) + cc pwrite(((DbFile)) Z C E) # Write C bytes from buffer Z to pos E + cmp A C # OK? + jne dbWrErr # No + null (DbJnl) # Journal? + jz Ret # No + cmp A ((DbFile) III) # Size (in A and C) equal to current file's block size? + if eq # Yes + ld A BLKSIZE # Use block unit size instead + end + cc putc_unlocked(A (DbJnl)) # Write size + sub S (+ BLK 2) # <S> Buffer + ld A ((DbFile) I) # Get file number + ld (S) B # Store low byte + shr A 8 + ld (S 1) B # and high byte + ld A E # Get position + shr A ((DbFile) II) # Un-shift for current file + call setAdrAS # Set block address in buffer + cc fwrite(S (+ BLK 2) 1 (DbJnl)) # Write file number and address + cmp A 1 # OK? + jne wrJnlErr # No + cc fwrite(Z C 1 (DbJnl)) # Write C bytes from buffer Z + cmp A 1 # OK? + jne wrJnlErr # No + add S (+ BLK 2) # Drop buffer + ret + +(code 'logBlock) + sub S (+ BLK 2) # <S> Buffer + ld A ((DbFile) I) # Get file number + ld (S) B # Store low byte + shr A 8 + ld (S 1) B # and high byte + ld A (BlkIndex) # Get block index in E + call setAdrAS # Write into buffer + cc fwrite(S (+ BLK 2) 1 (DbLog)) # Write file number and address + cmp A 1 # OK? + jne wrLogErr # No + cc fwrite((DbBlock) ((DbFile) III) 1 (DbLog)) # Write 'siz' bytes from block buffer + cmp A 1 # OK? + jne wrLogErr # No + add S (+ BLK 2) # Drop buffer + ret + +(code 'newBlock_X) + push Z + ld C (* 2 BLK) # Read 'free' and 'next' + ld E 0 # from block zero + ld Z Buf # into 'Buf' + call blkPeekCEZ + call getAdrZ_A # 'free'? + null A + jz 10 # No + null ((DbFile) VII) # 'fluse'? + if nz # Yes + ld X A # Keep 'free' in X + ld C (DbFile) + shl A (C II) # Shift 'free' + sub (C VII) 1 # Decrement 'fluse' + ld E A # Read 'free' link + ld C BLK + call blkPeekCEZ # into 'Buf' + ld E 0 # Restore block zero in E + ld C (* 2 BLK) # and poke size in C + else +10 add Z BLK # Get 'next' + call getAdrZ_A + cmp A (hex "FFFFFFFFFFC0") # Max object ID + jeq dbSizErr # DB Oversize + ld X A # Keep in X + add A BLKSIZE # Increment 'next' + call setAdrAZ + sub Z BLK # Restore 'Buf' in Z + end + call blkPokeCEZ # Write 'Buf' back + ld C ((DbFile) III) # Current file's block size + sub S C # <S> Buffer + ld B 0 # Clear buffer + mset (S) C # with block size + ld E X # Get new block address + shl E ((DbFile) II) # Shift it + ld Z S # Write initblock + call blkPokeCEZ + add S ((DbFile) III) # Drop buffer + pop Z + ret + +(code 'newIdEX_X) + sub E 1 # Zero-based + shl E 6 # 'dbFile' index + cmp E (DBs) # In Range? + jge dbfErrX # No + add E (DbFiles) # Get DB file + ld (DbFile) E # Set current + null (DbLog) # Transaction log? + if z # No + add (EnvProtect) 1 # Protect the operation + end + call wrLockDb # Write lock DB + null (DbJnl) # Journal? + if nz # Yes + call lockJnl # Write lock journal + end + call newBlock_X # Allocate new block + ld C X # Object ID + shr C 6 # Normalize + ld E ((DbFile) I) # Get file number + call extNmCE_X # Build external symbol name + null (DbJnl) # Journal? + if nz # Yes + call unLockJnl # Unlock journal + end + ld A (hex "10000") # Length 1 + call rwUnlockDbA # Unlock + null (DbLog) # Transaction log? + if z # No + sub (EnvProtect) 1 # Unprotect + end + ret + +(code 'isLifeE_F) + push E # Save symbol + call fileObjE_AC # Get file and ID + pop E # Restore symbol + shl C 6 # Block index? + jz retnz # No + shl A 6 # 'dbFile' index + cmp A (DBs) # Local file? + if lt # Yes + add A (DbFiles) # Get DB file + ld (DbFile) A # Set current + ld A (E TAIL) # Get tail + call nameA_A # Get name + shl A 1 # Dirty? + jc retz # Yes + shl A 1 # Loaded? + jc Retz # Yes + push E + push Z + push C # Save block index + ld C BLK # Read 'next' + ld E BLK + ld Z Buf # into 'Buf' + call blkPeekCEZ + call getAdrZ_A # Get 'next' + pop C # Get block index + cmp C A # Less than 'next'? + jge retnz # No + ld E C # Block index + shl E ((DbFile) II) # Shift + ld C BLK # Read link field + call blkPeekCEZ # into 'Buf' + ld B (Z) # Get tag byte + and B BLKTAG # Block tag + cmp B 1 # One? + pop Z + pop E + else + atom (Ext) # Remote databases? + end + ret # 'z' if OK + +(code 'cleanUpY) + ld C BLK # Read 'free' + ld E 0 # from block zero + ld Z Buf # into 'Buf' + call blkPeekCEZ + call getAdrZ_A # Get 'free' + push A # Save 'free' + ld A Y # Deleted block + call setAdrAZ # Store in buffer + call blkPokeCEZ # Set new 'free' + ld E Y # Deleted block + do + shl E ((DbFile) II) # Shift it + call blkPeekCEZ # Get block link + off (Z) BLKTAG # Clear tag + call getAdrZ_A # Get link + null A # Any? + while nz # Yes + ld Y A # Keep link in Y + call blkPokeCEZ # Write link + ld E Y # Get link + loop + pop A # Retrieve 'free' + call setAdrAZ # Store in buffer + jmp blkPokeCEZ # Append old 'free' list + +(code 'getBlockZ_FB 0) + cmp Z (BufEnd) # End of block data? + if eq # Yes + ld A (BlkLink) # Next block? + null A + jz ret # No: Return 0 + push C + push E + call rdBlockIndexAZ_Z # Read block + pop E + pop C + end + ld B (Z) # Next byte + add Z 1 # (nc) + ret + +(code 'putBlockBZ 0) + cmp Z (BufEnd) # End of block data? + if eq # Yes + push A # Save byte + push C + push E + ld Z (DbBlock) # Block buffer + null (BlkLink) # Next block? + if nz # Yes + call wrBlockZ # Write current block + call rdBlockLinkZ_Z # Read next block + else + push X + call newBlock_X # Allocate new block + ld B (Z) # Get block count (link is zero) + zxt + push A # Save count + or A X # Combine with new link + call setAdrAZ # Store in current block + call wrBlockZ # Write current block + ld (BlkIndex) X # Set new block index + pop A # Retrieve count + cmp A BLKTAG # Max reached? + if ne # No + add A 1 # Increment count + end + call setAdrAZ # Store in new current block + add Z BLK # Point to block data + pop X + end + pop E + pop C + pop A # Retrieve byte + end + ld (Z) B # Store byte + add Z 1 # Increment pointer + ret + +# (pool ['sym1 ['lst] ['sym2] ['sym3]]) -> T +(code 'doPool 2) + push X + push Y + push Z + ld X E + ld Y (E CDR) # Y on args + call evSymY_E # Eval database name + link + push E # <L IV> 'sym1' + ld Y (Y CDR) + ld E (Y) # Eval scale factor list + eval+ + push E # <L III> 'lst' + link + cmp E Nil # Need list + if ne + atom E + jnz lstErrEX + end + ld Y (Y CDR) + call evSymY_E # Eval replication journal + tuck E # <L II> 'sym2' + link + ld Y (Y CDR) + call evSymY_E # Eval transaction log + tuck E # <L I> 'sym3' + link + ld (Solo) ZERO # Reset solo mode + null (DBs) # DB open? + if nz # Yes + call doRollback # Roll back possible changes + ld E (DbFiles) # Iterate DB files + ld C (DBs) # Count + do + ld A (E) # File descriptor + call closeAX # Close it + cc free((E VI)) # Free mark bit vector + add E VIII # Increment by sizeof(dbFile) + sub C VIII # Done? + until z # Yes + ld (DBs) 0 + null (DbJnl) # Journal? + if nz # Yes + cc fclose((DbJnl)) # Close it + ld (DbJnl) 0 + end + null (DbLog) # Transaction log? + if nz # Yes + cc fclose((DbLog)) # Close it + ld (DbLog) 0 + end + end + ld E (L IV) # Database name + cmp E Nil # Given? + if ne # Yes + push A # 8 bytes additional buffer space + call pathStringE_SZ # <S II> DB name + slen C S # String length in C + add C S # Add to buffer + push C # <S I> DB name end pointer + ld E VIII # Default to single dbFile + ld A (L III) # Get scale factor list + atom A # Any? + if z # Yes + ld E 0 # Calculate length + do + add E VIII # Increment by sizeof(dbFile) + ld A (A CDR) + atom A # More cells? + until nz # No + end + ld A (DbFiles) # DB file structure array + call allocAE_A # Set to new size + ld (DbFiles) A + ld Y A # Index in Y + add A E + push A # <S> Limit + ld (MaxBlkSize) 0 # Init block size maximum + do + ld C (S I) # Get DB name end pointer + ld A Y # Get index + sub A (DbFiles) + shr A 6 # Revert to file number + ld (Y I) A # Store in 'dbFile' + atom (L III) # Scale factor list? + if z # Yes + call bufAoAC_C # Append AO encoding to DB base name + end + set (C) 0 # Null-byte string terminator + ld A (L III) # Scale factor list + ld (L III) (A CDR) + ld A (A) # Next scale factor + cnt A # Given? + ldz A 2 # No: Default to 2 + if nz + shr A 4 # Else normalize + end + ld (Y II) B # Set block shift + ld (DbFile) Y # Set current file + cc open(&(S II) O_RDWR) # Try to open + nul4 # OK? + if ns # Yes + ld (Y) A # Set file descriptor + ld C (+ BLK BLK 1) # Read block shift + ld E 0 # from block zero + ld Z Buf # into 'Buf' + call blkPeekCEZ + ld B (Z (+ BLK BLK)) # Get block shift + ld (Y II) B # Override argument block shift + ld C BLKSIZE # Calculate block size + shl C B + ld (Y III) C # Set in dbFile + else + ld E (L IV) # Database name (if error) + call errno_A + cmp A ENOENT # Non-existing? + jne openErrEX # No + cc open(&(S II) (| O_CREAT O_EXCL O_RDWR) (oct "0666")) # Try to create + nul4 # OK? + js openErrEX # No + ld (Y) A # Set file descriptor + ld C BLKSIZE # Calculate block size + shl C (Y II) + ld (Y III) C # Set in dbFile + sub S C # <S> Buffer + ld B 0 # Clear buffer + mset (S) C # with block size + ld E 0 # Position of DB block zero + lea Z (S BLK) # Address of 'next' in buffer + cmp Y (DbFiles) # First file? + if ne # No + ld A BLKSIZE # Only block zero + else + ld A (* 2 BLKSIZE) # Block zero plus DB root + end + call setAdrAZ # into 'next' + ld Z S # Buffer address + set (Z (* 2 BLK)) (Y II) # Set block shift in block zero + call blkPokeCEZ # Write DB block zero + cmp Y (DbFiles) # First file? + if eq # Yes + ld (S) 0 # Clear 'next' link in buffer + ld (S I) 0 + ld Z S # Address of 'link' in buffer + ld A 1 # First block for DB root + call setAdrAZ # into link field + ld E (Y III) # Second block has block size position + call blkPokeCEZ # Write first ID-block (DB root block) + end + add S (Y III) # Drop buffer + end + ld A (Y) # Get fd + call closeOnExecAX + ld A (Y III) # Block size + cmp A (MaxBlkSize) # Calculate maximum + if gt + ld (MaxBlkSize) A + end + ld (Y IV) 0 # Clear 'flgs' + ld (Y V) 0 # mark vector size + ld (Y VI) 0 # and mark bit vector + ld (Y VII) -1 # Init 'fluse' + add Y VIII # Increment index by sizeof(dbFile) + ld A Y # Get index + sub A (DbFiles) # Advanced so far + ld (DBs) A # Set new scaled DB file count + cmp Y (S) # Done? + until eq # Yes + ld A (DbBlock) # Allocate block buffer + ld E (MaxBlkSize) # for maximal block size + call allocAE_A + ld (DbBlock) A + ld E (L II) # Replication journal? + cmp E Nil + if ne # Yes + call pathStringE_SZ # Write journal to stack buffer + cc fopen(S _a_) # Open for appending + ld S Z # Drop buffer + null A # OK? + jz openErrEX # No + ld (DbJnl) A + call jnlFileno_A # Get fd + call closeOnExecAX + end + ld E (L I) # Transaction log? + cmp E Nil + if ne # Yes + call pathStringE_SZ # Write journal to stack buffer + cc fopen(S _ap_) # Open for reading and appending + ld S Z # Drop buffer + null A # OK? + jz openErrEX # No + ld (DbLog) A + call logFileno_A # Get fd + call closeOnExecAX + call rewindLog # Test for existing transaction + cc fread(Buf 2 1 (DbLog)) # Read first file number + null A # Any? + if nz # Yes + cc feof((DbLog)) # EOF? + nul4 + if z # No + call ignLog # Discard incomplete transaction + else + do + ld2 (Buf) # Get file number (byte order doesn't matter) + cmp A -1 # End marker? + if eq # Yes + cc fprintf((stderr) RolbLog) # Rollback incomplete transaction + call rewindLog # Rewind transaction log + ld E (DbFiles) # Iterate DB files + ld C (DBs) # Count + do + set (E (+ IV 1)) 0 # Clear dirty flag + sub C VIII # Done? + until z # Yes + sub S (MaxBlkSize) # <S> Buffer + do + cc fread(Buf 2 1 (DbLog)) # Read file number + null A # Any? + jz jnlErrX # No + ld2 (Buf) # Get file number (byte order doesn't matter) + cmp A -1 # End marker? + while ne # No + call dbfBuf_AF # Read file number from 'Buf' to 'DbFile' + jc jnlErrX # No local file + cc fread(Buf BLK 1 (DbLog)) # Read object ID + cmp A 1 # OK? + jne jnlErrX # No + cc fread(S ((DbFile) III) 1 (DbLog)) # Read block data + cmp A 1 # OK? + jne jnlErrX # No + ld Z Buf # Get object ID from 'Buf' + call getAdrZ_A + shl A ((DbFile) II) # Shift + ld C ((DbFile) III) # Block size + cc pwrite(((DbFile)) S C A) # Write C bytes from stack buffer to pos A + cmp A C # OK? + jne dbWrErr + set ((DbFile) (+ IV 1)) 1 # Set dirty flag + loop + add S (MaxBlkSize) # Drop buffer + call fsyncDB # Sync DB files to disk + break T + end + call dbfBuf_AF # Read file number from 'Buf' into 'DbFile' + jc 40 # No local file + cc fread(Buf BLK 1 (DbLog)) # Read object ID + cmp A 1 # OK? + jne 40 # No + cc fseek((DbLog) ((DbFile) III) SEEK_CUR) # Skip by 'siz' + nul4 # OK? + jnz 40 # No + cc fread(Buf 2 1 (DbLog)) # Read next file number + cmp A 1 # OK? + if nz # No +40 call ignLog # Discard incomplete transaction + break T + end + loop + end + end + call truncLog # Truncate log file + end + end + drop + pop Z + pop Y + pop X + ld E TSym # Return T + ret +: RolbLog asciz "Last transaction not completed: Rollback\n" + +(code 'ignLog) + cc fprintf((stderr) IgnLog) + ret +: IgnLog asciz "Discarding incomplete transaction.\n" + +(code 'rewindLog) + cc fseek((DbLog) 0 SEEK_SET) # Rewind transaction log + ret + +(code 'fsyncDB) + ld E (DbFiles) # Iterate DB files + ld C (DBs) # Count + do + nul (E (+ IV 1)) # Dirty? + if nz # Yes + cc fsync((E)) # Sync DB file to disk + nul4 # OK? + js dbSyncErrX # No + end + sub C VIII # Done? + until z # Yes + ret + +(code 'truncLog) + call rewindLog # Rewind transaction log + call logFileno_A # Get fd + cc ftruncate(A 0) # Truncate log file + nul4 # OK? + jnz truncErrX + ret + +# Append A-O encoding to string +(code 'bufAoAC_C 0) + cmp A 15 # Single digit? + if gt # No + push A # Save + shr A 4 # Divide by 16 + call bufAoAC_C # Recurse + pop A + and B 15 # Get remainder + end + add B (char "@") # Make ASCII letter + ld (C) B # Store in buffer + add C 1 + ret + +# (journal 'any ..) -> T +(code 'doJournal 2) + push X + push Y + push Z + ld X E + ld Y (E CDR) # Y on args + sub S (MaxBlkSize) # <S /I> Buffer + do + atom Y # More args? + while z # Yes + call evSymY_E # Next file name + call pathStringE_SZ # Write to stack buffer + cc fopen(S _r_) # Open file + ld S Z # Drop buffer + null A # OK? + jz openErrEX # No + ld E A # Keep journal file pointer in E + do + cc getc_unlocked(E) # Next char + nul4 # EOF? + while ns # No + ld C A # Size in C + cc fread(Buf 2 1 E) # Read file number + cmp A 1 # OK? + jne jnlErrX # No + call dbfBuf_AF # Read file number from 'Buf' to 'DbFile' + jc dbfErrX # No local file + cmp C BLKSIZE # Whole block? + ldz C (A III) # Yes: Take file's block size + cc fread(Buf BLK 1 E) # Read object ID + cmp A 1 # OK? + jne jnlErrX # No + cc fread(S C 1 E) # Read data into buffer + cmp A 1 # OK? + jne jnlErrX # No + push E # Save journal file pointer + ld Z Buf # Get object ID from 'Buf' + call getAdrZ_A + ld E A # into E + shl E ((DbFile) II) # Shift + lea Z (S I) # Buffer + call blkPokeCEZ # Write object data + pop E # Restore journal file pointer + loop + cc fclose(E) # Close file pointer + ld Y (Y CDR) + loop + add S (MaxBlkSize) # Drop buffer + ld E TSym # Return T + pop Z + pop Y + pop X + ret + +# (id 'num ['num]) -> sym +# (id 'sym [NIL]) -> num +# (id 'sym T) -> (num . num) +(code 'doId 2) + push X + push Y + ld X E + ld Y (E CDR) # Y on args + ld E (Y) # Eval first + eval + num E # File number? + if nz # Yes + shr E 4 # Normalize + push E # <S> Scaled file number or object ID + ld Y (Y CDR) # Next arg + ld E (Y) + eval # Eval object ID + cmp E Nil # Given? + if eq # No + pop C # Get object ID + ld E 0 # File defaults to zero + else + call xCntEX_FE # Eval object ID + ld C E # into C + pop E # Get file number + sub E 1 # Zero-based + end + call extNmCE_X # Build external symbol name + call externX_E # New external symbol + pop Y + pop X + ret + end + sym E # Need symbol + jz symErrEX + sym (E TAIL) # External symbol? + jz extErrEX # No + xchg E Y # Keep symbol in Y + ld E ((E CDR)) # Eval second arg + eval # Eval flag + xchg E Y # Keep flag in Y, get symbol in E + call fileObjE_AC # Get file and ID + shl C 4 # Make short object ID + or C CNT + cmp Y Nil # Return only object ID? + ldz E C # Yes + if ne # No + add A 1 # File is zero-based + shl A 4 # Make short file number + or A CNT + call cons_E # Return (file . id) + ld (E) A + ld (E CDR) C + end + pop Y + pop X + ret + +# (seq 'cnt|sym1) -> sym | NIL +(code 'doSeq 2) + push X + push Y + push Z + ld X E + ld E ((E CDR)) # Eval arg + eval + num E # File number? + if nz # Yes + off E 15 # Normalize + 'dbFile' index + sub E (hex "10") # Zero-based + shl E 2 + push E # <S> Scaled file number + cmp E (DBs) # Local file? + jge dbfErrX # No + add E (DbFiles) # Get DB file + ld (DbFile) E # Set current + ld X 0 # Block index zero + else + sym E # Need symbol + jz symErrEX + sym (E TAIL) # External symbol? + jz extErrEX # No + call fileObjE_AC # Get file and ID + shl A 6 # 'dbFile' index + push A # <S> Scaled file number + cmp A (DBs) # Local file? + jge dbfErrX # No + add A (DbFiles) # Get DB file + ld (DbFile) A # Set current + shl C 6 # Block index from object ID + ld X C # Block index in X + end + call rdLockDb # Lock for reading + ld C BLK # Read 'next' + ld E BLK + ld Z Buf # into 'Buf' + call blkPeekCEZ + call getAdrZ_A # Get 'next' + ld Y A # into Y + do + add X BLKSIZE # Increment block index + cmp X Y # Less than 'next'? + if ge # No + pop A # Drop file number + ld E Nil # Return NIL + break T + end + ld E X # Block index + shl E ((DbFile) II) # Shift + ld C BLK # Read link field + call blkPeekCEZ # into 'Buf' + ld B (Z) # Get tag byte + and B BLKTAG # Block tag + cmp B 1 # One? + if eq # Yes + pop E # Get scaled file number + shr E 6 # Normalize + ld C X # Object ID + shr C 6 # Normalize + call extNmCE_X # Build external symbol name + call externX_E # New external symbol + break T + end + loop + ld A (hex "10000") # Length 1 + call rwUnlockDbA # Unlock + pop Z + pop Y + pop X + ret + +# (lieu 'any) -> sym | NIL +(code 'doLieu 2) + ld E ((E CDR)) # Get arg + eval # Eval it + num E # Number? + jnz retNil # Yes + sym E # Symbol? + jz retNil # No + ld A (E TAIL) # Get tail + sym A # External symbol? + jz retNil # No + off A SYM # Clear 'extern' tag + do + num A # Found name? + if nz # Yes + shl A 1 # Dirty? + if nc # No + shl A 1 # Loaded? + ldnc E Nil # No + ret + end + shl A 1 # Deleted? + ldc E Nil # Yes + ret + end + ld A (A CDR) # Skip property + loop + +# (lock ['sym]) -> cnt | NIL +(code 'doLock 2) + push X + ld X E + ld E ((E CDR)) # E on arg + eval # Eval it + cmp E Nil # NIL? + if eq # Yes + ld (DbFile) (DbFiles) # Use first dbFile + ld C 0 # Start + ld E 0 # Length + call tryLockCE_FA # Lock whole DB + else + num E # Need symbol + jnz symErrEX + sym E + jz symErrEX + sym (E TAIL) # External symbol? + jz extErrEX # No + call fileObjE_AC # Get file and ID + shl A 6 # 'dbFile' index + cmp A (DBs) # Local file? + jge dbfErrX # No + add A (DbFiles) # Get DB file + ld (DbFile) A + ld A (A III) # Get block size + mul C # Multiply with object ID for start position + ld C A # Start + ld E 1 # Length + call tryLockCE_FA # Lock external symbol + end + ld E Nil # Preload NIL + if nz # Locked by another process + ld E A # Get PID + shl E 4 # Make short number + or E CNT + end + pop X + ret + +(code 'dbSizeX_A 0) + cnt X # Short number? + if nz # Yes + shr X 3 # Normalize short, keep sign bit + jmp 20 + end + big X # Big number? + if nz # Yes + ld A 9 # Count 8 significant bytes plus 1 + do + ld C (X DIG) # Keep digit + ld X (X BIG) # More cells? + cnt X + while z # Yes + add A 8 # Increment count by 8 + loop + shr X 4 # Normalize short + shl C 1 # Get most significant bit of last digit + addc X X # Any significant bits in short number? + jmp 40 + end + ld A 1 # Preload 1 + cmp X Nil # NIL? + if ne # No + sym X # Symbol? + if nz # Yes + ld X (X TAIL) + call nameX_X # Get name + zero X # Any? + if ne # Yes + cnt X # Short name? + if nz # Yes + shl X 2 # Strip status bits + shr X 6 # Normalize +20 ld A 2 # Count significant bytes plus 1 + do + shr X 8 # More bytes? + while nz # Yes + add A 1 # Increment count + loop + ret + end + ld A 9 # Count significant bytes plus 1 + do + ld X (X BIG) # More cells? + cnt X + while z # Yes + add A 8 # Increment count by 8 + loop + shr X 4 # Any significant bits in short name/number? +40 if nz # Yes + do + add A 1 # Increment count + shr X 8 # More bytes? + until z # No + end + cmp A (+ 63 1) # More than one chunk? + if ge # Yes + ld X A # Keep size+1 in X + sub A 64 # Size-63 + ld C 0 # Divide by 255 + div 255 + setc # Plus 1 + addc A X # Plus size+1 + end + end + ret + end + push X # <S I> List head + push 2 # <S> Count + do + push (X CDR) # Save rest + ld X (X) # Recurse on CAR + call dbSizeX_A + pop X + add (S) A # Add result to count + cmp X Nil # CDR is NIL? + while ne # No + cmp X (S I) # Circular? + if eq # Yes + add (S) 1 # Increment count once more + break T + end + atom X # Atomic CDR? + if nz # Yes + call dbSizeX_A # Get size + add (S) A # Add result to count + break T + end + loop + pop A # Get result + pop C # Drop list head + end + ret + +(code 'dbFetchEX 0) + ld A (E TAIL) # Get tail + num A # Any properties? + jz Ret # Yes + rcl A 1 # Dirty? + jc ret # Yes + rcl A 1 # Loaded? + jc ret # Yes + setc # Set "loaded" + rcr A 1 + shr A 1 + push C +: dbAEX + push Y + push Z + link + push E # <L I> Symbol + link + ld Y A # Status/name in Y + call dbFileBlkY_AC # Get file and block index + cmp A (DBs) # Local file? + if lt # Yes + call setBlockAC_Z # Set up block env + call rdLockDb # Lock for reading + call rdBlockZ_Z # Read first block + ld B (Z (- BLK)) # Get tag byte + and B BLKTAG # Block tag + cmp B 1 # One? + jne idErrXL # Bad ID + ld (GetBinZ_FB) getBlockZ_FB # Set binary read function + ld (Extn) 0 # Set external symbol offset to zero + call binReadZ_FE # Read first item + ld A (L I) # Get symbol + ld (A) E # Set value + ld (A TAIL) Y # and status/name + call binReadZ_FE # Read first property key + cmp E Nil # Any? + if ne # Yes + call consE_A # Build first property cell + ld (A) E # Cons key + ld (A CDR) Y # With status/name + ld Y A # Keep cell in Y + or A SYM # Set 'extern' tag + ld ((L I) TAIL) A # Set symbol's tail + call binReadZ_FE # Read property value + cmp E TSym # T? + if ne # No + call consE_A # Cons property value + ld (A) E + ld (A CDR) (Y) # With key + ld (Y) A # Save in first property cell + end + do + call binReadZ_FE # Read next property key + cmp E Nil # Any? + while ne # Yes + call consE_A # Build next property cell + ld (A) E # Cons key + ld (A CDR) (Y CDR) # With name + ld (Y CDR) A # Insert + ld Y A # Point Y to new cell + call binReadZ_FE # Read property value + cmp E TSym # T? + if ne # No + call consE_A # Cons property value + ld (A) E + ld (A CDR) (Y) # With key + ld (Y) A # Save in property cell + end + loop + end + ld A (hex "10000") # Length 1 + call rwUnlockDbA # Unlock + else + shr A 6 # Revert to file number + ld Z (Ext) # Remote databases? + atom Z + jnz dbfErrX # No + ld C ((Z)) # First offset + shr C 4 # Normalize + cmp A C # First offset too big? + jlt dbfErrX # Yes + do + ld E (Z CDR) # More? + atom E + while z # Yes + ld C ((E)) # Next offset + shr C 4 # Normalize + cmp A C # Matching entry? + while ge # No + ld Z E # Try next remote DB + loop + push Y # Save name + push ((Z) CDR) # fun ((Obj) ..) + ld Y S # Pointer to fun in Y + push (L I) # Symbol + ld Z S # Z on (last) argument + call applyXYZ_E # Apply + pop Z # Get symbol + pop A # Drop 'fun' + pop Y # Get name + ld (Z) (E) # Set symbol's value + ld E (E CDR) # Properties? + atom E + if z # Yes + or E SYM # Set 'extern' tag + ld (Z TAIL) E # Set property list + do + atom (E CDR) # Find end + while z + ld E (E CDR) + loop + ld (E CDR) Y # Set name + else + or Y SYM # Set 'extern' tag + ld (Z TAIL) Y # Set name + end + end + ld E (L I) # Restore symbol + drop + pop Z + pop Y + pop C + ret + +(code 'dbTouchEX 0) + push C + lea C (E TAIL) # Get tail + ld A (C) + num A # Any properties? + if z # Yes + off A SYM # Clear 'extern' tag + do + lea C (A CDR) # Skip property + ld A (C) + num A # Find name + until nz + end + rcl A 1 # Already dirty? + if nc # No + rcl A 1 # Loaded? + if c # Yes + shr A 1 + setc # Set "dirty" + rcr A 1 + ld (C) A # in status/name + pop C + ret + end + shr A 1 + setc # Set "dirty" + rcr A 1 + jmp dbAEX + end + pop C + ret + +(code 'dbZapE 0) + ld A (E TAIL) # Get tail + num A # Any properties? + if z # Yes + off A SYM # Clear 'extern' tag + do + ld A (A CDR) # Skip property + num A # Find name + until nz + or A SYM # Set 'extern' tag + end + shl A 2 # Set "deleted" + setc + rcr A 1 + setc + rcr A 1 + ld (E TAIL) A # Set empty tail + ld (E) Nil # Clear value + ret + +# (commit ['any] [exe1] [exe2]) -> T +(code 'doCommit 2) + push X + push Y + push Z + ld X E + ld Y (E CDR) # Y on args + ld E (Y) # Eval 'any' + eval + link + push E # <L I> 'any' + link + null (DbLog) # Transaction log? + if z # No + add (EnvProtect) 1 # Protect the operation + end + call wrLockDb # Write lock DB + null (DbJnl) # Journal? + if nz # Yes + call lockJnl # Write lock journal + end + null (DbLog) # Transaction log? + if nz # Yes + ld E (DbFiles) # Iterate DB files + ld C (DBs) # Count + do + set (E (+ IV 1)) 0 # Clear dirty flag + ld (E VII) 0 # and 'fluse' + sub C VIII # Done? + until z # Yes + push X + push Y + ld X Extern # Iterate external symbol tree + ld Y 0 # Clear TOS + do + do + ld A (X CDR) # Get subtrees + atom (A CDR) # Right subtree? + while z # Yes + ld C X # Go right + ld X (A CDR) # Invert tree + ld (A CDR) Y # TOS + ld Y C + loop + do + ld A ((X) TAIL) # Get external symbol's tail + call nameA_A # Get name + rcl A 1 # Dirty or deleted? + if c # Yes + push Y + rcr A 1 + ld Y A # Name in Y + call dbFileBlkY_AC # Get file and block index + cmp A (DBs) # Local file? + if lt # Yes + call setBlockAC_Z # Set up block env + call rdBlockZ_Z # Read first block + do + call logBlock # Write to transaction log + null (BlkLink) # More blocks? + while nz # Yes + call rdBlockLinkZ_Z # Read next block + loop + ld C (DbFile) + set (C (+ IV 1)) 1 # Set dirty flag + rcl Y 2 # Deleted? + if nc # No + add (C VII) 1 # Increment 'fluse' + end + end + pop Y + end + ld A (X CDR) # Left subtree? + atom (A) + if z # Yes + ld C X # Go left + ld X (A) # Invert tree + ld (A) Y # TOS + or C SYM # First visit + ld Y C + break T + end + do + ld A Y # TOS + null A # Empty? + jeq 20 # Done + sym A # Second visit? + if z # Yes + ld C (A CDR) # Nodes + ld Y (C CDR) # TOS on up link + ld (C CDR) X + ld X A + break T + end + off A SYM # Set second visit + ld C (A CDR) # Nodes + ld Y (C) + ld (C) X + ld X A + loop + loop + loop +20 ld X (DbFiles) # Iterate DB files + ld Y (DBs) # Count + do + ld A (X VII) # Get 'fluse' + null A # Any? + if nz # Yes + push A # Save as count + ld A X + ld C 0 # Save Block 0 and free list + call setBlkAC_Z # Set up block env + call rdBlockZ_Z # Read first block + do + call logBlock # Write to transaction log + null (BlkLink) # More blocks? + while nz # Yes + sub (S) 1 # Decrement count + while nc + call rdBlockLinkZ_Z # Read next block + loop + pop A # Drop count + end + sub Y VIII # Done? + until z # Yes + cc putc_unlocked((hex "FF") (DbLog)) # Write end marker + cc putc_unlocked((hex "FF") (DbLog)) + cc fflush((DbLog)) # Flush Transaction log + call logFileno_A # Sync log file to disk + cc fsync(A) + nul4 # OK? + js trSyncErrX # No + pop Y + pop X + end + ld Y (Y CDR) # Eval pre-expression + ld E (Y) + eval + cmp (L I) Nil # 'any'? + if eq # No + push 0 # <L -I> No notification + else + ld A (Tell) + or A (Children) + push A # <L -I> Notify flag + if nz + push A # <L -II> Tell's buffer pointer + push (TellBuf) # <L -III> Save current 'tell' env + sub S PIPE_BUF # <L - III - PIPE_BUF> New 'tell' buffer + ld Z S # Buffer pointer + call tellBegZ_Z # Start 'tell' message + ld E (L I) # Get 'any' + call prTellEZ # Print to 'tell' + ld (L -II) Z # Save buffer pointer + end + end + push X + push Y + ld X Extern # Iterate external symbol tree + ld Y 0 # Clear TOS + do + do + ld A (X CDR) # Get subtrees + atom (A CDR) # Right subtree? + while z # Yes + ld C X # Go right + ld X (A CDR) # Invert tree + ld (A CDR) Y # TOS + ld Y C + loop + do + lea C ((X) TAIL) # Get external symbol's tail + ld A (C) + num A # Any properties? + if z # Yes + off A SYM # Clear 'extern' tag + do + lea C (A CDR) # Skip property + ld A (C) + num A # Find name + until nz + end + rcl A 1 # Dirty? + if c # Yes + push Y + rcl A 1 # Deleted? + if nc # No + setc # Set "loaded" + rcr A 1 + shr A 1 + ld (C) A # in status/name + ld Y A # Name in Y + call dbFileBlkY_AC # Get file and block index + cmp A (DBs) # Local file? + if lt # Yes + call setBlockAC_Z # Set up block env + call rdBlockZ_Z # Read first block + ld B 1 # First block in object (might be a new object) + or (Z (- BLK)) B # Set in tag byte + ld (PutBinBZ) putBlockBZ # Set binary print function + ld Y (X) # Get external symbol + ld E (Y) # Print value + ld (Extn) 0 # Set external symbol offset to zero + call binPrintEZ + ld Y (Y TAIL) # Get tail + off Y SYM # Clear 'extern' tag + do + num Y # Properties? + while z # Yes + atom (Y) # Flag? + if z # No + ld E ((Y) CDR) # Print key + call binPrintEZ + ld E ((Y)) # Print value + call binPrintEZ + else + ld E (Y) # Print key + call binPrintEZ + ld E TSym # Print 'T' + call binPrintEZ + end + ld Y (Y CDR) + loop + ld A NIX + call putBlockBZ # Output NIX + ld Z (DbBlock) # Block buffer in Z again + ld B (Z) # Lowest byte of link field + and B BLKTAG # Clear link + zxt + call setAdrAZ # Store in last block + call wrBlockZ # Write block + ld Y (BlkLink) # More blocks? + null Y + if nz # Yes + call cleanUpY # Clean up + end + null (L -I) # Notify? + if nz # Yes + ld Z (L -II) # Get buffer pointer + lea A ((TellBuf) (- PIPE_BUF 10)) # Space for EXTERN+<8>+END? + cmp Z A + if ge # No + call tellEndZ # Close 'tell' + lea Z (L (- (+ III PIPE_BUF))) # Reset buffer pointer + call tellBegZ_Z # Start new 'tell' message + end + ld E (X) # Get external symbol + call prTellEZ # Print to 'tell' + ld (L -II) Z # Save buffer pointer + end + end + else # Deleted + shr A 2 # Set "not loaded" + ld (C) A # in status/name + ld Y A # Name in Y + call dbFileBlkY_AC # Get file and block index + cmp A (DBs) # Local file? + if lt # Yes + add A (DbFiles) # Get DB file + ld (DbFile) A # Set current + ld Y C + call cleanUpY # Clean up + null (L -I) # Notify? + if nz # Yes + ld Z (L -II) # Get buffer pointer + lea A ((TellBuf) (- PIPE_BUF 10)) # Space for EXTERN+<8>+END? + cmp Z A + if ge # No + call tellEndZ # Close 'tell' + lea Z (L (- (+ III PIPE_BUF))) # Reset buffer pointer + call tellBegZ_Z # Start new 'tell' message + end + ld E (X) # Get external symbol + call prTellEZ # Print to 'tell' + ld (L -II) Z # Save buffer pointer + end + end + end + pop Y + end + ld A (X CDR) # Left subtree? + atom (A) + if z # Yes + ld C X # Go left + ld X (A) # Invert tree + ld (A) Y # TOS + or C SYM # First visit + ld Y C + break T + end + do + ld A Y # TOS + null A # Empty? + jeq 40 # Done + sym A # Second visit? + if z # Yes + ld C (A CDR) # Nodes + ld Y (C CDR) # TOS on up link + ld (C CDR) X + ld X A + break T + end + off A SYM # Set second visit + ld C (A CDR) # Nodes + ld Y (C) + ld (C) X + ld X A + loop + loop + loop +40 pop Y + pop X + null (L -I) # Notify? + if nz # Yes + ld Z (L -II) # Get buffer pointer + call tellEndZ # Close 'tell' + add S PIPE_BUF # Drop 'tell' buffer + pop (TellBuf) + end + ld Y (Y CDR) # Eval post-expression + ld E (Y) + eval + null (DbJnl) # Journal? + if nz # Yes + call unLockJnl # Unlock journal + end + ld Y (Zap) # Objects to delete? + atom Y + if z # Yes + push (OutFile) # Save output channel + sub S (+ III BUFSIZ) # <S> Local buffer with sizeof(outFile) + ld E (Y CDR) # Get zap file pathname + call pathStringE_SZ # Write to stack buffer + cc open(S (| O_APPEND O_CREAT O_WRONLY) (oct "0666")) # Open zap file + nul4 # OK? + js openErrEX # No + ld S Z # Drop buffer + ld (S) A # Store 'fd' in outFile + ld (S I) 0 # Clear 'ix' + ld (S II) 0 # and 'tty' + ld (OutFile) S # Set OutFile + ld (PutBinBZ) putStdoutB # Set binary print function + ld Y (Y) # Get zap list + do + atom Y # More symbols? + while z # Yes + ld E (Y) # Get next + ld (Extn) 0 # Set external symbol offset to zero + call binPrintEZ # Print it + ld Y (Y CDR) + loop + ld A S # Flush file + call flushA_F + ld A S # Close file + call closeAX + ld ((Zap)) Nil # Clear zap list + add S (+ III BUFSIZ) # Drop buffer + pop (OutFile) # Restore output channel + end + null (DbLog) # Transaction log? + if nz # Yes + call fsyncDB # Sync DB files to disk + call truncLog # Truncate log file + end + ld A 0 # Length + call rwUnlockDbA # Unlock all + null (DbLog) # Transaction log? + if z # No + sub (EnvProtect) 1 # Unprotect + end + ld E (DbFiles) # Iterate DB files + ld C (DBs) # Count + do + ld (E VII) -1 # Init 'fluse' + until z # Yes + drop + pop Z + pop Y + pop X + ld E TSym # Return T + ret + +# (rollback) -> T +(code 'doRollback 2) + push X + push Y + ld X Extern # Iterate external symbol tree + ld Y 0 # Clear TOS + do + do + ld A (X CDR) # Get subtrees + atom (A CDR) # Right subtree? + while z # Yes + ld C X # Go right + ld X (A CDR) # Invert tree + ld (A CDR) Y # TOS + ld Y C + loop + do + ld E (X) # Get external symbol + ld A (E TAIL) + num A # Any properties? + if z # Yes + off A SYM # Clear 'extern' tag + do + ld A (A CDR) # Skip property + num A # Find name + until nz + or A SYM # Set 'extern' tag + end + shl A 2 # Strip status bits + shr A 2 + ld (E TAIL) A # Set status/name + ld (E) Nil # Clear value + ld A (X CDR) # Left subtree? + atom (A) + if z # Yes + ld C X # Go left + ld X (A) # Invert tree + ld (A) Y # TOS + or C SYM # First visit + ld Y C + break T + end + do + ld A Y # TOS + null A # Empty? + jeq 90 # Done + sym A # Second visit? + if z # Yes + ld C (A CDR) # Nodes + ld Y (C CDR) # TOS on up link + ld (C CDR) X + ld X A + break T + end + off A SYM # Set second visit + ld C (A CDR) # Nodes + ld Y (C) + ld (C) X + ld X A + loop + loop + loop +90 pop Y + pop X + ld E TSym # Return T + ret + +# (mark 'sym|0 [NIL | T | 0]) -> flg +(code 'doMark 2) + push X + push Y + ld X E + ld Y (E CDR) # Y on args + ld E (Y) # Eval first + eval + zero E # Zero? + if eq # Yes + ld X (DbFiles) # Iterate DB files + ld Y (DBs) # Count + do + sub Y VIII # Done? + while ge # No + ld (X V) 0 # Mark vector size zero + cc free((X VI)) # Free mark bit vector + ld (X VI) 0 # Set to null + add X VIII # Increment by sizeof(dbFile) + loop + ld E Nil # Return NIL + pop Y + pop X + ret + end + num E # Need symbol + jnz symErrEX + sym E + jz symErrEX + sym (E TAIL) # External symbol? + jz extErrEX # No + push E # <S> 'sym' + ld E ((Y CDR)) # Eval second arg + eval + xchg E (S) # <S> NIL | T | 0 + call fileObjE_AC # Get file and ID + shl A 6 # 'dbFile' index + cmp A (DBs) # Local file? + jge dbfErrX # No + add A (DbFiles) # Get DB file + ld X A # into X + ld E C # Object ID in E + shr E 3 # Byte position + cmp E (X V) # Greater or equal to mark vector size? + if ge # Yes + push E # Save byte position + add E 1 # New size + ld Y E # Keep in Y + ld A (X VI) # Get mark bit vector + call allocAE_A # Increase to new size + ld (X VI) A + xchg E (X V) # Store size in 'dbFile', get old size + sub Y E # Length of new area + add E A # Start position of new area + ld B 0 # Clear new area + mset (E) Y + pop E # Restore byte position + end + add E (X VI) # Byte position in bit vector + and C 7 # Lowest three bits of object ID + ld B 1 # Bit position + shl B C # in B + test (E) B # Bit test + if z # Not set + cmp (S) TSym # Second arg 'T'? + if eq # Yes + or (E) B # Set mark + end + ld E Nil # Return NIL + else # Bit was set + zero (S) # Second arg '0'? + if eq # Yes + not B + and (E) B # Clear mark + end + ld E TSym # Return T + end + pop A # Drop second arg + pop Y + pop X + ret + +# (free 'cnt) -> (sym . lst) +(code 'doFree 2) + push X + push Y + push Z + ld X E + ld E ((E CDR)) # Eval 'cnt' + call evCntEX_FE + sub E 1 # File is zero-based + shl E 6 # 'dbFile' index + cmp E (DBs) # Local file? + jge dbfErrX # No + add E (DbFiles) # Get DB file + ld (DbFile) E # Set current + call rdLockDb # Lock for reading + ld C (* 2 BLK) # Read 'free' and 'next' + ld E 0 # from block zero + ld Z Buf # into 'Buf' + call blkPeekCEZ + call getAdrZ_A # Get 'free' + ld (BlkLink) A # Store as next block + add Z BLK + call getAdrZ_A # Get 'next' + ld C A # Object ID + shr C 6 # Normalize + ld E ((DbFile) I) # Get file number + call extNmCE_X # Build external symbol name + call externX_E # New external symbol + call cons_Y # Cons as CAR of result list + ld (Y) E + ld (Y CDR) Nil + link + push Y # (L I) Result list + link + do # Collect free list + ld C (BlkLink) # Next free block? + null C + while nz # Yes + shr C 6 # Normalize + ld E ((DbFile) I) # Get file number + call extNmCE_X # Build external symbol name + call externX_E # New external symbol + call cons_A # Next cell + ld (A) E + ld (A CDR) Nil + ld (Y CDR) A # Append ot result list + ld Y A + call rdBlockLinkZ_Z # Read next block + loop + ld A (hex "10000") # Length 1 + call rwUnlockDbA # Unlock + ld E (L I) # Get result list + drop + pop Z + pop Y + pop X + ret + +# (dbck ['cnt] 'flg) -> any +(code 'doDbck 2) + push X + push Y + push Z + ld X E + ld Y (E CDR) # Y on args + ld E (Y) # Eval first + eval + ld (DbFile) (DbFiles) # Default to first dbFile + cnt E # 'cnt' arg? + if nz # Yes + off E 15 # Normalize + 'dbFile' index + sub E (hex "10") # Zero-based + shl E 2 + cmp E (DBs) # Local file? + jge dbfErrX # No + add E (DbFiles) # Get DB file + ld (DbFile) E # Set current + ld Y (Y CDR) # Next arg + ld E (Y) + eval # Eval next arg + end + push E # <S III> 'flg' + push ZERO # <S II> 'syms' + push ZERO # <S I> 'blks' + add (EnvProtect) 1 # Protect the operation + call wrLockDb # Write lock DB + null (DbJnl) # Journal? + if nz # Yes + call lockJnl # Write lock journal + end + ld C (* 2 BLK) # Read 'free' and 'next' + ld E 0 # from block zero + ld Z Buf # into 'Buf' + call blkPeekCEZ + call getAdrZ_A # Get 'free' + ld (BlkLink) A # Store as next block + add Z BLK + call getAdrZ_A # Get 'next' + push A # <S> 'next' + ld Y BLKSIZE # 'cnt' in Y + do # Check free list + ld A (BlkLink) # Next block? + null A + while nz # Yes + call rdBlockIndexAZ_Z # Read next block + add Y BLKSIZE # Increment 'cnt' + cmp Y (S) # Greater than 'next'? + if gt # Yes + ld E CircFree # Circular free list + call mkStrE_E # Return message + jmp 90 + end + ld Z (DbBlock) # Block buffer in Z again + or (Z) BLKTAG # Mark free list + call wrBlockZ # Write block + loop + ld X BLKSIZE # 'p' in X + do # Check all chains + cmp X (S) # Reached 'next'? + while ne # No + ld A X # Get 'p' + call rdBlockIndexAZ_Z # Read next block + sub Z BLK # Block buffer in Z again + ld B (Z) # Get tag byte + and B BLKTAG # Block tag zero? + if z # Yes + add Y BLKSIZE # Increment 'cnt' + movn (Z) (Buf) BLK # Insert into free list + call wrBlockZ # Write block + ld A X # Write 'free' + ld Z Buf # into 'Buf' + call setAdrAZ + ld C BLK + ld E 0 # 'free' address + call blkPokeCEZ # Write 'Buf' + else + cmp B 1 # ID-block of symbol? + if eq # Yes + push X + add (S II) (hex "10") # Increment 'blks' + add (S III) (hex "10") # Increment 'syms' + add Y BLKSIZE # Increment 'cnt' + ld X 2 # Init 'i' + do + ld A (BlkLink) # Next block? + null A + while nz # Yes + add Y BLKSIZE # Increment 'cnt' + add (S II) (hex "10") # Increment 'blks' + call rdBlockIndexAZ_Z # Read next block + ld B (Z (- BLK)) # Get tag byte + and B BLKTAG # Block tag + cmp B X # Same as 'i'? + if ne # No + ld E BadChain # Bad object chain + call mkStrE_E # Return message + jmp 90 + end + cmp X BLKTAG # Less than maximum? + if lt # Yes + add X 1 # Increment + end + loop + pop X + end + end + add X BLKSIZE # Increment 'p' + loop + ld Z Buf # Get 'free' + call getAdrZ_A + ld (BlkLink) A # Store as next block + do # Unmark free list + null A # Any? + while nz # Yes + call rdBlockIndexAZ_Z # Read next block + sub Z BLK # Block buffer in Z again + ld B (Z) # Get tag byte + and B BLKTAG # Block tag non-zero? + if nz # Nes + off (Z) BLKTAG # Clear tag + call wrBlockZ # Write block + end + ld A (BlkLink) # Get next block + loop + cmp Y (S) # 'cnt' == 'next'? + if ne # No + ld E BadCount # Circular free list + call mkStrE_E # Return message + else + cmp (S III) Nil # 'flg' is NIL? + ldz E Nil # Yes: Return NIL + if ne # No + call cons_E # Return (blks . syms) + ld (E) (S I) # 'blks' + ld (E CDR) (S II) # 'syms' + end + end +90 pop A # Drop 'next' + pop A # and 'blks' + pop A # and 'syms' + pop A # and 'flg' + null (DbJnl) # Journal? + if nz # Yes + call unLockJnl # Unlock journal + end + ld A (hex "10000") # Length 1 + call rwUnlockDbA # Unlock + sub (EnvProtect) 1 # Unprotect + pop Z + pop Y + pop X + ret +: CircFree asciz "Circular free list" +: BadChain asciz "Bad chain" +: BadCount asciz "Bad count" + +# vi:et:ts=3:sw=3 diff --git a/src64/defs.l b/src64/defs.l @@ -0,0 +1,65 @@ +# 03mar10abu +# (c) Software Lab. Alexander Burger + +# Constants +(equ HEAP (* 1024 1024)) # Heap size in bytes +(equ CELLS (/ HEAP 16)) # Number of cells in a single heap (65536) +(equ ZERO (short 0)) # Short number '0' +(equ ONE (short 1)) # Short number '1' +(equ TOP (hex "10000")) # Character top +(equ DB1 (hex "1A")) # Name of '{1}' + +# Pointer offsets +(equ I 8) +(equ II 16) +(equ III 24) +(equ IV 32) +(equ V 40) +(equ VI 48) +(equ VII 56) +(equ VIII 64) +(equ IX 72) + +(equ -I . -8) +(equ -II . -16) +(equ -III . -24) +(equ -IV . -32) +(equ -V . -40) +(equ -VI . -48) +(equ -VII . -56) +(equ -VIII . -64) + +# Cell offsets +(equ CNT 2) # Count tag +(equ BIG 4) # Rest of a bignum + bignum tag +(equ DIG -4) # First digit of a big number +(equ CDR 8) # CDR part of a list cell +(equ SIGN 8) # Sign bit of a number +(equ SYM 8) # Symbol tag +(equ TAIL -8) # Tail of a symbol + +# I/O Tokens +(equ NIX 0) # NIL +(equ BEG 1) # Begin list +(equ DOT 2) # Dotted pair +(equ END 3) # End list +(equ NUMBER 0) # Number +(equ INTERN 1) # Internal symbol +(equ TRANSIENT 2) # Transient symbol +(equ EXTERN 3) # External symbol + +# DB-I/O +(equ BLK 6) # Block address size +(equ BLKSIZE 64) # DB block unit size +(equ BLKTAG 63) # Block tag mask + +# Networking +(equ UDPMAX 4096) # UDP buffer size + +# Case mappings from the GNU Kaffe Project +(equ CHAR_UPPERCASE 1) +(equ CHAR_LOWERCASE 2) +(equ CHAR_LETTER 62) +(equ CHAR_DIGIT 512) + +# vi:et:ts=3:sw=3 diff --git a/src64/err.l b/src64/err.l @@ -0,0 +1,726 @@ +# 08mar10abu +# (c) Software Lab. Alexander Burger + +# Debug print routine +(code 'dbgS) + xchg E (S) # Get return address + xchg E (S I) # Get argument, save return + push C # Save all registers + push A + push F # And flags + push (OutFile) # Save output channel + ld (OutFile) ((OutFiles) II) # Set to OutFiles[2] (stderr) + push (EnvPutB) # Save 'put' + ld (EnvPutB) putStdoutB # Set new + call printE # Print argument + call newline # and a newline + pop (EnvPutB) # Restore 'put' + pop (OutFile) # and output channel + pop F + pop A + pop C + pop E + ret + +# System error number +(code 'errnoEXY) + call errno_A # Get 'errno' + cc strerror(A) # Convert to string + ld Z A + +# E reason +# X context +# Y message format +# Z message parameter +(code 'errEXYZ) + sub S (+ 240 IV) # <S> Message buffer, <S 240> outFrame + cc sprintf(S Y Z) # Build message + null X # Error context? + ld A Nil + ldnz A X # Yes + ld (Up) A # Save it + nul (S) # Message empty? + if nz # No + push E # Save reason + lea E (S I) # Make transient symbol + call mkStrE_E + ld (Msg) E # Store in '*Msg' + ld C (Catch) # Search catch frames + do + null C # Any? + while nz # Yes + ld Y (C I) # Tag non-zero? + null Y + if nz # Yes + do + atom Y # List? + while z # Yes + ld A (Y) # Next element of tag list + ld E (Msg) # Substring of '*Msg'? + push C + call subStrAE_F + pop C + if eq # Yes + ld Y (Y) # Get tag list element + cmp Y Nil # NIL? + ldz Y (Msg) # Yes: Use *Msg instead + push Y # Save tag list element + call unwindC_Z # Unwind environments + pop E # Return tag list element from 'catch' + ld S Z # Restore stack + jmp caught + end + ld Y (Y CDR) # Tag list + loop + end + ld C (C) # Next frame + loop + pop E # Retrieve reason + end + ld (Chr) 0 # Init globals + ld (ExtN) 0 + ld (EnvBrk) 0 + ld (Alarm) Nil + ld (LineX) ZERO + ld (LineC) -1 + lea Y (S 240) # Pointer to outFrame + ld (Y I) 2 # fd = stderr + ld (Y II) 0 # pid = 0 + call pushOutFilesY + ld Y (InFile) # Current InFile + null Y # Any? + if nz # Yes + ld C (Y VI) # Filename? + null C + if nz # Yes + ld B (char "[") # Output location + call (EnvPutB) + call outStringC # Print filename + ld B (char ":") # Separator ':' + call (EnvPutB) + ld A (Y V) # Get 'src' + call outWordA # Print line number + ld B (char "]") + call (EnvPutB) + call space + end + end + null X # Error context? + if nz # Yes + ld C ErrTok # Print error token + call outStringC + push E # Save reason + ld E X # Get context + call printE # Print context + call newline + pop E # Retrieve reason + end + null E # Reason? + if nz # Yes + call printE # Print reason + ld C Dashes # Print " -- " + call outStringC + end + nul (S) # Message empty? + if nz # No + call outStringS # Print message + call newline + cmp (Err) Nil # Error handler? + if ne # Yes + nul (Jam) # Jammed? + if z # No + set (Jam) 1 # Set flag + ld X (Err) # Run error handler + prog X + set (Jam) 0 # Reset flag + end + end + ld E 1 # Exit error code + cc isatty(0) # STDIN + nul4 # on a tty? + jz byeE # No + cc isatty(1) # STDOUT + nul4 # on a tty? + jz byeE # No + ld B (char "?") # Prompt + ld E Nil # Load argument + ld X 0 # Runtime expression + call loadBEX_E + end + ld C 0 # Top frame + call unwindC_Z # Unwind + ld (EnvProtect) 0 # Reset environments + ld (EnvTask) Nil + ld (EnvArgs) 0 + ld (EnvNext) 0 + ld (EnvMeth) 0 + ld (EnvMake) 0 + ld (EnvYoke) 0 + ld (EnvTrace) 0 + ld L 0 # Init link register + ld S (Stack0) # and stack pointer + jmp restart # Restart interpreter +: ErrTok asciz "!? " +: Dashes asciz " -- " + +(code 'unwindC_Z 0) + push C # <S> Target frame + ld X (Catch) # Catch link + ld Y (EnvBind) # Bindings + do + null X # Catch frames? + while nz # Yes + do + null Y # Bindings? + while nz # Yes + ld C (Y -I) # First env swap + null C # Zero? + if nz # No + ld A C # 'j' + ld E 0 # 'n' + ld Z Y # Bindings in Z + do + add E 1 # Increment 'n' + add A 1 # Done? + while nz # No + ld Z ((Z) I) # Follow link + null Z # Any? + while nz # Yes + cmp (Z -I) A # Env swap nesting? + if lt # Yes + sub A 1 # Adjust + end + loop + do + ld A E # Get 'n' + ld Z Y # Bindings + do + sub A 1 # 'n-1' times + while nz + ld Z ((Z) I) # Follow link + loop + ld A (Z) # End of bindings in A + sub (Z -I) C # Increment 'eswp' by absolute first eswp + if gt # Overflowed + ld (Z -I) 0 # Reset + end + if ge # Last pass + sub A II + do + xchg ((A)) (A I) # Exchange next symbol value with saved value + sub A II + cmp A Z # More? + until lt # No + end + sub E 1 # Decrement 'n' + until z # Done + end + cmp Y (X III) # Reached last bind frame? + while ne # No + ld C (Y) # C on link + null (Y -I) # Env swap now zero? + if z # Yes + add Y I # Y on bindings + do + ld Z (Y) # Next symbol + add Y I + ld (Z) (Y) # Restore value + add Y I + cmp Y C # More? + until eq # No + end + ld Y (C I) # Bind link + loop + do + cmp (EnvInFrames) (X IV) # Open input frames? + while nz # Yes + call popInFiles # Clean up + loop + do + cmp (EnvOutFrames) (X V) # Open output frames? + while nz # Yes + call popOutFiles # Clean up + loop + do + cmp (EnvCtlFrames) (X VI) # Open control frames? + while nz # Yes + call popCtlFiles # Clean up + loop + movn (Env) (X III) "(EnvEnd-Env)" # Restore environment + ld E (X II) # 'fin' + eval # Evaluate 'finally' expression + cmp X (S) # Reached target catch frame? + ld X (X) # Catch link + ld (Catch) X + if eq # Yes + pop Z # Get target frame + ret + end + loop + pop A # Drop target frame + do # Top level bindings + null Y # Any? + while nz # Yes + ld C (Y) # C on link + null (Y -I) # Env swap zero? + if z # Yes + add Y I # Y on bindings + do + ld Z (Y) # Next symbol + add Y I + ld (Z) (Y) # Restore value + add Y I + cmp Y C # More? + until eq # No + end + ld Y (C I) # Bind link + loop + ld (EnvBind) 0 + do + null (EnvInFrames) # Open input frames? + while nz # Yes + call popInFiles # Clean up + loop + do + null (EnvOutFrames) # Open output frames? + while nz # Yes + call popOutFiles # Clean up + loop + do + null (EnvCtlFrames) # Open control frames? + while nz # Yes + call popCtlFiles # Clean up + loop + ret + +### Checks ### +(code 'needSymAX 0) + num A # Need symbol + jnz symErrAX + sym A + jz symErrAX + cmp A Nil # A < NIL ? + jc ret # Yes + cmp A TSym # A > T ? + jncz Ret # Yes + ld E A + jmp protErrEX + +(code 'needSymEX 0) + num E # Need symbol + jnz symErrEX + sym E + jz symErrEX + cmp E Nil # E < NIL ? + jc ret # Yes + cmp E TSym # E > T ? + jncz Ret # Yes + jmp protErrEX + +(code 'needVarAX 0) + num A # Need variable + jnz varErrAX + cmp A Nil # A < NIL ? + jc ret # Yes + cmp A TSym # A > T ? + jncz Ret # Yes + ld E A + jmp protErrEX + +(code 'needVarEX 0) + num E # Need variable + jnz varErrEX + cmp E Nil # E < NIL ? + jc ret # Yes + cmp E TSym # E > T ? + jncz Ret # Yes + jmp protErrEX + +(code 'checkVarAX 0) + cmp A Nil # A < NIL ? + jc ret # Yes + cmp A TSym # A > T ? + jncz Ret # Yes + ld E A + jmp protErrEX + +(code 'checkVarYX 0) + cmp Y Nil # Y < NIL ? + jc ret # Yes + cmp Y TSym # Y > T ? + jncz Ret # Yes + ld E Y + jmp protErrEX + +(code 'checkVarEX 0) + cmp E Nil # E < NIL ? + jc ret # Yes + cmp E TSym # E > T ? + jncz Ret # Yes +(code 'protErrEX) + ld Y ProtErr + jmp errEXYZ +: ProtErr asciz "Protected symbol" + +### Error messages ### +(code 'argErrAX) + ld E A +(code 'argErrEX) + ld Y ArgErr + jmp errEXYZ +: ArgErr asciz "Bad argument" + +(code 'numErrAX) + ld E A +(code 'numErrEX) + ld Y NumErr + jmp errEXYZ +: NumErr asciz "Number expected" + +(code 'cntErrAX) + ld C A +(code 'cntErrCX) + ld E C +(code 'cntErrEX) + ld Y CntErr + jmp errEXYZ +: CntErr asciz "Small number expected" + +(code 'symErrAX) + ld Y A +(code 'symErrYX) + ld E Y +(code 'symErrEX) + ld Y SymErr + jmp errEXYZ +: SymErr asciz "Symbol expected" + +(code 'extErrEX) + ld Y ExtErr + jmp errEXYZ +: ExtErr asciz "External symbol expected" + +(code 'cellErrAX) + ld E A +(code 'cellErrEX) + ld Y CellErr + jmp errEXYZ +: CellErr asciz "Cell expected" + +(code 'atomErrAX) + ld E A +(code 'atomErrEX) + ld Y AtomErr + jmp errEXYZ +: AtomErr asciz "Atom expected" + +(code 'lstErrAX) + ld E A +(code 'lstErrEX) + ld Y LstErr + jmp errEXYZ +: LstErr asciz "List expected" + +(code 'varErrAX) + ld E A +(code 'varErrEX) + ld Y VarErr + jmp errEXYZ +: VarErr asciz "Variable expected" + +(code 'divErrX) + ld E 0 + ld Y DivErr + jmp errEXYZ +: DivErr asciz "Div/0" + +(code 'renErrEX) + ld Y RenErr + jmp errEXYZ +: RenErr asciz "Can't rename" + +(code 'makeErrEX) + ld Y MakeErr + jmp errEXYZ +: MakeErr asciz "Not making" + +(code 'msgErrYX) + ld A Y +(code 'msgErrAX) + ld E A +(code 'msgErrEX) + ld Y MsgErr + jmp errEXYZ +: MsgErr asciz "Bad message" + +(code 'brkErrX) + ld E 0 + ld Y BrkErr + jmp errEXYZ +: BrkErr asciz "No Break" + +# I/O errors +(code 'openErrEX) + ld Y OpenErr + jmp errnoEXY +: OpenErr asciz "Open error: %s" + +(code 'closeErrX) + ld E 0 +(code 'closeErrEX) + ld Y CloseErr + jmp errnoEXY +: CloseErr asciz "Close error: %s" + +(code 'pipeErrX) + ld E 0 + ld Y PipeErr + jmp errnoEXY +: PipeErr asciz "Pipe error: %s" + +(code 'forkErrX) + ld E 0 + ld Y ForkErr + jmp errEXYZ +: ForkErr asciz "Can't fork" + +(code 'waitPidErrX) + ld E 0 + ld Y WaitPidErr + jmp errnoEXY +: WaitPidErr asciz "wait pid" + +(code 'badFdErrEX) + ld Y BadFdErr + jmp errEXYZ +: BadFdErr asciz "Bad FD" + +(code 'noFdErrX) + ld E 0 + ld Y NoFdErr + jmp errEXYZ +: NoFdErr asciz "No current fd" + +(code 'eofErr) + ld E 0 + ld X 0 + ld Y EofErr + jmp errEXYZ +: EofErr asciz "EOF Overrun" + +(code 'suparErrE) + ld X 0 + ld Y SuparErr + jmp errEXYZ +: SuparErr asciz "Super parentheses mismatch" + +(code 'badInputErrB) + zxt + ld Z A + ld E 0 + ld X 0 + ld Y BadInput + jmp errEXYZ +: BadInput asciz "Bad input '%c'" + +(code 'badDotErrE) + ld X 0 + ld Y BadDot + jmp errEXYZ +: BadDot asciz "Bad dotted pair" + +(code 'selectErrX) + ld E 0 + ld Y SelectErr + jmp errnoEXY +: SelectErr asciz "Select error: %s" + +(code 'wrBytesErr) + ld E 0 + ld X 0 + ld Y WrBytesErr + jmp errnoEXY +: WrBytesErr asciz "bytes write: %s" + +(code 'wrChildErr) + ld E 0 + ld X 0 + ld Y WrChildErr + jmp errnoEXY +: WrChildErr asciz "child write: %s" + +(code 'wrSyncErrX) + ld E 0 + ld Y WrSyncErr + jmp errnoEXY +: WrSyncErr asciz "sync write: %s" + +(code 'wrJnlErr) + ld E 0 + ld X 0 + ld Y WrJnlErr + jmp errnoEXY +: WrJnlErr asciz "Journal write: %s" + +(code 'wrLogErr) + ld E 0 + ld X 0 + ld Y WrLogErr + jmp errnoEXY +: WrLogErr asciz "Log write: %s" + +(code 'truncErrX) + ld E 0 + ld Y TruncErr + jmp errnoEXY +: TruncErr asciz "Log truncate error: %s" + +(code 'dbSyncErrX) + ld E 0 + ld Y DbSyncErr + jmp errnoEXY +: DbSyncErr asciz "DB fsync error: %s" + +(code 'trSyncErrX) + ld E 0 + ld Y TrSyncErr + jmp errnoEXY +: TrSyncErr asciz "Transaction fsync error: %s" + +(code 'lockErr) + ld E 0 + ld X 0 + ld Y LockErr + jmp errnoEXY +: LockErr asciz "File lock: %s" + +(code 'dbfErrX) + ld E 0 + ld Y DbfErr + jmp errEXYZ +: DbfErr asciz "Bad DB file" + +(code 'jnlErrX) + ld E 0 + ld Y JnlErr + jmp errEXYZ +: JnlErr asciz "Bad Journal" + +(code 'idErrXL) + ld E (L I) # Get symbol + ld Y IdErr + jmp errEXYZ +: IdErr asciz "Bad ID" + +(code 'dbRdErr) + ld E 0 + ld X 0 + ld Y DbRdErr + jmp errnoEXY +: DbRdErr asciz "DB read: %s" + +(code 'dbWrErr) + ld E 0 + ld X 0 + ld Y DbWrErr + jmp errnoEXY +: DbWrErr asciz "DB write: %s" + +(code 'dbSizErr) + ld E 0 + ld X 0 + ld Y DbSizErr + jmp errEXYZ +: DbSizErr asciz "DB Oversize" + +(code 'tellErr) + ld E 0 + ld X 0 + ld Y TellErr + jmp errEXYZ +: TellErr asciz "Tell PIPE_BUF" + +(code 'ipSocketErrX) + ld E 0 + ld Y IpSocketErr + jmp errnoEXY +: IpSocketErr asciz "IP socket error: %s" + +(code 'ipGetsocknameErrX) + ld E 0 + ld Y IpGetsocknameErr + jmp errnoEXY +: IpGetsocknameErr asciz "IP getsockname error: %s" + +(code 'ipSetsockoptErrX) + ld E 0 + ld Y IpSetsockoptErr + jmp errnoEXY +: IpSetsockoptErr asciz "IP setsockopt error: %s" + +(code 'ipBindErrX) + ld E 0 + ld Y IpBindErr + jmp errnoEXY +: IpBindErr asciz "IP bind error: %s" + +(code 'ipListenErrX) + ld E 0 + ld Y IpListenErr + jmp errnoEXY +: IpListenErr asciz "IP listen error: %s" + +(code 'udpOvflErr) + ld E 0 + ld X 0 + ld Y UdpOvflErr + jmp errEXYZ +: UdpOvflErr asciz "UDP overflow" + +### Undefined symbol ### +(code 'undefinedCE) + ld X E +(code 'undefinedCX) + ld E C +(code 'undefinedEX) + ld Y UndefErr + jmp errEXYZ +: UndefErr asciz "Undefined" + +(code 'dlErrX) + ld E 0 + cc dlerror() # Get dynamic loader error message + ld Y DlErr + ld Z A + jmp errEXYZ +: DlErr asciz "[DLL] %s" + +### Global return labels ### +(code 'ret 0) + ret +(code 'retc 0) + setc + ret +(code 'retnc 0) + clrc + ret +(code 'retz 0) + setz + ret +(code 'retnz 0) + clrz + ret +(code 'retNull 0) + ld E 0 + ret +(code 'retNil 0) + ld E Nil + ret +(code 'retT 0) + ld E TSym + ret +(code 'retE_E 0) + ld E (E) # Get value or CAR + ret + +# vi:et:ts=3:sw=3 diff --git a/src64/ext.l b/src64/ext.l @@ -0,0 +1,248 @@ +# 05mar10abu +# (c) Software Lab. Alexander Burger + +### Soundex Algorithm ### +(data 'SnxTab) +bytes ( + (char "0") (char "1") (char "2") (char "3") (char "4") (char "5") (char "6") (char "7") # 48 + (char "8") (char "9") 0 0 0 0 0 0 + 0 0 (char "F") (char "S") (char "T") 0 (char "F") (char "S") # 64 + 0 0 (char "S") (char "S") (char "L") (char "N") (char "N") 0 + (char "F") (char "S") (char "R") (char "S") (char "T") 0 (char "F") (char "F") + (char "S") 0 (char "S") 0 0 0 0 0 + 0 0 (char "F") (char "S") (char "T") 0 (char "F") (char "S") # 96 + 0 0 (char "S") (char "S") (char "L") (char "N") (char "N") 0 + (char "F") (char "S") (char "R") (char "S") (char "T") 0 (char "F") (char "F") + (char "S") 0 (char "S") 0 0 0 0 0 + 0 0 0 0 0 0 0 0 # 128 + 0 0 0 0 0 0 0 0 + 0 0 0 0 0 0 0 0 + 0 0 0 0 0 0 0 0 + 0 0 0 0 0 0 0 0 # 160 + 0 0 0 0 0 0 0 0 + 0 0 0 0 0 0 0 0 + 0 0 0 0 0 0 0 0 + 0 0 0 0 0 0 0 (char "S") # 192 + 0 0 0 0 0 0 0 0 + (char "T") (char "N") 0 0 0 0 0 (char "S") + 0 0 0 0 0 0 0 (char "S") + 0 0 0 0 0 0 0 (char "S") # 224 + 0 0 0 0 0 0 0 0 + 0 (char "N") ) + +(equ SNXBASE 48) +(equ SNXSIZE (+ (* 24 8) 2)) + +# (ext:Snx 'any ['cnt]) -> sym +(code 'Snx 2) + push X + push Y + ld X E + ld Y (E CDR) # Y on args + call evSymY_E # Eval 'any' + cmp E Nil + if ne # No + ld E (E TAIL) + call nameE_E # Get name + link + push E # <L II> Save Name + link + ld Y (Y CDR) # Next arg + atom Y # Any? + ldnz E 24 # Default to 24 + if z # Yes + call evCntXY_FE # Eval 'cnt' + end + tuck ZERO # <L I> Result + ld X S + link + push 4 # <S II> Build name + push X # <S I> Pack status + ld X (L II) # Get name + ld C 0 # Index + do + call symCharCX_FACX # First char? + jz 90 # No + cmp A SNXBASE # Too small? + until ge # No + cmp A (char "a") # Lower case? + if ge + cmp A (char "z") + jle 40 # Yes + end + cmp A 128 + jeq 40 # Yes + cmp A 224 + if ge + cmp A 255 + if le # Yes +40 off B 32 # Convert to lower case + end + end + push A # <S> Last character + xchg C (S II) # Swap status + xchg X (S I) + call charSymACX_CX # Pack first char + xchg X (S I) # Swap status + xchg C (S II) + do + call symCharCX_FACX # Next char? + while nz # Yes + cmp A 32 # Non-white? + if gt # Yes + sub A SNXBASE # Too small? + jlt 60 # Yes + cmp A SNXSIZE # Too big? + jge 60 # Yes + ld B (A SnxTab) # Character entry? + zxt + or A A + if z # No +60 ld (S) 0 # Clear last character + else + cmp A (S) # Same as last? + if ne # No + sub E 1 # Decrement count + break z + ld (S) A # Save last character + xchg C (S II) # Swap status + xchg X (S I) + call charSymACX_CX # Pack char + xchg X (S I) # Swap status + xchg C (S II) + end + end + end + loop +90 ld X (L I) # Get result + call consSymX_E # Make transient symbol + drop + end + pop Y + pop X + ret + + +(equ BIAS 132) +(equ CLIP (- 32767 BIAS)) + +# (ext:Ulaw 'cnt) -> cnt # SEEEMMMM +(code 'Ulaw 2) + push X + ld X E + ld E ((E CDR)) # Get arg + eval # Eval 'cnt' + cnt E # # Short number? + jz cntErrEX # No + ld X 0 # No sign + shr E 4 # Normalize + if c # Negative? + ld X (hex "80") # Set sign + end + cmp E (+ CLIP 1) # Clip the value + ldnc E CLIP + add E BIAS # Increment by BIAS + ld A E # Double value + add A A # in 'tmp' + ld C 7 # Exponent + do + test A (hex "8000") + while z + add A A # Double 'tmp' + sub C 1 # Decrement exponent + until z + ld A C # Get exponent + add A 3 # plus 3 + shr E A # Shift value right + and E 15 # Lowest 4 bits + shl C 4 # Shift exponent left + or E C # Combine with value + or E X # and sign + not E # Negate + and E (hex "FF") # Get byte value + shl E 4 # Make short number + or E CNT + pop X + ret + + +### Base64 Encoding ### +(data 'Chr64) +ascii "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/" + +# (ext:Base64 'num1|NIL ['num2|NIL ['num3|NIL]]) -> flg +(code 'Base64 2) + push X + push Y + push Z + ld X E + ld Y (E CDR) # Y on args + ld E (Y) # Eval first 'num|NIL' + eval + cmp E Nil # NIL? + if ne # No + shr E 4 # Normalize first arg + ld Z E # Keep in Z + shr E 2 # Upper 6 bits + call chr64E # Output encoded + ld Y (Y CDR) # Next arg + ld E (Y) + eval # Eval second arg + cmp E Nil # NIL? + if eq # Yes + ld E Z # Get first arg + and E 3 # Mask + shl E 4 # Shift to upper position + call chr64E # Output encoded + ld B (char "=") # and two equal signs + call envPutB + ld B (char "=") + call envPutB + ld E Nil # Return NIL + else + shr E 4 # Normalize second arg + and Z 3 # Mask first arg + shl Z 4 # Shift to upper position + ld A E # Get second arg + shr A 4 # Normalize + or A Z # Combine + ld Z E # Keep second arg in Z + call chr64A # Output encoded + ld Y (Y CDR) # Next arg + ld E (Y) + eval # Eval third arg + cmp E Nil # NIL? + if eq # Yes + ld A Z # Get second + and A 15 # Lowest four bits + shl A 2 # Shift + call chr64A # Output encoded + ld B (char "=") # and an equal sign + call envPutB + ld E Nil # Return NIL + else + shr E 4 # Normalize third arg + ld A E + shr A 6 # Upper bits + and Z 15 # Lowest four bits of second arg + shl Z 2 # Shift + or A Z # Combine + call chr64A # Output encoded + and E 63 # Last arg + call chr64E # Output encoded + ld E TSym # Return T + end + end + end + pop Z + pop Y + pop X + ret + +(code 'chr64E) + ld A E +(code 'chr64A) + ld B (A Chr64) # Fetch from table + jmp envPutB # Output byte + +# vi:et:ts=3:sw=3 diff --git a/src64/flow.l b/src64/flow.l @@ -0,0 +1,3150 @@ +# 19apr10abu +# (c) Software Lab. Alexander Burger + +(code 'redefMsgEC) + push (OutFile) # Save output channel + ld (OutFile) ((OutFiles) II) # Set to OutFiles[2] (stderr) + push (EnvPutB) # Save 'put' + ld (EnvPutB) putStdoutB # Set new + push C # Save optional class + ld C HashBlank # Print comment + call outStringC + call printE # Print sym + pop E # Class? + null E + if nz # Yes + call space + call printE_E # Print class + end + ld C Redefined # Print message + call outStringC + pop (EnvPutB) # Restore 'put' + pop (OutFile) # and output channel + ret +: HashBlank asciz "# " +: Redefined asciz " redefined\\n" + +(code 'putSrcEC_E) + cmp (Dbg) Nil # Debug? + if ne # Yes + sym (E TAIL) # External symbol? + if z # No + ld A (InFile) # Current InFile + null A # Any? + if nz # Yes + null (A VI) # Filename? + if nz # Yes + push X + push E # <S I> sym + push C # <S> key + ld C Dbg + call getEC_E # Get '*Dbg' properties + ld X E # into X + ld E ((InFile) VI) # Get filename + call mkStrE_E # Make string + ld A ((InFile) V) # Get 'src' + shl A 4 # Make short number + or A CNT + push E + call consE_E # (<src> . "filename") + ld (E) A + pop (E CDR) + ld A (S) # Get key + null A # Any? + if z # No + cmp X Nil # '*Dbg' properties? + if eq # No + push E + call consE_E # Make list + pop (E) + ld (E CDR) Nil + ld A (S I) # Put initial '*Dbg' properties + ld C Dbg + call putACE + else + ld (X) E # Set first '*Dbg' property + end + else + cmp X Nil # '*Dbg' properties? + if eq # No + call consE_C # Make list + ld (C) E + ld (C CDR) Nil + call consC_E # Empty first property + ld (E) Nil + ld (E CDR) C + ld A (S I) # Put initial '*Dbg' properties + ld C Dbg + call putACE + else + ld C (X CDR) # Search secondary properties + do + atom C # Any? + if nz # No + call consE_C + ld (C) (S) # Get key + ld (C CDR) E # Cons with value + call consC_A # Insert into list + ld (A) C + ld (A CDR) (X CDR) + ld (X CDR) A + break T + end + cmp ((C)) (S) # Found key? + if eq # Yes + ld ((C) CDR) E # Store value + break T + end + ld C (C CDR) + loop + end + end + pop C + pop E + pop X + end + end + end + end + ret + +(code 'redefineCEX 0) + num E # Need symbol + jnz symErrEX + sym E + jz symErrEX + call checkVarEX + ld A (E) # Current value + cmp A Nil # NIL? + if ne # NO + cmp A E # Auto-symbol? + if ne # No + push C # Save definition + push E # and sym + ld E C # Value + call equalAE_F # Changing? + if ne # Yes + ld E (S) # Get sym + ld C 0 # No class + call redefMsgEC + end + pop E # Retrieve sym + pop C # and definition + end + end + ld (E) C # Set definition + ld C 0 # No class + call putSrcEC_E # Put source information + ret + +# (quote . any) -> any +(code 'doQuote 2) + ld E (E CDR) # Get CDR + ret + +# (as 'any1 . any2) -> any2 | NIL +(code 'doAs 2) + ld E (E CDR) + push E # Save args + ld E (E) # Eval condition + eval + pop A # Retrieve args + cmp E Nil # Result NIL? + ldnz E (A CDR) # No: Return 'any2' + ret + +# (pid 'pid|lst . exe) -> any +(code 'doPid 2) + ld E (E CDR) + push (E CDR) # Push rest + ld E (E) # Eval condition + eval + ld A (Pid) # Get '*Pid' + atom E # Single 'pid'? + if nz # Yes + cmp E A # Matches '*Pid'? + pop E + jne retNil # No + eval/ret # Evaluate 'exe' + end + do + cmp (E) A # CAR matches '*Pid'? + if eq + pop E + eval/ret # Evaluate 'exe' + end + ld E (E CDR) # Try next + atom E # Any? + until nz # No + pop A # Drop 'exe' + ret + +# (lit 'any) -> any +(code 'doLit 2) + ld E (E CDR) # Get arg + ld E (E) # Eval it + eval + num E # Number? + if z # No + cmp E Nil # NIL? + if ne # No + cmp E TSym # T? + if ne # No + atom E # Cell? + jnz 10 # No + num (E) # CAR number? + if z # No +10 ld A E + call consE_E # Cons with 'quote' + ld (E) Quote + ld (E CDR) A + end + end + end + end + ret + +# (eval 'any ['cnt ['lst]]) -> any +(code 'doEval 2) + push X + ld X (E CDR) # Args + ld E (X) # Eval first + eval + link + push E # <L I> 'any' + link + ld X (X CDR) # X on rest + atom X # Any? + if nz # No +10 eval # Evaluate 'any' + drop + pop X + ret + end + null (EnvBind) # Bindings? + jz 10 # No + ld E (X) # Eval 'cnt' + eval + shr E 4 # Normalize + push E # <L -I> 'cnt' + push 0 # <L -II> 'n' + ld E ((X CDR)) # Last argument + eval # Exclusion list 'lst' in E + push Y + ld C (L -I) # Get 'cnt' + ld Y (EnvBind) # and bindings + do + ld A (Y) # End of bindings in A + add (L -II) 1 # Increment 'n' + sub (Y -I) (L -I) # Decrement 'eswp' by 'cnt' + if c # First pass + add Y I + do + ld X (Y) # Next symbol + xchg (X) (Y I) # Exchange symbol value with saved value + add Y II + cmp Y A # More? + until eq # No + cmp X At # Lambda frame? + if eq # Yes + sub C 1 # Decrement local 'cnt' + break z # Done + end + end + ld Y (A I) # Bind link + null Y # More bindings? + until z # No + atom E # Exclusion list? + if nz # No + ld E (L I) # Get 'any' + eval # Evaluate it + else + push (EnvBind) # Build bind frame + link + do + ld X (E) # Next excluded symbol + push (X) # Save in bind frame + push X + ld C (L -II) # Get 'n' + ld Y (EnvBind) # Bindings + do + ld A (Y) # End of bindings in A + add Y I + do + cmp X (Y) # Found excluded symbol? + if eq # Yes + ld (X) (Y I) # Bind to found value + jmp 20 + end + add Y II + cmp Y A # More? + until eq # No + sub C 1 # Traversed 'n' frames? + while nz # No + ld Y (A I) # Bind link + null Y # More bindings? + until z # No +20 ld E (E CDR) + atom E # Exclusion list? + until nz # No + ld E ((L) I) # Get 'any' + link + ld (EnvBind) L # Close bind frame + push 0 # Init env swap + eval # Evaluate 'any' + pop A # Drop env swap + pop L # Get link + do # Unbind excluded symbols + pop X # Next symbol + pop (X) # Restore value + cmp S L # More? + until eq # No + pop L # Restore link + pop (EnvBind) # Restore bind link + end + ld C (L -II) # Get 'n' + do + ld A C # in A + ld Y (EnvBind) # Bindings + do + sub A 1 # 'n-1' times + while nz + ld Y ((Y) I) # Follow link + loop + ld A (Y) # End of bindings in A + add (Y -I) (L -I) # Increment 'eswp' by 'cnt' + if z # Last pass + sub A II + do + xchg ((A)) (A I) # Exchange next symbol value with saved value + sub A II + cmp A Y # More? + until lt # No + end + sub C 1 # Decrement 'n' + until z # Done + pop Y + drop + pop X + ret + +# (run 'any ['cnt ['lst]]) -> any +(code 'doRun 2) + push X + ld X (E CDR) # Args + ld E (X) # Eval first + eval + num E # 'any' is number? + if z # No + link + push E # <L I> 'any' + link + ld X (X CDR) # X on rest + atom X # Any? + if nz # No +10 sym E # Symbolic? + if nz # Yes + ld E (E) # Get value + else + call runE_E # Execute + end + drop + pop X + ret + end + null (EnvBind) # Bindings? + jz 10 # No + ld E (X) # Eval 'cnt' + eval + shr E 4 # Normalize + push E # <L -I> 'cnt' + push 0 # <L -II> 'n' + ld E ((X CDR)) # Last argument + eval # Exclusion list 'lst' in E + push Y + ld C (L -I) # Get 'cnt' + ld Y (EnvBind) # and bindings + do + ld A (Y) # End of bindings in A + add (L -II) 1 # Increment 'n' + sub (Y -I) (L -I) # Decrement 'eswp' by 'cnt' + if c # First pass + add Y I + do + ld X (Y) # Next symbol + xchg (X) (Y I) # Exchange symbol value with saved value + add Y II + cmp Y A # More? + until eq # No + cmp X At # Lambda frame? + if eq # Yes + sub C 1 # Decrement local 'cnt' + break z # Done + end + end + ld Y (A I) # Bind link + null Y # More bindings? + until z # No + atom E # Exclusion list? + if nz # No + ld X (L I) # Run 'any' + sym X # Symbolic? + if nz # Yes + ld E (X) # Get value + else + prog X # Execute + end + else + push (EnvBind) # Build bind frame + link + do + ld X (E) # Next excluded symbol + push (X) # Save in bind frame + push X + ld C (L -II) # Get 'n' + ld Y (EnvBind) # Bindings + do + ld A (Y) # End of bindings in A + add Y I + do + cmp X (Y) # Found excluded symbol? + if eq # Yes + ld (X) (Y I) # Bind to found value + jmp 20 + end + add Y II + cmp Y A # More? + until eq # No + sub C 1 # Traversed 'n' frames? + while nz # No + ld Y (A I) # Bind link + null Y # More bindings? + until z # No +20 ld E (E CDR) + atom E # Exclusion list? + until nz # No + ld X ((L) I) # Get 'any' + link + ld (EnvBind) L # Close bind frame + push 0 # Init env swap + sym X # 'any' symbolic? + if nz # Yes + ld E (X) # Get value + else + prog X # Execute + end + pop A # Drop env swap + pop L # Get link + do # Unbind excluded symbols + pop X # Next symbol + pop (X) # Restore value + cmp S L # More? + until eq # No + pop L # Restore link + pop (EnvBind) # Restore bind link + end + ld C (L -II) # Get 'n' + do + ld A C # in A + ld Y (EnvBind) # Bindings + do + sub A 1 # 'n-1' times + while nz + ld Y ((Y) I) # Follow link + loop + ld A (Y) # End of bindings in A + add (Y -I) (L -I) # Increment 'eswp' by 'cnt' + if z # Last pass + sub A II + do + xchg ((A)) (A I) # Exchange next symbol value with saved value + sub A II + cmp A Y # More? + until lt # No + end + sub C 1 # Decrement 'n' + until z # Done + pop Y + drop + end + pop X + ret + +# (def 'sym 'any) -> sym +# (def 'sym 'sym 'any) -> sym +(code 'doDef 2) + push X + push Y + ld X E + ld Y (E CDR) # Y on args + ld E (Y) # Eval first + eval + call needSymEX # Check symbol + sym (E TAIL) # External symbol? + if nz # Yes + call dbTouchEX # Touch it + end + link + push E # <L II/III> First symbol + ld Y (Y CDR) # Next arg + ld E (Y) + eval+ # Eval next arg + push E # <L I/II> Second arg + link + ld Y (Y CDR) # Third arg? + atom Y + if nz # No + ld C (L II) # First symbol + ld A (C) # Current value + cmp A Nil # NIL? + if ne # NO + cmp A C # Auto-symbol? + if ne # No + call equalAE_F # Changing? + if ne # Yes + ld E C # Get sym + ld C 0 # No class + call redefMsgEC + end + end + end + ld E (L II) # Get symbol + ld (E) (L I) # Set new value + ld C 0 # No class + call putSrcEC_E # Put source information + else + ld E (Y) + eval # Eval next arg + tuck E # <L I> Third arg + link + ld E (L III) # First symbol + sym (E TAIL) # External symbol? + if nz # Yes + call dbTouchEX # Touch it + end + ld C (L II) # Second arg + call getEC_E # Current property value + cmp E Nil # NIL? + if ne # NO + ld A (L I) # New value + call equalAE_F # Changing? + if ne # Yes + ld E (L III) # First symbol + ld C (L II) # Property key + call redefMsgEC + end + end + ld A (L III) # Symbol + ld C (L II) # Key + ld E (L I) # Value + call putACE + ld E (L III) # Symbol + ld C (L II) # Key + call putSrcEC_E # Put source information + end + drop # Return first symbol + pop Y + pop X + ret + +# (de sym . any) -> sym +(code 'doDe 2) + push X + ld X (E CDR) # Args + ld E (X) # Symbol in E + ld C (X CDR) # Body in C + call redefineCEX # Redefine + pop X + ret + +# (dm sym . fun|cls2) -> sym +# (dm (sym . cls) . fun|cls2) -> sym +# (dm (sym sym2 [. cls]) . fun|cls2) -> sym +(code 'doDm 2) + push X + push Y + ld X E + ld Y (E CDR) # Y on args + ld E (Y) # Get first + atom E # First form? + if nz # Yes + ld C (Class) # Get 'cls' from Class + else + ld C (E CDR) + atom C # Second form? + if z # No + ld E (C CDR) # 'cls'? + cmp E Nil + if eq # No + ld E (Class) # Default to Class + end + ld C (C) # 'sym' + call getEC_E # Get instance object + ld C E # into C + ld E (Y) # Get first again + end + ld E (E) # msg + end + cmp E TSym # 'msg' is T? + if ne # No + push C # Save class + ld C doMeth # Get 'meth' code pointer + call redefineCEX # Redefine + pop C + end + ld A (Y CDR) # Explicit inheritance? + num A + if z # No + sym A + if nz # Yes + ld A (A) # Get cls2's value + do + atom A # More method definitions? + jnz msgErrAX # No + atom (A) + jnz msgErrAX + cmp E ((A)) # Found 'msg'? + if eq # Yes + ld Y (A) # Get method entry + break T + end + ld A (A CDR) + loop + end + end + ld X (C) # Get cls's value + do + atom X # More method definitions? + while z # Yes + atom (X) + while z + cmp E ((X)) # Found 'msg'? + if eq # Yes + push E # Save 'msg' + ld E ((X) CDR) # Old body + ld A (Y CDR) # New body + call equalAE_F # Changing? + if ne # Yes + ld E (S) # Get 'msg' + push C # Save 'cls' + call redefMsgEC + pop C + end + pop E + ld ((X) CDR) (Y CDR) # Set new body + call putSrcEC_E # Put source information + pop Y + pop X + ret + end + ld X (X CDR) + loop + atom (Y) # First form or explict inheritance? + if nz # Yes + call cons_A # Cons into methods + ld (A) Y + ld (A CDR) (C) + else + call cons_A # Cons 'msg' + ld (A) E + ld (A CDR) (Y CDR) # With method body + push A + call consA_A # Cons into methods + pop (A) + ld (A CDR) (C) + end + ld (C) A + call putSrcEC_E # Put source information + pop Y + pop X + ret + +# Apply METH in C to X, with object A +(code 'evMethodACXYZ_E 0) + push Z # 'cls' + push Y # 'key' + push (EnvMeth) # <(L) II> Method frame + ld Y (C) # Parameter list in Y + ld Z (C CDR) # Body in Z + push (EnvBind) # Build bind frame + link + push (At) # Bind At + push At + push A # Bind object in A + push This # to 'This' + do + atom Y # More evaluating parameters? + while z # Yes + ld E (X) # Get next argument + ld X (X CDR) + eval+ # Evaluate and save + push E + push (Y) # Save symbol + ld Y (Y CDR) + loop + cmp Y Nil # NIL-terminated parameter list? + if eq # Yes: Bind parameter symbols + ld Y S # Y on bindings + do + ld X (Y) # Symbol in X + add Y I + ld A (X) # Old value in A + ld (X) (Y) # Set new value + ld (Y) A # Save old value + add Y I + cmp Y L # End? + until eq # Yes + link + ld (EnvBind) L # Close bind frame + push 0 # Init env swap + lea (EnvMeth) ((L) II) # and method frame + prog Z # Run body + pop A # Drop env swap + pop L # Get link + do # Unbind symbols + pop X # Next symbol + pop (X) # Restore value + cmp S L # More? + until eq # No + pop L # Restore link + pop (EnvBind) # Restore bind link + pop (EnvMeth) # and method link + pop A # Drop frame + pop A + ret + end + # Non-NIL parameter + cmp Y At # '@'? + if ne # No + push (Y) # Save last parameter's old value + push Y # and the last parameter + ld (Y) X # Set to unevaluated argument list + lea Y (S II) # Y on evaluated bindings + do + ld X (Y) # Symbol in X + add Y I + ld A (X) # Old value in A + ld (X) (Y) # Set new value + ld (Y) A # Save old value + add Y I + cmp Y L # End? + until eq # Yes + link + ld (EnvBind) L # Close bind frame + push 0 # Init env swap + lea (EnvMeth) ((L) II) # and method frame + prog Z # Run body + pop A # Drop env swap + pop L # Get link + do # Unbind symbols + pop X # Next symbol + pop (X) # Restore value + cmp S L # More? + until eq # No + pop L # Restore link + pop (EnvBind) # Restore bind link + pop (EnvMeth) # and method link + pop A # Drop frame + pop A + ret + end + # Evaluated argument list + link # Close bind frame + ld Y L # Y on frame + push 0 # Init env swap + push (EnvNext) # Save current 'next' + push (EnvArgs) # and varArgs base + atom X # Any args? + if nz # No + ld (EnvArgs) 0 + ld (EnvNext) 0 + else + link # Build varArgs frame + do + ld E (X) # Get next argument + eval+ # Evaluate and save + push E + ld X (X CDR) + atom X # More args? + until nz # No + ld (EnvArgs) S # Set new varArgs base + ld (EnvNext) L # Set new 'next' + link # Close varArgs frame + end + ld (EnvBind) Y # Close bind frame + lea (EnvMeth) ((Y) II) # and method frame + ld C (Y) # End of bindings in C + add Y I + do + ld X (Y) # Symbol in X + add Y I + ld A (X) # Old value in A + ld (X) (Y) # Set new value + ld (Y) A # Save old value + add Y I + cmp Y C # End? + until eq # Yes + prog Z # Run body + null (EnvNext) # VarArgs? + if nz # Yes + drop # Drop varArgs + end + pop (EnvArgs) # Restore varArgs base + pop (EnvNext) # and 'next' + pop A # Drop env swap + pop L # Get link + do # Unbind symbols + pop X # Next symbol + pop (X) # Restore value + cmp S L # More? + until eq # No + pop L # Restore link + pop (EnvBind) # Restore bind link + pop (EnvMeth) # and method link + pop A # Drop frame + pop A + ret + +(code 'methodEY_FCYZ 0) + ld A (E) # Get class definition (methods and superclasses) + atom A # Any? + if z # Yes + do + ld C (A) # First item + atom C # Method definition? + while z # Yes + cmp Y (C) # Found method definition? + if eq # Yes + ld C (C CDR) # Return method + ret # 'z' + end + ld A (A CDR) # Next item + atom A # Any? + jnz ret # Return 'nz' + loop + do + ld Z A # Set class list + ld E (A) # Class symbol + push A + call methodEY_FCYZ # Found method definition? + pop A + jeq ret # 'z' + ld A (A CDR) # Next superclass + atom A # Any? + until nz # No + end + ret # 'nz' + +# (box 'any) -> sym +(code 'doBox 2) + ld E ((E CDR)) # Get arg + eval # Eval it + call consE_A # New symbol + ld (A) ZERO # anonymous + or A SYM + ld (A) E # Set value + ld E A + ret + +# (new ['flg|num] ['typ ['any ..]]) -> obj +(code 'doNew 2) + push X + push Y + push Z + ld X E + ld Y (E CDR) # Y on args + ld E (Y) # Eval first + eval + atom E # 'typ' list? + if z # Yes + call consE_A # New object + ld (A) ZERO # anonymous + or A SYM # Make symbol + ld (A) E # Set 'typ' + link + push A # <L II> 'obj' + push Nil # <L I> Safe + link + else + cmp E Nil # 'flg'? + if eq # NIL + call cons_E # New object + ld (E) ZERO # anonymous + or E SYM # Make symbol + ld (E) Nil # Init to 'NIL' + else # External object + cnt E # File number? + ldz E ONE # Default to '1' + shr E 4 # Normalize + call newIdEX_X # Allocate new external name + call externX_E # Intern external symbol + ld A (E TAIL) # Get name again + shl A 1 + setc # Set "dirty" + rcr A 1 + ld (E TAIL) A # Set name + end + link + push E # <L II> 'obj' + push Nil # <L I> Safe + link + ld Y (Y CDR) # Next arg + ld E (Y) + eval # Eval 'typ' + ld A (L II) # Object in A + ld (A) E # Set value in 'obj' + end + ld X (Y CDR) # Keep args in X + ld E A # Object + ld Y TSym # Search for initial method + ld Z Nil # No classes + call methodEY_FCYZ # Found? + if eq # Yes + ld A (L II) # 'obj' + call evMethodACXYZ_E + else + do + atom X # More args? + while z # Yes + ld E (X) # Eval next key + eval + ld (L I) E # Save it + ld X (X CDR) + ld E (X) # Eval next value + eval + ld A (L II) # 'obj' + ld C (L I) # Key + call putACE # Put value + ld X (X CDR) + loop + end + ld E (L II) # Return 'obj' + drop + pop Z + pop Y + pop X + ret + +# (type 'any) -> lst +(code 'doType 2) + push X + ld X E + ld E ((E CDR)) # E on arg + eval # Eval it + num E # Symbol? + if z + sym E + if nz # Yes + sym (E TAIL) # External symbol? + if nz # Yes + call dbFetchEX # Fetch it + end + pop X + ld E (E) # Get value + ld C E # Keep in C + do + atom E # Class definitions? + jnz retNil # No + atom (E) # Class? + if nz # Yes + ld A E + do + num (A) # Symbol? + jnz retNil # No + ld A (A CDR) # Next class + atom A # Any? + if nz # No + cmp A Nil # End of classes? + jnz retNil # No + ret # Return E + end + cmp C A # Circular? + jeq retNil # Yes + loop + end + ld E (E CDR) # Next definition + cmp C E # Circular? + jeq retNil # Yes + loop + end + end + pop X + ld E Nil # Return NIL + ret + +# (isa 'cls|typ 'any) -> obj | NIL +(code 'doIsa 2) + push X + push Y + ld X E + ld Y (E CDR) # Y on args + ld E (Y) # Eval first + eval + link + push E # <L I> 'cls|typ' + link + ld Y (Y CDR) # Next arg + ld E (Y) + eval # Eval 'any' + num E # Symbol? + if z + sym E + if nz # Yes + sym (E TAIL) # External symbol? + if nz # Yes + call dbFetchEX # Fetch it + end + ld C (L I) # Get 'cls|typ' + atom C # 'cls'? + if nz # Yes + call isaCE_F # Check + ldnz E Nil # Return NIL if no match + else + ld Y C # Get 'typ' in Y + do + ld C (Y) # Next class + call isaCE_F # Check + if nz + ld E Nil # Return NIL if no match + break T + end + ld Y (Y CDR) # More? + atom Y + until nz # No + end + drop + pop Y + pop X + ret + end + end + ld E Nil # Return NIL + drop + pop Y + pop X + ret + +: isaCE_F # A, X + ld X (E) # Get value + ld A X # Keep in A + do + atom X # Atomic value? + jnz ret # Return NO + atom (X) # Next item atomic? + if nz # Yes + do + num (X) # Numeric? + jnz ret # Return NO + sym ((X) TAIL) # External? + jnz ret # Return NO + cmp C (X) # Match? + jeq ret # Return YES + push A # Save list head + push E # object + push X # and list + ld E (X) # Recurse + call isaCE_F # Match? + pop X + pop E + pop A + jeq ret # Return YES + ld X (X CDR) # Next class + atom X # Any? + jnz ret # Return NO + cmp A X # Circular? + jeq retnz # Return NO + atom (X) # Next item a list? + jz retnz # Return NO + loop + end + ld X (X CDR) # Next item + cmp A X # Circular? + jeq retnz # Yes + loop + +# (method 'msg 'obj) -> fun +(code 'doMethod 2) + push X + push Y + push Z + ld X E + ld Y (E CDR) # Y on args + ld E (Y) # Eval first + eval # Eval it + num E # Need symbol + jnz symErrEX + sym E + jz symErrEX + link + push E # <L I> 'msg' + link + ld E ((Y CDR)) # Second + eval # 'obj' + num E # Need symbol + jnz symErrEX + sym E + jz symErrEX + sym (E TAIL) # External symbol? + if nz # Yes + call dbFetchEX # Fetch it + end + ld Y (L I) # 'msg' + call methodEY_FCYZ # Found? + ld E C # Yes + ldnz E Nil # No + drop + pop Z + pop Y + pop X + ret + +# (meth 'obj ..) -> any +(code 'doMeth 2) + push X + push Y + push Z + ld X E + ld Y (E CDR) # Y on args + ld E (Y) # Eval 'obj' + eval + num E # Need symbol + jnz symErrEX + sym E + jz symErrEX + link + push E # <L I> 'obj' + link + sym (E TAIL) # External symbol? + if nz # Yes + call dbFetchEX # Fetch it + end + push (Y CDR) # Save args + ld Y (X) # Get 'msg' + do + num Y # Need symbol + jnz msgErrYX + sym Y + jz msgErrYX + cnt (Y) # Value numeric? + if nz # Yes + ld Z Nil # No classes + call methodEY_FCYZ # Found? + jne msgErrYX # No + ld A (L I) # Get 'obj' + pop X # and args + call evMethodACXYZ_E + drop + pop Z + pop Y + pop X + ret + end + ld Y (Y) # Get value + loop + +# (send 'msg 'obj ['any ..]) -> any +(code 'doSend 2) + push X + push Y + push Z + ld X E + ld Y (E CDR) # Y on args + ld E (Y) # Eval 'msg' + eval + num E # Need symbol + jnz symErrEX + sym E + jz symErrEX + link + push E # <L II> 'msg' + ld Y (Y CDR) # Next arg + ld E (Y) + eval+ # Eval 'obj' + push E # <L I> 'obj' + link + num E # Need symbol + jnz symErrEX + sym E + jz symErrEX + sym (E TAIL) # External symbol? + if nz # Yes + call dbFetchEX # Fetch it + end + ld X (Y CDR) # Keep args in X + ld Y (L II) # Get 'msg' + ld Z Nil # No classes + call methodEY_FCYZ # Found? + jne msgErrYX # No + ld A (L I) # Get 'obj' + call evMethodACXYZ_E + drop + pop Z + pop Y + pop X + ret + +# (try 'msg 'obj ['any ..]) -> any +(code 'doTry 2) + push X + push Y + push Z + ld X E + ld Y (E CDR) # Y on args + ld E (Y) # Eval 'msg' + eval + num E # Need symbol + jnz symErrEX + sym E + jz symErrEX + link + push E # <L II> 'msg' + ld Y (Y CDR) # Next arg + ld E (Y) + eval+ # Eval + push E # <L I> 'obj' + link + num E # Symbol? + jnz 90 + sym E + jz 90 # No + sym (E TAIL) # External symbol? + if nz # Yes + call isLifeE_F # Alive? + jnz 90 # No + call dbFetchEX # Fetch it + end + ld X (Y CDR) # Keep args in X + ld Y (L II) # Get 'msg' + ld Z Nil # No classes + call methodEY_FCYZ # Found? + if eq # Yes + ld A (L I) # Get 'obj' + call evMethodACXYZ_E + else +90 ld E Nil + end + drop + pop Z + pop Y + pop X + ret + +# (super ['any ..]) -> any +(code 'doSuper 2) + push X + push Y + push Z + push E # Save expression + ld A (EnvMeth) # Method frame + ld Y (A I) # 'key' + ld X (A II) # 'cls' + cmp X Nil # Any? + ldnz X (X) # Yes: First class + ldz X (This) # No: 'This' + ld X (X) # Get class definition + do + atom (X) # Method? + while z # Yes + ld X (X CDR) # Skip + loop + do + atom X # Classes? + while z # Yes + ld E (X) # First class + ld Z X # 'cls' + call methodEY_FCYZ # Found? + if eq # Yes + pop E # Get expression + push Z # 'cls' + push Y # 'key' + push (EnvMeth) # Build method frame + ld (EnvMeth) S + call evExprCE_E # Evaluate expression + pop (EnvMeth) # Restore method link + pop A # Drop frame + pop A + pop Z + pop Y + pop X + ret + end + ld X (X CDR) + loop + ld E Y # 'key' + pop X # Expression + ld Y SuperErr + jmp errEXYZ +: SuperErr asciz "Bad super" + +# (extra ['any ..]) -> any +(code 'doExtra 2) + push X + push Y + push Z + push E # Save expression + ld Y ((EnvMeth) I) # Get 'key' + ld X (This) # Current object + call extraXY_FCYZ # Locate extra method + if eq + pop E # Get expression + push Z # 'cls' + push Y # 'key' + push (EnvMeth) # Build method frame + ld (EnvMeth) S + call evExprCE_E # Evaluate expression + pop (EnvMeth) # Restore method link + pop A # Drop frame + pop A + pop Z + pop Y + pop X + ret + end + ld E Y # 'key' + pop X # Expression + ld Y ExtraErr + jmp errEXYZ +: ExtraErr asciz "Bad extra" + +(code 'extraXY_FCYZ 0) + ld X (X) # Get class definition + do + atom (X) # Method? + while z # Yes + ld X (X CDR) # Skip + loop + do + atom X # Classes? + while z # Yes + cmp X ((EnvMeth) II) # Hit current 'cls' list? + if eq # Yes +10 do + ld X (X CDR) # Locate method in extra classes + atom X # Any? + while z # No: Return 'gt' + ld E (X) # Superclass + ld Z X # 'cls' + call methodEY_FCYZ # Found? + until eq # Return 'eq' + ret + end + push X + ld X (X) # Recurse on superclass + call extraXY_FCYZ # Found? + pop X + jeq ret # Yes + jgt 10 # Else try extra classes + ld X (X CDR) # Try next in 'cls' list + loop + setc # Return 'lt' + ret + +# (with 'sym . prg) -> any +(code 'doWith 2) + push X + ld X (E CDR) # Args + ld E (X) # Eval first + eval + cmp E Nil # Non-NIL? + if ne # Yes + num E # Need symbol + jnz symErrEX + sym E + jz symErrEX + push (EnvBind) # Build bind frame + link + push (This) # Save old 'This' + push This # and 'sym' + link + ld (EnvBind) L # Close bind frame + push 0 # Init env swap + ld (This) E # Set new + ld X (X CDR) # Run 'prg' + prog X + pop A # Drop 'eswp' + link + 'This' + pop A + pop A + pop (This) # Restore value + pop L # Restore link + pop (EnvBind) # Restore bind link + end + pop X + ret + +# (bind 'sym|lst . prg) -> any +(code 'doBind 2) + push X + ld X (E CDR) # Args + ld E (X) # Eval first + eval + num E # Need sym|lst + jnz argErrEX + ld X (X CDR) # X on 'prg' + cmp E Nil # No bindings? + if eq # Yes + prog X # Run 'prg' + pop X + ret + end + push (EnvBind) # Build bind frame + link + sym E # Single symbol? + if nz # Yes + push (E) # Save value + push E # and 'sym' + link + ld (EnvBind) L # Close bind frame + push 0 # Init env swap + prog X # Run 'prg' + pop A # Drop env swap + pop L # Get link + pop X # Unbind symbol + pop (X) # Restore value + pop L # Restore link + pop (EnvBind) # Restore bind link + pop X + ret + end + do + ld A (E) # Next item + num A # Need symbol or pair + jnz argErrAX + ld C (A) # Get VAL or CAR + sym A # Symbol? + if nz # Yes + push C # Save value + push A # and 'sym' + else + push (C) # Save value + push C # and 'sym' + ld (C) (A CDR) # Set new value + end + ld E (E CDR) # More items? + atom E + until nz # No + link + ld (EnvBind) L # Close bind frame + push 0 # Init env swap + prog X # Run 'prg' + pop A # Drop env swap + pop L # Get link + do # Unbind symbols + pop X # Next symbol + pop (X) # Restore value + cmp S L # More? + until eq # No + pop L # Restore link + pop (EnvBind) # Restore bind link + pop X + ret + +# (job 'lst . prg) -> any +(code 'doJob 2) + push X + ld X (E CDR) # Args + ld E (X) # Eval first + eval + cmp E Nil # Empty env 'lst'? + if ne # No + push (EnvBind) # Build bind frame + link + ld A E # Get 'lst' + do + ld C (A) # Next cell + push ((C)) # Save value + push (C) # and sym + ld ((C)) (C CDR) # Set new value + ld A (A CDR) + atom A # More cells? + until nz # No + link + ld (EnvBind) L # Close bind frame + push 0 # Init env swap + end + link + push E # <L I> 'lst' + link + ld X (X CDR) # X on 'prg' + prog X # Run 'prg' + pop A # Drop link + pop C # Retrieve 'lst' + pop L # Unlink + cmp C Nil # Empty env 'lst'? + if ne # No + pop A # Drop env swap + lea X ((L) -II) # X on bindings + do # Unbind symbols + ld A (X) # Next symbol + ld ((C) CDR) (A) # Store value in env + ld (A) (X I) # Restore value + ld C (C CDR) + sub X II # Reverse stacked order + cmp X L # More? + until lt # No + drop # Restore link + pop (EnvBind) # Restore bind link + end + pop X + ret + +# (let sym 'any . prg) -> any +# (let (sym 'any ..) . prg) -> any +(code 'doLet 2) + push X + push Y + ld X (E CDR) # Args + ld Y (X) # First arg + ld X (X CDR) + push (EnvBind) # Build bind frame + link + sym Y # Single symbol? + if nz # Yes + push (Y) # Save old value + push Y # and 'sym' + link + ld (EnvBind) L # Close bind frame + push 0 # Init env swap + ld E (X) # Eval 'any' + eval + ld (Y) E # Set new value + ld X (X CDR) # Run 'prg' + prog X + pop A # Drop env swap + pop L # Get link + pop X # Unbind symbol + pop (X) # Restore value + pop L # Restore link + pop (EnvBind) # Restore bind link + pop Y + pop X + ret + end + do + ld A (Y) # Next sym + push (A) # Save old value + push A # and sym + link + ld (EnvBind) L # Close bind frame + push 0 # Init env swap + ld E ((Y CDR)) # Eval 'any' + eval + ld ((Y)) E # Set new value + ld Y ((Y CDR) CDR) # More symbols? + atom Y + while z # Yes + pop A # Drop env swap + pop L # and link + loop + prog X # Run 'prg' + pop A # Drop env swap + pop L # Get link + do # Unbind symbols + pop X # Next symbol + pop (X) # Restore value + cmp S L # More? + until eq # No + pop L # Restore link + pop (EnvBind) # Restore bind link + pop Y + pop X + ret + +# (let? sym 'any . prg) -> any +(code 'doLetQ 2) + push X + push Y + ld X (E CDR) # Args + ld Y (X) # Get 'sym' + ld X (X CDR) + ld E (X) # Eval 'any' + eval + cmp E Nil # NIL? + if ne # No + push (EnvBind) # Build bind frame + link + push (Y) # Save old value + push Y # and 'sym' + link + ld (EnvBind) L # Close bind frame + push 0 # Init env swap + ld (Y) E # Set new value + ld X (X CDR) # Run 'prg' + prog X + pop A # Drop env swap + pop L # Get link + pop X # Unbind symbol + pop (X) # Restore value + pop L # Restore link + pop (EnvBind) # Restore bind link + end + pop Y + pop X + ret + +# (use sym . prg) -> any +# (use (sym ..) . prg) -> any +(code 'doUse 2) + push X + push Y + ld X (E CDR) # Args + ld Y (X) # First arg + ld X (X CDR) + push (EnvBind) # Build bind frame + link + sym Y # Single symbol? + if nz # Yes + push (Y) # Save old value + push Y # and 'sym' + link + ld (EnvBind) L # Close bind frame + push 0 # Init env swap + prog X # Run 'prg' + pop A # Drop env swap + pop L # Get link + pop X # Unbind symbol + pop (X) # Restore value + pop L # Restore link + pop (EnvBind) # Restore bind link + pop Y + pop X + ret + end + do + ld A (Y) # Next sym + push (A) # Save old value + push A # and sym + ld Y (Y CDR) # More symbols? + atom Y + until nz # No + link + ld (EnvBind) L # Close bind frame + push 0 # Init env swap + prog X # Run 'prg' + pop A # Drop env swap + pop L # Get link + do # Unbind symbols + pop X # Next symbol + pop (X) # Restore value + cmp S L # More? + until eq # No + pop L # Restore link + pop (EnvBind) # Restore bind link + pop Y + pop X + ret + +# (and 'any ..) -> any +(code 'doAnd 2) + push X + ld X (E CDR) # Args + do + ld E (X) # Eval next + eval + cmp E Nil # NIL? + while ne # No + ld (At) E + ld X (X CDR) # X on rest + atom X # Done? + until nz # Yes + pop X + ret + +# (or 'any ..) -> any +(code 'doOr 2) + push X + ld X (E CDR) # Args + do + ld E (X) # Eval next + eval + cmp E Nil # NIL? + if ne # No + ld (At) E + pop X + ret + end + ld X (X CDR) # X on rest + atom X # Done? + until nz # Yes + pop X + ret + +# (nand 'any ..) -> flg +(code 'doNand 2) + push X + ld X (E CDR) # Args + do + ld E (X) # Eval next + eval + cmp E Nil # NIL? + if eq # Yes + ld E TSym # Return T + pop X + ret + end + ld (At) E + ld X (X CDR) # X on rest + atom X # Done? + until nz # Yes + ld E Nil # Return NIL + pop X + ret + +# (nor 'any ..) -> flg +(code 'doNor 2) + push X + ld X (E CDR) # Args + do + ld E (X) # Eval next + eval + cmp E Nil # NIL? + if ne # No + ld (At) E + ld E Nil # Return NIL + pop X + ret + end + ld X (X CDR) # X on rest + atom X # Done? + until nz # Yes + ld E TSym # Return T + pop X + ret + +# (xor 'any 'any) -> flg +(code 'doXor 2) + ld E (E CDR) + push (E CDR) # Push rest + ld E (E) # Eval first + eval + cmp E Nil # NIL? + if eq # Yes + pop E # Get rest + ld E (E) # Eval second + eval + cmp E Nil # NIL again? + ldnz E TSym # No + ret + end + pop E # Get rest + ld E (E) # Eval second + eval + cmp E Nil # NIL? + ld E Nil + ldz E TSym # Yes + ret + +# (bool 'any) -> flg +(code 'doBool 2) + ld E ((E CDR)) # Get arg + eval # Eval it + cmp E Nil # NIL? + ldnz E TSym # No + ret + +# (not 'any) -> flg +(code 'doNot 2) + ld E ((E CDR)) # Get arg + eval # Eval it + cmp E Nil # NIL? + jeq retT # Yes + ld (At) E + ld E Nil + ret + +# (nil . prg) -> NIL +(code 'doNil 2) + push X + ld X (E CDR) # Get 'prg' + exec X # Execute it + ld E Nil # Return NIL + pop X + ret + +# (t . prg) -> T +(code 'doT 2) + push X + ld X (E CDR) # Get 'prg' + exec X # Execute it + ld E TSym # Return T + pop X + ret + +# (prog . prg) -> any +(code 'doProg 2) + push X + ld X (E CDR) # Get 'prg' + prog X # Run it + pop X + ret + +# (prog1 'any1 . prg) -> any1 +(code 'doProg1 2) + push X + ld X (E CDR) # Args + ld E (X) # Eval first + eval + ld (At) E + link + push E # <L I> Result + link + ld X (X CDR) # Get 'prg' + exec X # Execute it + ld E (L I) # Get result + drop + pop X + ret + +# (prog2 'any1 'any2 . prg) -> any2 +(code 'doProg2 2) + push X + ld X (E CDR) # Args + ld E (X) # Eval first + eval + ld X (X CDR) # Eval second + ld E (X) + eval + ld (At) E + link + push E # <L I> Result + link + ld X (X CDR) # Get 'prg' + exec X # Execute it + ld E (L I) # Get result + drop + pop X + ret + +# (if 'any1 'any2 . prg) -> any +(code 'doIf 2) + ld E (E CDR) + push (E CDR) # Push rest + ld E (E) # Eval condition + eval + cmp E Nil + if ne # Non-NIL + ld (At) E + pop E # Get rest + ld E (E) # Consequent + eval/ret + end + xchg X (S) # Get rest in X + ld X (X CDR) # Else + prog X + pop X + ret + +# (if2 'any1 'any2 'any3 'any4 'any5 . prg) -> any +(code 'doIf2 2) + ld E (E CDR) + push (E CDR) # Push rest + ld E (E) # Eval first condition 'any1' + eval + cmp E Nil + if eq # NIL + xchg X (S) # Get rest in X + ld E (X) # Eval second condition 'any2' + eval + cmp E Nil + if eq # Also NIL + ld X ((((X CDR) CDR) CDR) CDR) # Run 'prg' + prog X + pop X + ret + end + ld (At) E + ld X (((X CDR) CDR) CDR) # Eval 'any5' + ld E (X) + pop X + eval/ret + end + ld (At) E # 'any1' is non-Nil + xchg X (S) # Get rest in X + ld E (X) # Eval second condition 'any2' + eval + cmp E Nil + if eq # NIL + ld X ((X CDR) CDR) # Eval 'any4' + ld E (X) + pop X + eval/ret + end + ld (At) E # Both are non-Nil + ld X (X CDR) # Eval 'any3' + ld E (X) + pop X + eval/ret + +# (ifn 'any1 'any2 . prg) -> any +(code 'doIfn 2) + ld E (E CDR) + push (E CDR) # Push body + ld E (E) # Eval condition + eval + cmp E Nil + if eq # NIL + pop E # Get rest + ld E (E) # Consequent + eval/ret + end + ld (At) E + xchg X (S) # Get rest in X + ld X (X CDR) # Else + prog X + pop X + ret + +# (when 'any . prg) -> any +(code 'doWhen 2) + ld E (E CDR) + push (E CDR) # Push body + ld E (E) # Get condition + eval # Eval condition + cmp E Nil + if eq # NIL + pop A # Drop rest + ret + end + ld (At) E + xchg X (S) # Run body + prog X + pop X + ret + +# (unless 'any . prg) -> any +(code 'doUnless 2) + ld E (E CDR) + push (E CDR) # Push body + ld E (E) # Get condition + eval # Eval condition + cmp E Nil + if ne # NIL + ld (At) E + pop A # Drop rest + ld E Nil # Return NIL + ret + end + xchg X (S) # Run body + prog X + pop X + ret + +# (cond ('any1 . prg1) ('any2 . prg2) ..) -> any +(code 'doCond 2) + push X + ld X E # Clauses in X + do + ld X (X CDR) # Next clause + atom X # Any? + while z # Yes + ld E ((X)) # Eval CAR + eval + cmp E Nil + if ne # Non-NIL + ld (At) E + ld X ((X) CDR) # Run body + prog X + pop X + ret + end + loop + ld E Nil # Return NIL + pop X + ret + +# (nond ('any1 . prg1) ('any2 . prg2) ..) -> any +(code 'doNond 2) + push X + ld X E # Clauses in X + do + ld X (X CDR) # Next clause + atom X # Any? + while z # Yes + ld E ((X)) # Eval CAR + eval + cmp E Nil + if eq # NIL + ld X ((X) CDR) # Run body + prog X + pop X + ret + end + ld (At) E + loop + ld E Nil # Return NIL + pop X + ret + +# (case 'any (any1 . prg1) (any2 . prg2) ..) -> any +(code 'doCase 2) + push X + ld X (E CDR) # Arguments in X + ld E (X) # Eval argument item + eval + ld (At) E + do + ld X (X CDR) # Next clause + atom X # Any? + while z # Yes + ld C ((X)) # Item(s) in C + cmp C TSym # Catch-all? + jz 10 # Yes + ld A (At) # Equal to argument item? + ld E C + call equalAE_F + if eq # Yes +10 ld X ((X) CDR) # Run body + prog X + pop X + ret + end + atom C # List of items? + if z # Yes + do + ld A (At) # Argument item member? + ld E (C) + call equalAE_F + if eq # Yes + ld X ((X) CDR) # Run body + prog X + pop X + ret + end + ld C (C CDR) # End of list? + atom C + until nz # Yes + end + loop + ld E Nil # Return NIL + pop X + ret + +# (state 'var (sym|lst exe [. prg]) ..) -> any +(code 'doState 2) + push X + push Y + ld X E + ld Y (E CDR) # Y on args + ld E (Y) # Eval 'var' + eval + link + push E # <L I> 'var' + link + call needVarEX # Need variable + do + ld Y (Y CDR) # Next clause + atom Y # Any? + while z # Yes + ld X (Y) # Get clause in X + ld E (X) # Get sym|lst in E + cmp E TSym # T? + jz 10 # Yes + ld A ((L I)) # 'var's value + cmp A E # Same? + jz 10 # Yes + do # 'memq' + atom E # List? + while z # Yes + cmp A (E) # Member? + while ne # No + ld E (E CDR) + loop + if eq # Yes +10 ld X (X CDR) # Eval 'exe' + ld E (X) + eval + cmp E Nil + if ne # Non-NIL + ld ((L I)) E # Set target state + ld (At) E + drop + ld X (X CDR) # Get body in X + pop Y + prog X # Run body + pop X + ret + end + end + loop + drop + pop Y + pop X + ret + +# (while 'any . prg) -> any +(code 'doWhile 2) + push X + push Y + ld X (E CDR) # X arguments + link + push Nil # <L I> Result + link + do + ld E (X) # Eval condition + eval + cmp E Nil + while ne # Non-NIL + ld (At) E + ld Y (X CDR) # Run body + prog Y + ld (L I) E # Save result + loop + ld E (L I) # Get result + drop + pop Y + pop X + ret + +# (until 'any . prg) -> any +(code 'doUntil 2) + push X + push Y + ld X (E CDR) # X arguments + link + push Nil # <L I> Result + link + do + ld E (X) # Eval condition + eval + cmp E Nil + while eq # NIL + ld Y (X CDR) # Run body + prog Y + ld (L I) E # Save result + loop + ld (At) E + ld E (L I) # Get result + drop + pop Y + pop X + ret + +# (at '(cnt1 . cnt2) . prg) -> any +(code 'doAt 2) + push X + push Y + ld X E + ld Y (E CDR) # Y on args + ld E (Y) # Eval first + eval + atom E # Need cell + jnz cellErrEX + ld A (E) # Get 'cnt1' + cnt A # Need short + jz cntErrAX + ld C (E CDR) # Get 'cnt2' + cnt C # Need short + jz cntErrCX + add A (hex "10") # Increment + cmp A C # Reached count? + if lt # No + ld (E) A + ld E Nil + else + ld (E) ZERO + ld Y (Y CDR) # Run body + prog Y + end + pop Y + pop X + ret + +# (do 'flg|cnt ['any | (NIL 'any . prg) | (T 'any . prg) ..]) -> any +(code 'doDo 2) + push X + push Y + push Z + ld X (E CDR) # Args + ld E (X) # Eval 'flg|cnt' + ld X (X CDR) # Body + eval + cmp E Nil # Ever? + if ne # Yes + cnt E # Short number? + jz loopX # No: Non-NIL 'flg' + shr E 4 # Normalize + if gt # Greater zero + push E # <S> Count + do + ld Y X # Loop body + call loopY_FE + while nz + sub (S) 1 # Decrement count + until z + pop A # Drop count + else + ld E Nil # Return NIL if zero + end + end + pop Z + pop Y + pop X + ret + +# (loop ['any | (NIL 'any . prg) | (T 'any . prg) ..]) -> any +(code 'doLoop 2) + push X + push Y + push Z + ld X (E CDR) # Body +: loopX + do + ld Y X # Body in Y + do + ld E (Y) # Next expression + atom E # Cell? + if z # Yes + ld A (E) # Get CAR + cmp A Nil # NIL? + if eq # Yes + ld Z (E CDR) # Sub-body in Z + ld E (Z) + eval # Evaluate condition + cmp E Nil # NIL? + if eq # Yes + ld Y (Z CDR) # Run sub-body + prog Y + pop Z + pop Y + pop X + ret + end + ld (At) E + else + cmp A TSym # T? + if eq # Yes + ld Z (E CDR) # Sub-body in Z + ld E (Z) + eval # Evaluate condition + cmp E Nil # NIL? + if ne # No + ld (At) E + ld Y (Z CDR) # Run sub-body + prog Y + pop Z + pop Y + pop X + ret + end + else + call evListE_E # Else evaluate expression + end + end + end + ld Y (Y CDR) + atom Y # Finished one pass? + until nz # Yes + loop + +# (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 +(code 'doFor 2) + push X + push Y + push Z + ld X (E CDR) # X on args + ld Y (X) # Y on first arg + ld X (X CDR) + push (EnvBind) # Build bind frame + link + atom Y # 'sym'? + if nz # Yes + # (for sym 'cnt|lst ..) + push (Y) # Save old value + push Y # <L V> and 'sym' + link + ld (EnvBind) L # Close bind frame + push 0 # Init env swap + ld E (X) # Eval 'cnt|lst' + eval + link + push E # <L I> 'cnt|lst' + link + ld X (X CDR) # X on body + ld A E + ld E Nil # Preload NIL + num A # Number? + if nz # Yes + test A SIGN # Negative? + if z # No + ld (Y) ZERO # Init 'sym' to zero + do + ld A ((L V)) # Get value of 'sym' + add A (hex "10") # Increment + cmp A (L I) # Greater than 'num'? + while le # No + ld ((L V)) A # Set incremented value of 'sym' + ld Y X # Loop body + call loopY_FE + until z + end + else + do + ld A (L I) # Get 'lst' + atom A # Any? + while z # Yes + ld (L I) (A CDR) + ld ((L V)) (A) # Set value + ld Y X # Loop body + call loopY_FE + until z + end + drop + pop A # Drop env swap + pop L # Get link + else + ld Z (Y CDR) # CDR of first arg + atom Z # 'sym'? + if nz # Yes + # (for (sym2 . sym) 'lst ..) + push (Z) # Value of 'sym' + push Z # <L VII> 'sym' + ld Z (Y) + push (Z) # Value of 'sym2' + push Z # <L V> 'sym2' + link + ld (EnvBind) L # Close bind frame + push 0 # Init env swap + ld E (X) # Eval 'lst' + eval + link + push E # <L I> 'lst' + link + ld (Z) ZERO # Init 'sym2' to zero + ld X (X CDR) # X on body + do + ld A (L I) # Get 'lst' + atom A # Any? + while z # Yes + ld (L I) (A CDR) + ld ((L VII)) (A) # Set value of 'sym' + add ((L V)) (hex "10") # Increment 'sym2' + ld Y X # Loop body + call loopY_FE + until z + drop + pop A # Drop env swap + pop L # Get link + pop X # Unbind 'sym2' + pop (X) # Restore value + else + ld Z (Y) # CAR of first arg + ld Y (Y CDR) + atom Z # 'sym'? + if nz # Yes + # (for (sym ..) ..) + push (Z) # Save old value + push Z # <L V> and 'sym' + link + ld (EnvBind) L # Close bind frame + push 0 # Init env swap + ld E (Y) # Eval 'any1' init-expression + eval + ld (Z) E # Set new value + link + push Nil # <L I> Result + link + push (Y CDR) # <S> (any2 . prg) + do + ld E ((S)) # Evaluate condition + eval + cmp E Nil # NIL? + if eq # Yes + ld E (L I) # Get result + break T + end + ld (At) E + ld Y X # Loop body + call loopY_FE + while nz + ld (L I) E # Keep result + ld Y ((S) CDR) # 'prg' re-init? + atom Y + if z # Yes + prog Y + ld ((L V)) E # Set new value + end + loop + drop + pop A # Drop env swap + pop L # Get link + else + # (for ((sym2 . sym) ..) ..) + ld C (Z CDR) # 'sym' + push (C) # Save old value + push C # <L VII> and 'sym' + ld C (Z) # 'sym2' + push (C) # Value of 'sym2' + push C # <L V> and 'sym2' + link + ld (EnvBind) L # Close bind frame + push 0 # Init env swap + ld E (Y) # Eval 'any1' init-expression + eval + ld ((Z CDR)) E # Set new value of 'sym' + ld ((Z)) ZERO # Init 'sym2' to zero + link + push Nil # <L I> Result + link + push (Y CDR) # <S> (any2 . prg) + do + ld E ((S)) # Evaluate condition + eval + cmp E Nil # NIL? + if eq # Yes + ld E (L I) # Get result + break T + end + ld (At) E + add ((L V)) (hex "10") # Increment 'sym2' + ld Y X # Loop body + call loopY_FE + while nz + ld (L I) E # Keep result + ld Y ((S) CDR) # 'prg' re-init? + atom Y + if z # Yes + prog Y + ld ((L VII)) E # Set new value + end + loop + drop + pop A # Drop env swap + pop L # Get link + pop X # Unbind 'sym2' + pop (X) # Restore value + end + end + end + pop X # Unbind 'sym' + pop (X) # Restore value + pop L # Restore link + pop (EnvBind) # Restore bind link + pop Z + pop Y + pop X + ret + +(code 'loopY_FE 0) # Z + do + ld E (Y) # Next expression + num E # Number? + if z # No + sym E # Symbol? + if nz # Yes + ld E (E) # Get value + else + ld A (E) # Else get CAR + cmp A Nil # NIL? + if eq # Yes + ld Z (E CDR) # Sub-body in Z + ld E (Z) + eval # Evaluate condition + cmp E Nil # NIL? + if eq # Yes + ld Y (Z CDR) # Run sub-body + prog Y + setz # Return 'z' + ret + end + ld (At) E + ld E Nil + else + cmp A TSym # T? + if eq # Yes + ld Z (E CDR) # Sub-body in Z + ld E (Z) + eval # Evaluate condition + cmp E Nil # NIL? + if ne # No + ld (At) E + ld Y (Z CDR) # Run sub-body + prog Y + setz # Return 'z' + ret + end + else + call evListE_E # Else evaluate expression + end + end + end + end + ld Y (Y CDR) + atom Y # Done? + until nz # Yes + ret # Return 'nz' + +# (catch 'any . prg) -> any +(code 'doCatch 2) + push X + push Y + push Z + push L + ld X (E CDR) + ld E (X) # Get tag + ld X (X CDR) # X on body + eval # Evaluate tag + sub S "(EnvEnd-Env)" # Build catch frame + movn (S) (Env) "(EnvEnd-Env)" # Save environment + push ZERO # 'fin' + push E # 'tag' + push (Catch) # Link + ld (Catch) S # Close catch frame + prog X # Run body +: caught + pop (Catch) # Restore catch link + add S "(EnvEnd-Env)+8+8" # Clean up + pop L + pop Z + pop Y + pop X + ret + +# (throw 'sym 'any) +(code 'doThrow 2) + ld X E + ld Y (X CDR) + ld E (Y) # Get sym + ld Y (Y CDR) + eval # Evaluate tag + ld Z E # into Z + ld E (Y) # Get value + eval # Keep thrown value in E + ld C (Catch) # Search catch frames + do + null C # Any? + jz throwErrZX # No + cmp (C I) TSym # Catch-all? + while nz # No + cmp Z (C I) # Found tag? + while nz # No + ld C (C) # Next frame + loop + push E # Save thrown value + call unwindC_Z # Unwind environments + pop E + ld S Z # Restore stack + jmp caught # Return E + +(code 'throwErrZX) + ld E Z + ld Y ThrowErr + jmp errEXYZ +: ThrowErr asciz "Tag not found" + +# (finally exe . prg) -> any +(code 'doFinally 2) + push X + sub S "(EnvEnd-Env)" # Build catch frame + movn (S) (Env) "(EnvEnd-Env)" # Save environment + ld X (E CDR) + push (X) # 'exe' -> 'fin' + ld X (X CDR) + push 0 # 'tag' + push (Catch) # Link + ld (Catch) S # Close catch frame + prog X # Run body + link + push E # <L I> Result + link + ld E (S V) # Get 'fin' + eval # Evaluate it + ld E (L I) # Get result + drop + pop (Catch) # Restore catch link + add S "(EnvEnd-Env)+8+8" # Clean up + pop X + ret + +# (! . exe) -> any +(code 'doBreak 2) + ld E (E CDR) # exe + cmp (Dbg) Nil # Debug? + if ne # Yes + call brkLoadE_E # Enter debug breakpoint + end + eval/ret + +(code 'brkLoadE_E) + null (EnvBrk) # Already in breakpoint? + if z # No + cc isatty(0) # STDIN + nul4 # on a tty? + if nz # Yes + cc isatty(1) # STDOUT + nul4 # on a tty? + if nz # Yes + push X + push Y + push (EnvBind) # Build bind frame + link + push (Up) # <L VI> Bind '^' + push Up + ld (Up) E # to expression + push (Run) # <L IV> Bind '*Run' to NIL + push Run + ld (Run) Nil + push (At) # <L II> Save '@' + push At + link + ld (EnvBind) L # Close bind frame + ld (EnvBrk) L # Set break env + push 0 # Init env swap + sub S IV # <L -V> OutFrame + ld Y S + ld (Y I) 1 # fd = stdout + ld (Y II) 0 # pid = 0 + call pushOutFilesY + call printE # Print expression + call newline + ld B (char "!") # Prompt + ld E Nil # REPL + ld X 0 # Runtime expression + call loadBEX_E + call popOutFiles + add S (+ IV III) # Drop outFrame, env swap, bind link and '@' + pop (At) # Restore '@' + pop A + pop (Run) # '*Run' + pop A + ld E (Up) # runtime expression + pop (Up) # and '^' + pop L # Restore link + pop (EnvBind) # Restore bind link + ld (EnvBrk) 0 # Leave breakpoint + pop Y + pop X + end + end + end + ret + +# (e . prg) -> any +(code 'doE 2) + push X + push Y + ld X E + null (EnvBrk) # Breakpoint? + jz brkErrX # No + link + push (Dbg) # Save '*Dbg' + push (At) # '@' + push (Run) # and '*Run' + link + ld (Dbg) Nil # Switch off debug mode + ld C (EnvBrk) # Get break env + ld (At) (C II) # Set '@' + ld (Run) (C IV) # and '*Run' + call popOutFiles # Leave debug I/O env + ld Y (EnvInFrames) # Keep InFrames + call popInFiles + ld X (X CDR) # 'prg'? + atom X + if z # Yes + prog X + else + ld E (Up) # Get '^' + eval + end + call pushInFilesY # Restore debug I/O env + lea Y ((EnvBrk) -V) + call pushOutFilesY + pop L # Restore debug env + pop (Run) + pop (At) + pop (Dbg) + pop L + pop Y + pop X + ret + +# ($ sym|lst lst . prg) -> any +(code 'doTrace 2) + push X + ld X (E CDR) # Get args + cmp (Dbg) Nil # Debug? + if eq # No + ld X ((X CDR) CDR) # Get 'prg' + prog X # Run it + else + push Y + push Z + push (OutFile) # Save output channel + ld (OutFile) ((OutFiles) II) # Set to OutFiles[2] (stderr) + push (EnvPutB) # Save 'put' + ld (EnvPutB) putStdoutB # Set new + ld Y (X) # Get 'sym|lst' + ld X (X CDR) + ld Z (X CDR) # Get 'prg' + add (EnvTrace) 1 # Increment trace level + ld C (EnvTrace) # Get it + call traceCY # Print trace information + ld C trc1 # Print " :" + call outStringC + ld X (X) # Get 'lst' + do + atom X # List? + while z # Yes + call space + ld E (X) # Print value of CAR + ld E (E) + call printE + ld X (X CDR) + loop + cmp X Nil # Last CDR is NIL? + if ne # No + cmp X At # Variable arguments? + if ne # No + call space + ld E (X) # Print value + call printE + else + ld X (EnvNext) # VarArgs + do + cmp X (EnvArgs) # Any? + while ne # Yes + call space + sub X I # Next + ld E (X) # Next arg + call printE + loop + end + end + call newline + ld (EnvPutB) (S) # Restore 'put' + ld (OutFile) (S I) # and output channel + prog Z # Run 'prg' + ld (OutFile) ((OutFiles) II) # Set output channel again + ld (EnvPutB) putStdoutB + ld C (EnvTrace) # Get trace level + sub (EnvTrace) 1 # Decrement it + call traceCY # Print trace information + ld C trc2 # Print " = " + call outStringC + call printE_E # Print result + call newline + pop (EnvPutB) # Restore 'put' + pop (OutFile) # and output channel + pop Z + pop Y + end + pop X + ret +: trc1 asciz " :" +: trc2 asciz " = " + +(code 'traceCY) + cmp C 64 # Limit to 64 + if gt + ld C 64 + end + do + call space # Output spaces + sub C 1 # 'cnt' times + until sz + push E + atom Y # 'sym'? + if nz # Yes + ld E Y # Print symbol + call printE + else + ld E (Y) # Print method + call printE + call space + ld E (Y CDR) # Print class + call printE + call space + ld E (This) # Print 'This' + call printE + end + pop E + ret + +# (sys 'any ['any]) -> sym +(code 'doSys 2) + push X + push Z + ld X (E CDR) # X on args + call evSymX_E # Evaluate first symbol + call bufStringE_SZ # Write to stack buffer + ld X (X CDR) # Next arg? + atom X + if nz # No + cc getenv(S) # Get value from system + ld E A + call mkStrE_E # Make transient symbol + else + push Z + call evSymX_E # Evaluate second symbol + lea X (S I) # Keep pointer to first buffer + call bufStringE_SZ # Write to stack buffer + cc setenv(X S 1) # Set system value + nul4 # OK? + ldnz E Nil # No + ld S Z # Drop buffer + pop Z + end + ld S Z # Drop buffer + pop Z + pop X + ret + +# (call 'any ..) -> flg +(code 'doCall 2) + push X + push Z + ld X (E CDR) # X on args + push E # Save expression + push 0 # End-of-buffers marker + call evSymX_E # Pathname + call pathStringE_SZ # Write to stack buffer + do + ld X (X CDR) # Arguments? + atom X + while z # Yes + push Z # Buffer chain + call evSymX_E # Next argument + call bufStringE_SZ # Write to stack buffer + loop + push Z + ld Z S # Point to chain + ld X Z + push 0 # NULL terminator + do + lea A (X I) # Buffer pointer + push A # Push to vector + ld X (X) # Follow chain + null (X) # Done? + until z # Yes + ld X (X I) # Retrieve expression + call flushAll # Flush all output channels + cc fork() # Fork child process + nul4 # In child? + if z # Yes + cc setpgid(0 0) # Set process group + cc getpgrp() # Set terminal process group + cc tcsetpgrp(0 A) + cc execvp((S) S) # Execute program + jmp execErrS # Error if failed + end + js forkErrX + do + ld S Z # Clean up buffers + pop Z # Chain + null Z # End? + until z # Yes + ld Z A # Keep pid in Z + cc setpgid(Z 0) # Set process group + cc tcsetpgrp(0 Z) # Set terminal process group + do # Re-use expression stack entry + do + cc waitpid(Z S WUNTRACED) # Wait for child + nul4 # OK? + while s # No + call errno_A + cmp A EINTR # Interrupted? + jne waitPidErrX # No + nul (Signal) # Signal? + if nz # Yes + call sighandlerX + end + loop + cc getpgrp() # Set terminal process group + cc tcsetpgrp(0 A) + call wifstoppedS_F # WIFSTOPPED(S)? + if ne # No + ld4 (S) # Result? + or A A + ld E TSym # Return 'flg' + ldnz E Nil + pop X # Drop expression + pop Z + pop X + ret + end + ld B (char "+") # Prompt + ld E Nil # REPL + call loadBEX_E + cc tcsetpgrp(0 Z) # Set terminal process group + cc kill(Z SIGCONT) + loop + +# (tick (cnt1 . cnt2) . prg) -> any +(code 'doTick 2) + push X + push (TickU) # <S III> User ticks + push (TickS) # <S II> System ticks + cc times(Tms) # Get ticks + push (Tms TMS_UTIME) # <S I> User time + push (Tms TMS_STIME) # <S> User time + ld E (E CDR) + push (E) # Save pointer to count pair + ld X (E CDR) + prog X # Run 'prg' + pop X # Get count pair + cc times(Tms) # Get ticks again + ld A (Tms TMS_UTIME) # User time + sub A (S I) # Subtract previous user time + sub A (TickU) # Subtract user ticks + add A (S III) # Adjust by saved ticks + add (TickU) A # Save new user ticks + shl A 4 # Adjust to short number + add (X) A # Add to 'cnt1' + ld A (Tms TMS_STIME) # System time + sub A (S) # Subtract previous system time + sub A (TickS) # Subtract system ticks + add A (S II) # Adjust by saved ticks + add (TickS) A # Save new system ticks + shl A 4 # Adjust to short number + add (X CDR) A # Add to 'cnt2' + add S IV # Drop locals + pop X + ret + +# (ipid) -> pid | NIL +(code 'doIpid 2) + ld C (EnvInFrames) # OutFrames? + null C + if nz + ld E (C II) # 'pid' + cmp E 1 # 'pid' > 1? + if gt # Yes + shl E 4 # Make short number + or E CNT + ret + end + end + ld E Nil # Return NIL + ret + +# (opid) -> pid | NIL +(code 'doOpid 2) + ld C (EnvOutFrames) # OutFrames? + null C + if nz + ld E (C II) # 'pid' + cmp E 1 # 'pid' > 1? + if gt # Yes + shl E 4 # Make short number + or E CNT + ret + end + end + ld E Nil # Return NIL + ret + +# (kill 'pid ['cnt]) -> flg +(code 'doKill 2) + push X + push Y + ld X E + ld Y (E CDR) # Y on args + call evCntXY_FE # Eval 'pid' + ld Y (Y CDR) # Second arg? + atom Y + if nz # No + cc kill(E SIGTERM) # Send TERM signal + else + push E # Save signal number + call evCntXY_FE # Eval 'cnt' + cc kill(pop E) # Send signal + end + nul4 # OK? + ld E TSym # Yes + ldnz E Nil # No + pop Y + pop X + ret + +# (fork) -> pid | NIL +(code 'doFork 2) + push X + ld X E # Get expression + call forkLispX_FE # Fork child process + if c + ld E Nil # In child + else + shl E 4 # In parent + or E CNT # Return PID + end + pop X + ret + +(code 'forkLispX_FE 0) + call flushAll # Flush all output channels + null (Spkr) # Not listening for children yet? + if z # Yes + cc pipe(SpMiPipe) # Open speaker/microphone pipe + nul4 # OK? + jnz pipeErrX + ld4 (SpMiPipe) # Read end + ld (Spkr) A # into the speaker + call closeOnExecAX + ld4 (SpMiPipe 4) # Write end + call closeOnExecAX + end + push A # Create 'hear' and 'tell' pipes + push A + cc pipe(S) # Open 'hear' pipe + nul4 # OK? + jnz pipeErrX + cc pipe(&(S 8)) # Open 'tell' pipe + nul4 # OK? + jnz pipeErrX + ld4 (S) # Read end of 'hear' + call closeOnExecAX + ld4 (S 4) # Write end + call closeOnExecAX + ld4 (S 8) # Read end of 'tell' + call closeOnExecAX + ld4 (S 12) # Write end + call closeOnExecAX + ld C 0 # Index + ld A (Child) # Find a free child slot + do + cmp C (Children) # Tried all children? + while ne # No + null (A) # Found empty 'pid'? + while nz # No + add A VI # Increment by sizeof(child) + add C VI + loop + cc fork() # Fork child process + nul4 # In child? + js forkErrX + if z # Yes + ld (Slot) C # Set child index + ld (Spkr) 0 # No children yet + ld4 (SpMiPipe 4) # Set microphone to write end + ld (Mic) A + ld4 (S 4) # Close write end of 'hear' + call closeAX + ld4 (S 8) # Close read end of 'tell' + call closeAX + ld4 (SpMiPipe) # Close read end + call closeAX + ld A (Hear) # Already hearing? + null A + if nz # Yes + call closeAX # Close it + ld A (Hear) + call closeInFileA + ld A (Hear) + call closeOutFileA + end + ld4 (S) # Read end of 'hear' + ld (Hear) A + call initInFileA_A # Create input file + ld A (Tell) # Telling? + null A + if nz # Yes + call closeAX + end + ld4 (S 12) # Write end of 'tell' + ld (Tell) A + ld E (Child) # Iterate children + ld C (Children) # Count + do + sub C VI # More? + while ge # Yes + null (E) # 'pid'? + if nz # Yes + cc close((E I)) # Close 'hear' + cc close((E II)) # Close 'tell' + cc free((E V)) # Free buffer + end + add E VI # Increment by sizeof(child) + loop + ld (Children) 0 # No children + cc free((Child)) + ld (Child) 0 + ld A (EnvInFrames) # Clear pids in InFrames + do + null A # More frames? + while nz # Yes + ld (A II) 0 # Clear 'pid' + ld A (A) # Follow link + loop + ld A (EnvOutFrames) # Clear pids in OutFrames + do + null A # More frames? + while nz # Yes + ld (A II) 0 # Clear 'pid' + ld A (A) # Follow link + loop + ld A (Catch) # Clear 'finally' expressions in Catch frames + do + null A # More frames? + while nz # Yes + ld (A II) ZERO # Clear 'fin' + ld A (A) # Follow link + loop + cc free((Termio)) # Give up terminal control + ld (Termio) 0 + set (PRepl) (Repl) # Set parent REPL flag + ld (PPid) (Pid) # Set parent process ID + cc getpid() # Get new process ID + shl A 4 # Make short number + or A CNT + ld (Pid) A # Set new process ID + ld E (Fork) # Run '*Fork' + call execE + ld (Fork) Nil # Clear '*Fork' + pop A # Drop 'hear' and 'tell' pipes + pop A + setc # Return "in child" + ret + end + cmp C (Children) # Children table full? + ldnz E A # No: Get 'pid' into E + if eq # Yes + push A # Save child's 'pid' + ld A (Child) # Get vector + ld E C # Children + add E (* 8 VI) # Eight more slots + ld (Children) E + call allocAE_A # Extend vector + ld (Child) A + add A E # Point A to the end + ld E 8 # Init eight new slots + do + sub A VI # Decrement pointer + ld (A) 0 # Clear 'pid' + sub E 1 # Done? + until z # Yes + pop E # Get 'pid' + end + add C (Child) # Point C to free 'child' entry + ld (C) E # Set 'pid' + ld4 (S) # Close read end of 'hear' + call closeAX + ld4 (S 4) # Write end of 'hear' + ld (C II) A # Into 'tell' + call nonblockingA_A # Set to non-blocking + ld4 (S 8) # Read end of 'tell' + ld (C I) A # Into 'hear' + ld4 (S 12) # Close write end of 'tell' + call closeAX + ld (C III) 0 # Init buffer offset + ld (C IV) 0 # buffer count + ld (C V) 0 # No buffer yet + pop A # Drop 'hear' and 'tell' pipes + pop A + clrc # Return "in parent" + ret + +# (bye 'cnt|NIL) +(code 'doBye 2) + ld X E + ld E (E CDR) + ld E (E) + eval # Get exit code + cmp E Nil + if eq + ld E 0 # Zero if NIL + else + call xCntEX_FE + end + jmp byeE + +# vi:et:ts=3:sw=3 diff --git a/src64/gc.l b/src64/gc.l @@ -0,0 +1,1002 @@ +# 13oct09abu +# (c) Software Lab. Alexander Burger + +# Mark data +(code 'markE 0) + ld X 0 # Clear TOS + do + do + cnt E # Short number? + while z # No + ld A E # Get cell pointer in A + off A 15 + test (A CDR) 1 # Already marked? + while nz # No + off (A CDR) 1 # Mark cell + big E # Bigum? + if nz # Yes + ld C (A CDR) # Second digit + do + cnt C # Any? + while z # Yes + test (C BIG) 1 # Marked? + while nz # Yes + off (C BIG) 1 # Else mark it + ld C (C BIG) # Next digit + loop + break T + end + ld C E # Previous item + ld E (A) # Get CAR + or X 1 # First visit + ld (A) X # Keep TOS + ld X C # TOS on previous + loop + do + ld A X # TOS cell pointer in A + and A -16 # Empty? + jz ret # Yes + test (A) 1 # Second visit? + while z # Yes + ld C X # TMP + ld X (A CDR) # TOS up + ld (A CDR) E # Restore CDR + ld E C # E up + loop + ld C (A) # Up pointer + ld (A) E # Restore CAR + ld E (A CDR) # Get CDR + off C 1 # Set second visit + ld (A CDR) C # Store up pointer + loop + +# Reserve cells +(code 'needC 0) + ld A (Avail) # Get avail list + do + null A # Enough free cells? + jeq gc # No: Collect garbage + ld A (A) + sub C 1 + until z + ret + +# Garbage collector +(code 'gc 0) + push A # Save + push C + push E + push X + push Y + push Z + ld (DB) ZERO # Cut off DB root + ### Prepare all cells ### + ld X Nil # Symbol table + or (X) 1 # Set mark bit + add X 32 # Skip padding + do + or (X) 1 # Set mark bit + add X II # Next symbol + cmp X GcMarkEnd + until gt + ld X (Heaps) # Heap pointer + do + ld C CELLS + do + or (X CDR) 1 # Set mark bit + add X II # Next cell + sub C 1 # Done? + until z # Yes + ld X (X) # Next heap + null X # Done? + until eq # Yes + ### Mark ### + ld E (Alarm) # Mark globals + call markE + ld E (LineX) + call markE + ld E (Intern) # Mark internal symbols + call markE + ld E (Intern I) + call markE + ld E (Transient) # Mark transient symbols + call markE + ld E (Transient I) + call markE + ### Mark stack ### + ld Y L + do + null Y # End of stack? + while ne # No + ld Z (Y) # Keep end of frame in Z + do + add Y I # End of frame? + cmp Y Z + while ne # No + ld E (Y) # Next item + call markE # Mark it + loop + ld Y (Y) # Next frame + loop + ld Y (Catch) # Catch frames + do + null Y # Any? + while ne # Yes + ld E (Y I) # Mark 'tag' + null E # Any? + if ne + call markE # Yes + end + ld E (Y II) # Mark 'fin' + call markE + ld Y (Y) # Next frame + loop + ld Y (EnvMeth) # Method frames + do + null Y # Any? + while ne # Yes + ld E (Y I) # Mark 'key' + call markE + ld E (Y II) # Mark 'cls' + call markE + ld Y (Y) # Next frame + loop + # Mark externals + ld Y Extern + ld Z 0 # Clear TOS + do + do + off (Y CDR) 1 # Clear mark bit + ld A (Y CDR) # Get subtrees + off (A CDR) 1 # Clear mark bit + atom (A CDR) # Right subtree? + while z # Yes + ld C Y # Go right + ld Y (A CDR) # Invert tree + ld (A CDR) Z # TOS + ld Z C + loop + do + ld E (Y) # Get external symbol + test (E) 1 # Already marked? + if nz # No + ld A (E TAIL) + num A # Any properties? + if z # Yes + off A (| SYM 1) # Clear 'extern' tag and mark bit + do + ld A (A CDR) # Skip property + off A 1 # Clear mark bit + num A # Find name + until nz + end + rcl A 1 # Dirty or deleted? + if c # Yes + call markE # Mark external symbol + end + end + ld A (Y CDR) # Left subtree? + atom (A) + if z # Yes + ld C Y # Go left + ld Y (A) # Invert tree + ld (A) Z # TOS + or C SYM # First visit + ld Z C + break T + end + do + ld A Z # TOS + null A # Empty? + jeq 10 # Done + sym A # Second visit? + if z # Yes + ld C (A CDR) # Nodes + ld Z (C CDR) # TOS on up link + ld (C CDR) Y + ld Y A + break T + end + off A SYM # Set second visit + ld C (A CDR) # Nodes + ld Z (C) + ld (C) Y + ld Y A + loop + loop + loop +10 ld A Db1 # DB root object + ld (DB) A # Restore '*DB' + test (A) 1 # Marked? + if nz # No + ld (A) Nil # Clear + ld (A TAIL) DB1 # Set to "not loaded" + end + ld Y Extern # Clean up + ld Z 0 # Clear TOS +20 do + do + ld A (Y CDR) + atom (A CDR) # Right subtree? + while z # Yes + ld C Y # Go right + ld Y (A CDR) # Invert tree + ld (A CDR) Z # TOS + ld Z C + loop + do + test ((Y)) 1 # External symbol marked? + if nz # No: Remove it + ld A (Y CDR) # Get subtrees + atom A # Any? + if nz # No + or (Y CDR) 1 # Set mark bit again + ld Y A # Use NIL + jmp 40 # Already traversed + end + atom (A) # Left branch? + if nz # No + or (Y CDR) 1 # Set mark bit again + ld Y (A CDR) # Use right branch + jmp 40 # Already traversed + end + atom (A CDR) # Right branch? + if nz # No + or (Y CDR) 1 # Set mark bit again + ld Y (A) # Use left branch + jmp 20 + end + ld A (A CDR) # A on right branch + ld X (A CDR) # X on sub-branches + atom (X) # Left? + if nz # No + ld (Y) (A) # Insert right sub-branch + ld ((Y CDR) CDR) (X CDR) + jmp 30 # Traverse left branch + end + ld X (X) # Left sub-branch + do + ld C (X CDR) # More left branches? + atom (C) + while z # Yes + ld A X # Go down left + ld X (C) + loop + ld (Y) (X) # Insert left sub-branch + ld ((A CDR)) (C CDR) + end +30 ld A (Y CDR) # Left subtree? + atom (A) + if z # Yes + ld C Y # Go left + ld Y (A) # Invert tree + ld (A) Z # TOS + or C SYM # First visit + ld Z C + break T + end +40 do + ld A Z # TOS + null A # Empty? + jeq 50 # Done + sym A # Second visit? + if z # Yes + ld C (A CDR) # Nodes + ld Z (C CDR) # TOS on up link + ld (C CDR) Y + ld Y A + break T + end + off A SYM # Set second visit + ld C (A CDR) # Nodes + ld Z (C) + ld (C) Y + ld Y A + loop + loop + loop +50 ### Clean up ### + ld Y (EnvApply) # Apply stack + do + null Y # End of stack? + while ne # No + ld Z (Y) # Keep end of frame in Z + add Y II + do + off (Y) 1 # Clear + add Y II # Next gc mark + cmp Y Z # End of frame? + until ge # Yes + ld Y (Z) # Next frame + loop + ### Sweep ### + ld X 0 # Avail list + ld Y (Heaps) # Heap list in Y + ld C (GcCount) # Get cell count + null C + if ne # Non-zero: + do + lea Z (Y (- HEAP II)) # Z on last cell in chunk + do + test (Z CDR) 1 # Free cell? + if nz # Yes + ld (Z) X # Link avail + ld X Z + sub C 1 + end + sub Z II + cmp Z Y # Done? + until lt # Yes + ld Y (Y HEAP) # Next heap + null Y + until eq # All heaps done + ld (Avail) X # Set new Avail + do + null C # Count minimum reached? + while ns # No + call heapAlloc # Allocate heap + sub C CELLS + loop + else # Zero: Try to free heaps + ld E Heaps # Heap list link pointer in E + do + ld A (Avail) # Keep avail list + ld C CELLS # Counter + lea Z (Y (- HEAP II)) # Z on last cell in chunk + do + test (Z CDR) 1 # Free cell? + if nz # Yes + ld (Z) X # Link avail + ld X Z + sub C 1 + end + sub Z II + cmp Z Y # Done? + until lt # Yes + null C # Remaining cells? + if nz # Yes + lea E (Y HEAP) # Point to link of next heap + ld Y (E) # Next heap + else + ld (Avail) A # Reset avail list + ld Y (Y HEAP) # Next heap + cc free((E)) # Free empty heap + ld (E) Y # Store next heap in list link + end + null Y # Next heap? + until z # No + end + pop Z + pop Y + pop X + pop E + pop C + pop A + ret + +# (gc ['cnt]) -> cnt | NIL +(code 'doGc 2) + push X + ld X E + ld E (E CDR) # Get arg + ld E (E) + eval # Eval + cmp E Nil # Nil? + if eq # Yes + call gc # Collect with default + else + ld X E # Save return value in X + call xCntEX_FE # Else get number of megabytes + shl E 16 # Multiply with CELLS + ld C (GcCount) # Save default + ld (GcCount) E # Set new value + call gc # Collect with given count + ld (GcCount) C # Restore default + ld E X + end + pop X + ret + +### Build cons cells ### +(code 'cons_A 0) + ld A (Avail) # Get avail list + null A # Empty? + if ne # No + ld (Avail) (A) # Set new avail list + ret + end + call gc # Collect garbage + ld A (Avail) # Get avail list again + ld (Avail) (A) # Set new avail list + ret + +(code 'cons_C 0) + ld C (Avail) # Get avail list + null C # Empty? + if ne # No + ld (Avail) (C) # Set new avail list + ret + end + call gc # Collect garbage + ld C (Avail) # Get avail list again + ld (Avail) (C) # Set new avail list + ret + +(code 'cons_E 0) + ld E (Avail) # Get avail list + null E # Empty? + if ne # No + ld (Avail) (E) # Set new avail list + ret + end + call gc # Collect garbage + ld E (Avail) # Get avail list again + ld (Avail) (E) # Set new avail list + ret + +(code 'cons_X 0) + ld X (Avail) # Get avail list + null X # Empty? + if ne # No + ld (Avail) (X) # Set new avail list + ret + end + call gc # Collect garbage + ld X (Avail) # Get avail list again + ld (Avail) (X) # Set new avail list + ret + +(code 'cons_Y 0) + ld Y (Avail) # Get avail list + null Y # Empty? + if ne # No + ld (Avail) (Y) # Set new avail list + ret + end + call gc # Collect garbage + ld Y (Avail) # Get avail list again + ld (Avail) (Y) # Set new avail list + ret + +(code 'cons_Z 0) + ld Z (Avail) # Get avail list + null Z # Empty? + if ne # No + ld (Avail) (Z) # Set new avail list + ret + end + call gc # Collect garbage + ld Z (Avail) # Get avail list again + ld (Avail) (Z) # Set new avail list + ret + +(code 'consA_A 0) + null (Avail) # Avail list empty? + if ne # No + ld A (Avail) # Get avail list + ld (Avail) (A) # Set new avail list + ret + end + link # Save A + push A + link + call gc # Collect garbage + drop + ld A (Avail) # Get avail list + ld (Avail) (A) # Set new avail list + ret + +(code 'consC_A 0) + ld A (Avail) # Get avail list + null A # Empty? + if ne # No + ld (Avail) (A) # Set new avail list + ret + end + link # Save C + push C + link + call gc # Collect garbage + drop + ld A (Avail) # Get avail list again + ld (Avail) (A) # Set new avail list + ret + +(code 'consE_A 0) + ld A (Avail) # Get avail list + null A # Empty? + if ne # No + ld (Avail) (A) # Set new avail list + ret + end + link # Save E + push E + link + call gc # Collect garbage + drop + ld A (Avail) # Get avail list again + ld (Avail) (A) # Set new avail list + ret + +(code 'consX_A 0) + ld A (Avail) # Get avail list + null A # Empty? + if ne # No + ld (Avail) (A) # Set new avail list + ret + end + link # Save X + push X + link + call gc # Collect garbage + drop + ld A (Avail) # Get avail list again + ld (Avail) (A) # Set new avail list + ret + +(code 'consA_C 0) + ld C (Avail) # Get avail list + null C # Empty? + if ne # No + ld (Avail) (C) # Set new avail list + ret + end + link # Save A + push A + link + call gc # Collect garbage + drop + ld C (Avail) # Get avail list again + ld (Avail) (C) # Set new avail list + ret + +(code 'consC_C 0) + null (Avail) # Avail list empty? + if ne # No + ld C (Avail) # Get avail list + ld (Avail) (C) # Set new avail list + ret + end + link # Save C + push C + link + call gc # Collect garbage + drop + ld C (Avail) # Get avail list + ld (Avail) (C) # Set new avail list + ret + +(code 'consE_C 0) + ld C (Avail) # Get avail list + null C # Empty? + if ne # No + ld (Avail) (C) # Set new avail list + ret + end + link # Save E + push E + link + call gc # Collect garbage + drop + ld C (Avail) # Get avail list again + ld (Avail) (C) # Set new avail list + ret + +(code 'consA_E 0) + ld E (Avail) # Get avail list + null E # Empty? + if ne # No + ld (Avail) (E) # Set new avail list + ret + end + link # Save A + push A + link + call gc # Collect garbage + drop + ld E (Avail) # Get avail list again + ld (Avail) (E) # Set new avail list + ret + +(code 'consC_E 0) + ld E (Avail) # Get avail list + null E # Empty? + if ne # No + ld (Avail) (E) # Set new avail list + ret + end + link # Save C + push C + link + call gc # Collect garbage + drop + ld E (Avail) # Get avail list again + ld (Avail) (E) # Set new avail list + ret + +(code 'consE_E 0) + null (Avail) # Avail list empty? + if ne # No + ld E (Avail) # Get avail list + ld (Avail) (E) # Set new avail list + ret + end + link # Save E + push E + link + call gc # Collect garbage + drop + ld E (Avail) # Get avail list + ld (Avail) (E) # Set new avail list + ret + +(code 'consX_E 0) + ld E (Avail) # Get avail list + null E # Empty? + if ne # No + ld (Avail) (E) # Set new avail list + ret + end + link # Save X + push X + link + call gc # Collect garbage + drop + ld E (Avail) # Get avail list again + ld (Avail) (E) # Set new avail list + ret + +(code 'consA_X 0) + ld X (Avail) # Get avail list + null X # Empty? + if ne # No + ld (Avail) (X) # Set new avail list + ret + end + link # Save A + push A + link + call gc # Collect garbage + drop + ld X (Avail) # Get avail list again + ld (Avail) (X) # Set new avail list + ret + +(code 'consE_X 0) + ld X (Avail) # Get avail list + null X # Empty? + if ne # No + ld (Avail) (X) # Set new avail list + ret + end + link # Save E + push E + link + call gc # Collect garbage + drop + ld X (Avail) # Get avail list again + ld (Avail) (X) # Set new avail list + ret + +(code 'consY_X 0) + ld X (Avail) # Get avail list + null X # Empty? + if ne # No + ld (Avail) (X) # Set new avail list + ret + end + link # Save Y + push Y + link + call gc # Collect garbage + drop + ld X (Avail) # Get avail list again + ld (Avail) (X) # Set new avail list + ret + +(code 'consA_Y 0) + ld Y (Avail) # Get avail list + null Y # Empty? + if ne # No + ld (Avail) (Y) # Set new avail list + ret + end + link # Save A + push A + link + call gc # Collect garbage + drop + ld Y (Avail) # Get avail list again + ld (Avail) (Y) # Set new avail list + ret + +(code 'consA_Z 0) + ld Z (Avail) # Get avail list + null Z # Empty? + if ne # No + ld (Avail) (Z) # Set new avail list + ret + end + link # Save A + push A + link + call gc # Collect garbage + drop + ld Z (Avail) # Get avail list again + ld (Avail) (Z) # Set new avail list + ret + +(code 'consAC_E 0) + ld E (Avail) # Get avail list + null E # Empty? + if ne # No + ld (Avail) (E) # Set new avail list + ret + end + link # Save A and C + push A + push C + link + call gc # Collect garbage + drop + ld E (Avail) # Get avail list again + ld (Avail) (E) # Set new avail list + ret + +### Build symbol cells ### +(code 'consSymX_E 0) + cmp X ZERO # Name? + jeq retNil # No + ld E (Avail) # Get avail list + null E # Empty? + if eq # Yes + link # Save name + push X + link + call gc # Collect garbage + drop + ld E (Avail) # Get avail list again + end + ld (Avail) (E) # Set new avail list + ld (E) X # Set new symbol's name + or E SYM # Make symbol + ld (E) E # Set value to itself + ret + +### Build number cells ### +(code 'boxNum_A 0) + ld A (Avail) # Get avail list + null A # Empty? + if eq # Yes + call gc # Collect garbage + ld A (Avail) # Get avail list again + end + ld (Avail) (A) # Set new avail list + ld (A CDR) ZERO # Set CDR to ZERO + or B BIG # Make number + ret + +(code 'boxNum_C 0) + ld C (Avail) # Get avail list + null C # Empty? + if eq # Yes + call gc # Collect garbage + ld C (Avail) # Get avail list again + end + ld (Avail) (C) # Set new avail list + ld (C CDR) ZERO # Set CDR to ZERO + or C BIG # Make number + ret + +(code 'boxNum_E 0) + ld E (Avail) # Get avail list + null E # Empty? + if eq # Yes + call gc # Collect garbage + ld E (Avail) # Get avail list again + end + ld (Avail) (E) # Set new avail list + ld (E CDR) ZERO # Set CDR to ZERO + or E BIG # Make number + ret + +(code 'boxNum_X 0) + ld X (Avail) # Get avail list + null X # Empty? + if eq # Yes + call gc # Collect garbage + ld X (Avail) # Get avail list again + end + ld (Avail) (X) # Set new avail list + ld (X CDR) ZERO # Set CDR to ZERO + or X BIG # Make number + ret + +(code 'boxNumA_A 0) + push A + ld A (Avail) # Get avail list + null A # Empty? + if eq # Yes + call gc # Collect garbage + ld A (Avail) # Get avail list again + end + ld (Avail) (A) # Set new avail list + pop (A) # Set new cell's CAR + ld (A CDR) ZERO # Set CDR to ZERO + or B BIG # Make number + ret + +(code 'boxNumE_E 0) + push E + ld E (Avail) # Get avail list + null E # Empty? + if eq # Yes + call gc # Collect garbage + ld E (Avail) # Get avail list again + end + ld (Avail) (E) # Set new avail list + pop (E) # Set new cell's CAR + ld (E CDR) ZERO # Set CDR to ZERO + or E BIG # Make number + ret + +(code 'consNumAC_A 0) + push A + ld A (Avail) # Get avail list + null A # Empty? + if eq # Yes + link # Save C + push C + link + call gc # Collect garbage + drop + ld A (Avail) # Get avail list again + end + ld (Avail) (A) # Set new avail list + pop (A) # Set new cell's CAR + ld (A CDR) C # Set CDR + or B BIG # Make number + ret + +(code 'consNumAE_A 0) + push A + ld A (Avail) # Get avail list + null A # Empty? + if eq # Yes + link # Save E + push E + link + call gc # Collect garbage + drop + ld A (Avail) # Get avail list again + end + ld (Avail) (A) # Set new avail list + pop (A) # Set new cell's CAR + ld (A CDR) E # Set CDR + or B BIG # Make number + ret + +(code 'consNumCA_C 0) + push C + ld C (Avail) # Get avail list + null C # Empty? + if eq # Yes + link # Save A + push A + link + call gc # Collect garbage + drop + ld C (Avail) # Get avail list again + end + ld (Avail) (C) # Set new avail list + pop (C) # Set new cell's CAR + ld (C CDR) A # Set CDR + or C BIG # Make number + ret + +(code 'consNumCE_A 0) + ld A (Avail) # Get avail list + null A # Empty? + if eq # Yes + link # Save E + push E + link + call gc # Collect garbage + drop + ld A (Avail) # Get avail list again + end + ld (Avail) (A) # Set new avail list + ld (A) C # Set new cell's CAR + ld (A CDR) E # Set CDR + or B BIG # Make number + ret + +(code 'consNumCE_C 0) + push C + ld C (Avail) # Get avail list + null C # Empty? + if eq # Yes + link # Save E + push E + link + call gc # Collect garbage + drop + ld C (Avail) # Get avail list again + end + ld (Avail) (C) # Set new avail list + pop (C) # Set new cell's CAR + ld (C CDR) E # Set CDR + or C BIG # Make number + ret + +(code 'consNumCE_E 0) + null (Avail) # Avail list empty? + if eq # Yes + link # Save E + push E + link + call gc # Collect garbage + drop + end + push E + ld E (Avail) # Get avail list + ld (Avail) (E) # Set new avail list + ld (E) C # Set new cell's CAR + pop (E CDR) # Set CDR + or E BIG # Make number + ret + +(code 'consNumEA_A 0) + null (Avail) # Avail list empty? + if eq # Yes + link # Save A + push A + link + call gc # Collect garbage + drop + end + push A + ld A (Avail) # Get avail list + ld (Avail) (A) # Set new avail list + ld (A) E # Set new cell's CAR + pop (A CDR) # Set CDR + or B BIG # Make number + ret + +(code 'consNumEA_E 0) + push E + ld E (Avail) # Get avail list + null E # Empty? + if eq # Yes + link # Save A + push A + link + call gc # Collect garbage + drop + ld E (Avail) # Get avail list again + end + ld (Avail) (E) # Set new avail list + pop (E) # Set new cell's CAR + ld (E CDR) A # Set CDR + or E BIG # Make number + ret + +(code 'consNumEC_E 0) + push E + ld E (Avail) # Get avail list + null E # Empty? + if eq # Yes + link # Save C + push C + link + call gc # Collect garbage + drop + ld E (Avail) # Get avail list again + end + ld (Avail) (E) # Set new avail list + pop (E) # Set new cell's CAR + ld (E CDR) C # Set CDR + or E BIG # Make number + ret + +# vi:et:ts=3:sw=3 diff --git a/src64/glob.l b/src64/glob.l @@ -0,0 +1,1078 @@ +# 17mar10abu +# (c) Software Lab. Alexander Burger + +(data 'Globals 0) +:: AV word 0 # Command line argument vector +:: AV0 word 0 # Command name +:: Home word 0 # Home directory +:: Heaps word 0 # Heap list +:: Avail word 0 # Avail list +:: Chr word 0 # Single-char buffer +:: EnvPutB word 0 # Character output function +:: EnvGet_A word 0 # Character input function +:: InFile word 0 # Input file +:: OutFile word 0 # Output file +:: Buf word 0 # General 16-byte buffer + word 0 + +: Stack0 word 0 # Initial stack pointer +: Catch word 0 # Catch frames +: Termio word 0 # Raw mode terminal I/O +: Time word 0 # Pointer to time structure +: USec word 0 # Startup microseconds +: TtyPid word 0 # Terminal process ID +: InFDs word 0 # Scaled number of input files +: InFiles word 0 # Input files +: OutFDs word 0 # Scaled number of output files +: OutFiles word 0 # Output files +: PutBinBZ word 0 # Binary output function +: GetBinZ_FB word 0 # Binary input function +: Seed word 0 # Random seed low + word 0 # Random seed high +: TickU word 0 # Ticks in user time +: TickS word 0 # Ticks in system time +: Slot word 0 # Child index +: Spkr word 0 # RPC loadspeaker +: Mic word 0 # RPC microphone +: SpMiPipe word 0 # Speaker/microphone pipe +: Hear word 0 # RPC listener +: Tell word 0 # RPC broadcaster +: TellBuf word 0 # RPC buffer +: Children word 0 # Scaled number of children +: Child word 0 # Child array +: ExtN word 0 # External symbol offset +: Extn word 0 +: StrX word 0 # String status +: StrC word 0 +: Alarm word Nil # Alarm handler +: LineX word ZERO # Console line +: LineC word -1 +: GcCount word CELLS # Collector count +: Sep0 word (char ".") # Decimal separator +: Sep3 word (char ",") # Thousand separator +: BufEnd word 0 # Common buffer end pointer + +: Penv word Nil # Pilog environment +: Pnl word Nil + +# Database +: DBs word 0 # Scaled number of DB files +: DbFile word 0 # DB file +: DbFiles word 0 # DB files +: DbBlock word 0 # Block buffer +: MaxBlkSize word 0 # Maximum block size +: BlkIndex word 0 # Block index +: BlkLink word 0 # Next block +: DbJnl word 0 # Journal file +: DbLog word 0 # Transaction log file + +# Symbol trees +:: Intern word Nil # Short internal names + word Nil # Long internal names +:: Transient word Nil # Short transient names + word Nil # Long transient names + + +# Symbol Table +(data 'SymTab 0) + initSym Nil "NIL" Nil + word Nil # CDR when NIL is accessed as an empty list + word 0 # Padding + + # Protected symbols + initSym OS "*OS" TgOS + initSym DB "*DB" Db1 + initSym Meth "meth" doMeth + initSym Quote "quote" doQuote + initSym TSym "T" TSym + + # System globals + initSym ISym "I" Nil + initSym NSym "N" Nil + initSym SSym "S" Nil + initSym CSym "C" Nil + initSym BSym "B" Nil + initSym Solo "*Solo" ZERO + initSym PPid "*PPid" Nil + initSym Pid "*Pid" 0 + initSym At "@" Nil + initSym At2 "@@" Nil + initSym At3 "@@@" Nil + initSym This "This" Nil + initSym Dbg "*Dbg" Nil + initSym Zap "*Zap" Nil + initSym Ext "*Ext" Nil + initSym Scl "*Scl" ZERO + initSym Class "*Class" Nil + initSym Run "*Run" Nil + initSym Hup "*Hup" Nil + initSym Sig1 "*Sig1" Nil + initSym Sig2 "*Sig2" Nil + initSym Up "\^" Nil + initSym Err "*Err" Nil + initSym Msg "*Msg" Nil + initSym Uni "*Uni" Nil + initSym Led "*Led" Nil + initSym Tsm "*Tsm" Nil + initSym Adr "*Adr" Nil + initSym Fork "*Fork" Nil + initSym Bye "*Bye" Nil + + # System functions + initSym NIL "raw" doRaw + initSym NIL "alarm" doAlarm + initSym NIL "protect" doProtect + initSym NIL "heap" doHeap + initSym NIL "env" doEnv + initSym NIL "up" doUp + initSym NIL "quit" doQuit + initSym NIL "errno" doErrno + initSym NIL "native" doNative + initSym NIL "args" doArgs + initSym NIL "next" doNext + initSym NIL "arg" doArg + initSym NIL "rest" doRest + initSym NIL "date" doDate + initSym NIL "time" doTime + initSym NIL "usec" doUsec + initSym NIL "pwd" doPwd + initSym NIL "cd" doCd + initSym NIL "ctty" doCtty + initSym NIL "info" doInfo + initSym NIL "file" doFile + initSym NIL "dir" doDir + initSym NIL "cmd" doCmd + initSym NIL "argv" doArgv + initSym NIL "opt" doOpt + initSym NIL "version" doVersion + + # Garbage collection + initSym NIL "gc" doGc + + # Mapping + initSym NIL "apply" doApply + initSym NIL "pass" doPass + initSym NIL "maps" doMaps + initSym NIL "map" doMap + initSym NIL "mapc" doMapc + initSym NIL "maplist" doMaplist + initSym NIL "mapcar" doMapcar + initSym NIL "mapcon" doMapcon + initSym NIL "mapcan" doMapcan + initSym NIL "filter" doFilter + initSym NIL "extract" doExtract + initSym NIL "seek" doSeek + initSym NIL "find" doFind + initSym NIL "pick" doPick + initSym NIL "cnt" doCnt + initSym NIL "sum" doSum + initSym NIL "maxi" doMaxi + initSym NIL "mini" doMini + initSym NIL "fish" doFish + initSym NIL "by" doBy + + # Control flow + initSym NIL "as" doAs + initSym NIL "pid" doPid + initSym NIL "lit" doLit + initSym NIL "eval" doEval + initSym NIL "run" doRun + initSym NIL "def" doDef + initSym NIL "de" doDe + initSym NIL "dm" doDm + initSym NIL "box" doBox + initSym NIL "new" doNew + initSym NIL "type" doType + initSym NIL "isa" doIsa + initSym NIL "method" doMethod + initSym NIL "send" doSend + initSym NIL "try" doTry + initSym NIL "super" doSuper + initSym NIL "extra" doExtra + initSym NIL "with" doWith + initSym NIL "bind" doBind + initSym NIL "job" doJob + initSym NIL "let" doLet + initSym NIL "let?" doLetQ + initSym NIL "use" doUse + initSym NIL "and" doAnd + initSym NIL "or" doOr + initSym NIL "nand" doNand + initSym NIL "nor" doNor + initSym NIL "xor" doXor + initSym NIL "bool" doBool + initSym NIL "not" doNot + initSym NIL "nil" doNil + initSym NIL "t" doT + initSym NIL "prog" doProg + initSym NIL "prog1" doProg1 + initSym NIL "prog2" doProg2 + initSym NIL "if" doIf + initSym NIL "if2" doIf2 + initSym NIL "ifn" doIfn + initSym NIL "when" doWhen + initSym NIL "unless" doUnless + initSym NIL "cond" doCond + initSym NIL "nond" doNond + initSym NIL "case" doCase + initSym NIL "state" doState + initSym NIL "while" doWhile + initSym NIL "until" doUntil + initSym NIL "at" doAt + initSym NIL "do" doDo + initSym NIL "loop" doLoop + initSym NIL "for" doFor + initSym NIL "catch" doCatch + initSym NIL "throw" doThrow + initSym NIL "finally" doFinally + initSym NIL "!" doBreak + initSym NIL "e" doE + initSym NIL "$" doTrace + initSym NIL "sys" doSys + initSym NIL "call" doCall + initSym NIL "tick" doTick + initSym NIL "ipid" doIpid + initSym NIL "opid" doOpid + initSym NIL "kill" doKill + initSym NIL "fork" doFork + initSym NIL "bye" doBye + + # Symbol functions + initSym NIL "name" doName + initSym NIL "sp?" doSpQ + initSym NIL "pat?" doPatQ + initSym NIL "fun?" doFunQ + initSym NIL "getd" doGetd + initSym NIL "all" doAll + initSym NIL "intern" doIntern + initSym NIL "extern" doExtern + initSym NIL "====" doHide + initSym NIL "box?" doBoxQ + initSym NIL "str?" doStrQ + initSym NIL "ext?" doExtQ + initSym NIL "touch" doTouch + initSym NIL "zap" doZap + initSym NIL "chop" doChop + initSym NIL "pack" doPack + initSym NIL "glue" doGlue + initSym NIL "text" doText + initSym NIL "pre?" doPreQ + initSym NIL "sub?" doSubQ + initSym NIL "val" doVal + initSym NIL "set" doSet + initSym NIL "setq" doSetq + initSym NIL "xchg" doXchg + initSym NIL "on" doOn + initSym NIL "off" doOff + initSym NIL "onOff" doOnOff + initSym NIL "zero" doZero + initSym NIL "one" doOne + initSym NIL "default" doDefault + initSym NIL "push" doPush + initSym NIL "push1" doPush1 + initSym NIL "pop" doPop + initSym NIL "cut" doCut + initSym NIL "del" doDel + initSym NIL "queue" doQueue + initSym NIL "fifo" doFifo + initSym NIL "idx" doIdx + initSym NIL "lup" doLup + initSym NIL "put" doPut + initSym NIL "get" doGet + initSym NIL "prop" doProp + initSym NIL ";" doSemicol + initSym NIL "=:" doSetCol + initSym NIL ":" doCol + initSym NIL "::" doPropCol + initSym NIL "putl" doPutl + initSym NIL "getl" doGetl + initSym NIL "wipe" doWipe + initSym NIL "meta" doMeta + initSym NIL "low?" doLowQ + initSym NIL "upp?" doUppQ + initSym NIL "lowc" doLowc + initSym NIL "uppc" doUppc + initSym NIL "fold" doFold + + # List processing + initSym NIL "car" doCar + initSym NIL "cdr" doCdr + initSym NIL "caar" doCaar + initSym NIL "cadr" doCadr + initSym NIL "cdar" doCdar + initSym NIL "cddr" doCddr + initSym NIL "caaar" doCaaar + initSym NIL "caadr" doCaadr + initSym NIL "cadar" doCadar + initSym NIL "caddr" doCaddr + initSym NIL "cdaar" doCdaar + initSym NIL "cdadr" doCdadr + initSym NIL "cddar" doCddar + initSym NIL "cdddr" doCdddr + initSym NIL "caaaar" doCaaaar + initSym NIL "caaadr" doCaaadr + initSym NIL "caadar" doCaadar + initSym NIL "caaddr" doCaaddr + initSym NIL "cadaar" doCadaar + initSym NIL "cadadr" doCadadr + initSym NIL "caddar" doCaddar + initSym NIL "cadddr" doCadddr + initSym NIL "cdaaar" doCdaaar + initSym NIL "cdaadr" doCdaadr + initSym NIL "cdadar" doCdadar + initSym NIL "cdaddr" doCdaddr + initSym NIL "cddaar" doCddaar + initSym NIL "cddadr" doCddadr + initSym NIL "cdddar" doCdddar + initSym NIL "cddddr" doCddddr + initSym NIL "nth" doNth + initSym NIL "con" doCon + initSym NIL "cons" doCons + initSym NIL "conc" doConc + initSym NIL "circ" doCirc + initSym NIL "rot" doRot + initSym NIL "list" doList + initSym NIL "need" doNeed + initSym NIL "range" doRange + initSym NIL "full" doFull + initSym NIL "make" doMake + initSym NIL "made" doMade + initSym NIL "chain" doChain + initSym NIL "link" doLink + initSym NIL "yoke" doYoke + initSym NIL "copy" doCopy + initSym NIL "mix" doMix + initSym NIL "append" doAppend + initSym NIL "delete" doDelete + initSym NIL "delq" doDelq + initSym NIL "replace" doReplace + initSym NIL "strip" doStrip + initSym NIL "split" doSplit + initSym NIL "reverse" doReverse + initSym NIL "flip" doFlip + initSym NIL "trim" doTrim + initSym NIL "clip" doClip + initSym NIL "head" doHead + initSym NIL "tail" doTail + initSym NIL "stem" doStem + initSym NIL "fin" doFin + initSym NIL "last" doLast + initSym NIL "==" doEq + initSym NIL "n==" doNEq + initSym NIL "=" doEqual + initSym NIL "<>" doNEqual + initSym NIL "=0" doEq0 + initSym NIL "=T" doEqT + initSym NIL "n0" doNEq0 + initSym NIL "nT" doNEqT + initSym NIL "<" doLt + initSym NIL "<=" doLe + initSym NIL ">" doGt + initSym NIL ">=" doGe + initSym NIL "max" doMax + initSym NIL "min" doMin + initSym NIL "atom" doAtom + initSym NIL "pair" doPair + initSym NIL "lst?" doLstQ + initSym NIL "num?" doNumQ + initSym NIL "sym?" doSymQ + initSym NIL "flg?" doFlgQ + initSym NIL "member" doMember + initSym NIL "memq" doMemq + initSym NIL "mmeq" doMmeq + initSym NIL "sect" doSect + initSym NIL "diff" doDiff + initSym NIL "index" doIndex + initSym NIL "offset" doOffset + initSym NIL "length" doLength + initSym NIL "size" doSize + initSym NIL "assoc" doAssoc + initSym NIL "asoq" doAsoq + initSym NIL "rank" doRank + initSym NIL "match" doMatch + initSym NIL "fill" doFill + initSym NIL "prove" doProve + initSym NIL "->" doArrow + initSym NIL "unify" doUnify + initSym NIL "sort" doSort + + # Arithmetics + initSym NIL "format" doFormat + initSym NIL "+" doAdd + initSym NIL "-" doSub + initSym NIL "inc" doInc + initSym NIL "dec" doDec + initSym NIL "*" doMul + initSym NIL "*/" doMulDiv + initSym NIL "/" doDiv + initSym NIL "%" doRem + initSym NIL ">>" doShift + initSym NIL "lt0" doLt0 + initSym NIL "ge0" doGe0 + initSym NIL "gt0" doGt0 + initSym NIL "abs" doAbs + initSym NIL "bit?" doBitQ + initSym NIL "&" doBitAnd + initSym NIL "|" doBitOr + initSym NIL "x|" doBitXor + initSym NIL "seed" doSeed + initSym NIL "rand" doRand + + # Input/Output + initSym NIL "path" doPath + initSym NIL "read" doRead + initSym NIL "wait" doWait + initSym NIL "sync" doSync + initSym NIL "hear" doHear + initSym NIL "tell" doTell + initSym NIL "poll" doPoll + initSym NIL "key" doKey + initSym NIL "peek" doPeek + initSym NIL "char" doChar + initSym NIL "skip" doSkip + initSym NIL "eol" doEol + initSym NIL "eof" doEof + initSym NIL "from" doFrom + initSym NIL "till" doTill + initSym NIL "line" doLine + initSym NIL "lines" doLines + initSym NIL "any" doAny + initSym NIL "sym" doSym + initSym NIL "str" doStr + initSym NIL "load" doLoad + initSym NIL "in" doIn + initSym NIL "out" doOut + initSym NIL "pipe" doPipe + initSym NIL "ctl" doCtl + initSym NIL "open" doOpen + initSym NIL "close" doClose + initSym NIL "echo" doEcho + initSym NIL "prin" doPrin + initSym NIL "prinl" doPrinl + initSym NIL "space" doSpace + initSym NIL "print" doPrint + initSym NIL "printsp" doPrintsp + initSym NIL "println" doPrintln + initSym NIL "flush" doFlush + initSym NIL "rewind" doRewind + initSym NIL "ext" doExt + initSym NIL "rd" doRd + initSym NIL "pr" doPr + initSym NIL "wr" doWr + initSym NIL "rpc" doRpc + + # Database + initSym NIL "pool" doPool + initSym NIL "journal" doJournal + initSym NIL "id" doId + initSym NIL "seq" doSeq + initSym NIL "lieu" doLieu + initSym NIL "lock" doLock + initSym NIL "commit" doCommit + initSym NIL "rollback" doRollback + initSym NIL "mark" doMark + initSym NIL "free" doFree + initSym NIL "dbck" doDbck + + # Networking + initSym NIL "port" doPort + initSym NIL "accept" doAccept + initSym NIL "listen" doListen + initSym NIL "host" doHost + initSym NIL "connect" doConnect + initSym NIL "udp" doUdp + +: SymTabEnd + +# Transient symbols + initSym TgOS `*TargetOS TgOS + +# Database root symbol '{1}' + word DB1 # Name +: Db1 + word Nil # Value +:: Extern # External symbol tree root node + word Db1 + word Nil + +# Version number +:: Version + word (short `(car *Version)) + word .+8 + word (short `(cadr *Version)) + word .+8 + word (short `(caddr *Version)) + word .+8 + word (short `(cadddr *Version)) + word Nil + +: GcMarkEnd + +# Structures +: Env # <Catch III> Environment +: EnvBind word 0 # <III> Bind frames (first item in Env) +: EnvInFrames word 0 # <IV> Input frames +: EnvOutFrames word 0 # <V> Output frames +: EnvCtlFrames word 0 # <VI> Control frames +: EnvArgs word 0 # Varargs frame +: EnvNext word 0 # Next vararg +: EnvApply word 0 # Apply frames +: EnvMeth word 0 # Method frames +: EnvTask word Nil # Task list +: EnvMake word 0 # 'make' env +: EnvYoke word 0 +: EnvParseX word 0 # Parser status +: EnvParseC word 0 +: EnvParseEOF word -1 +: EnvSort word 0 # Sort function +: EnvProtect word 0 # Signal protection +: EnvTrace word 0 # Trace level +: EnvBrk word 0 # Breakpoint + align 8 # Padding +: EnvEnd + +: OrgTermio skip TERMIOS # Original termio structure +: Flock skip FLOCK # File lock structure +: Tms skip TMS # 'times' structure +: Addr skip SOCKADDR_IN # Internet socket address + +: TBuf byte (+ INTERN 4) # 'T' in PLIO format + byte (char "T") + +# Strings +:: _r_ asciz "r" +:: _w_ asciz "w" +:: _a_ asciz "a" +:: _ap_ asciz "a+" +:: _dot_ asciz "." + +# Bytes +:: Signal byte 0 # Signal flag +:: Tio byte 0 # Terminal I/O +:: Flg byte 0 # General flag value + +: Repl byte 0 # REPL flag +: PRepl byte 0 # Parent REPL +: Jam byte 0 # Error jam +: InBye byte 0 # Exit status +: Sync byte 0 # Family IPC synchronization + + +# Case mappings from the GNU Kaffe Project + align 2 +: CaseBlocks + hx2 ("1C2" "1C2" "1C1" "12C" "12B" "1A0" "1F8" "2DC" "25F" "2EE" "215" "346" "2DC" "326" "2BC" "216") + hx2 ("15F" "2D4" "376" "376" "376" "369" "FE8F" "344" "FF85" "FF65" "FDB5" "FDA1" "1B" "2C4" "1C" "47") + hx2 ("FEA8" "FF8C" "235" "FEFF" "1A" "FEBF" "26" "FB20" "FE28" "113" "104" "FB61" "FB5A" "10B" "109" "FE") + hx2 ("FF08" "229" "25E" "1C7" "1FC" "1DC" "FC46" "229" "FE27" "FB55" "169" "FBC8" "FC" "103" "FB68" "FB48") + hx2 ("FB28" "FB08" "FAE8" "FAC8" "FAA8" "FA88" "FA68" "FA48" "65" "50" "AB" "139" "FE0E" "63" "155" "1A8") + hx2 ("F669" "129" "128" "F91F" "FE56" "108" "107" "FAC0" "FC8E" "FEAD" "C6" "FCA7" "FB95" "F47D" "9F" "FB17") + hx2 ("FE20" "FD28" "FB2F" "3B" "F3B9" "FE57" "FCCE" "FFBB" "F339" "FA98" "FF8B" "FF3B" "FA54" "F7E3" "FF2B" "FAD7") + hx2 ("FB69" "FC3A" "FEE5" "F4C8" "FCB0" "FA88" "FDBF" "F448" "FE45" "FCC7" "FE4F" "F7F1" "F715" "F2E8" "FD9F" "F348") + hx2 ("F96A" "FC02" "FD97" "F2C8" "F2A8" "F4B9" "F4B3" "EF6B" "F86A" "F84A" "FC58" "F80A" "F7EA" "FC0F" "F7AA" "EE9C") + hx2 ("FB90" "F74A" "F7FA" "F70A" "F7CA" "F792" "F471" "F4D2" "F732" "F64A" "F401" "F64D" "EFA8" "F5CA" "F5AA" "ECA1") + hx2 ("F569" "F54A" "F52A" "F50A" "F4EA" "F4CA" "F4AA" "F48A" "F46A" "F44A" "F42A" "F40A" "F3EA" "F3CA" "F3AA" "F38A") + hx2 ("F36A" "F34A" "F32A" "F289" "F777" "F2CA" "F2AA" "F737" "EC28" "EC08" "EBE8" "EBC8" "F1EA" "F4A2" "F545" "EDC6") + hx2 ("F2D7" "F14A" "E8ED" "E81E" "F0EA" "F597" "EA68" "EA48" "EA28" "EA08" "E9E8" "E9C8" "E9A8" "E988" "E968" "E948") + hx2 ("E928" "E908" "E8E8" "E8C8" "E8A8" "E888" "E868" "E848" "E828" "E808" "E7E8" "E7C8" "E7A8" "E788" "E768" "E748") + hx2 ("E728" "E708" "E6E8" "E6C8" "E6A8" "E688" "E668" "E648" "E628" "E608" "E5E8" "E5C8" "E5A8" "E588" "E568" "E548") + hx2 ("E55F" "E53F" "E51F" "E4FF" "EFD7" "E4BF" "E49F" "E485" "EF87" "EF57" "EF57" "EF57" "EF57" "EF47" "E1AD" "EF46") + hx2 ("EF46" "EF46" "E1E0" "E3DD" "EF06" "E9D9" "EBEB" "E244" "EED4" "EF65" "E1F5" "EF45" "EEE9" "EF7C" "EE74" "EF70") + hx2 ("EF7D" "EF78" "EE91" "EFD3" "EE7D" "EE25" "EE27" "EF65" "EFDD" "EE96" "EFD3" "EFE1" "EF69" "DF88" "DF68" "DF48") + hx2 ("ED2B" "ED3D" "ED19" "EF1C" "EF08" "ED47" "ED3D" "ED33" "EC2B" "EC0B" "EBEB" "EBCB" "EBCE" "EA7C" "EB69" "EB6C") + hx2 ("E9B6" "EB0B" "EAEB" "E9E9" "DCA8" "DC88" "DC68" "DC48" "E910" "EA23" "EB58" "EB4F" "EB45" "EAE5" "DB68" "DB48") + hx2 ("E92B" "E90B" "E8EB" "E8CB" "E8AB" "E88B" "E86B" "E84B" "DA28" "DA08" "D9E8" "D9C8" "D9A8" "D988" "D968" "D948") + hx2 ("D928" "D908" "D8E8" "D8C8" "D8A8" "D888" "D868" "D848" "D828" "D808" "D7E8" "D7C8" "D7A8" "D788" "D768" "D748") + hx2 ("D728" "D708" "D6E8" "D6C8" "D6A8" "D688" "D668" "D648" "D628" "D608" "D5E8" "D5C8" "D5A8" "D588" "D568" "D548") + hx2 ("D528" "D508" "D4E8" "D4C8" "E2B1" "E28B" "E26B" "E270" "E22B" "E20B" "E1EB" "E1CB" "E1AB" "E18B" "E18E" "DD8F") + hx2 ("E3A8" "DFD3" "D929" "D90A" "E348" "D8C9" "D8AA" "DCD7" "DCB2" "D681" "D82A" "D80A" "E268" "CEDE" "D168" "D148") + hx2 ("E116" "E0E9" "E1CB" "E0B7" "E0B7" "E15E" "DF17" "E034" "E013" "DFF3" "DFD3" "DE6C" "DF93" "DF73" "DF55" "DF34") + hx2 ("D56A" "D54A" "D52A" "D50A" "D4EA" "D4CA" "D4AA" "D48A" "D46A" "D44A" "D42A" "D40A" "D3EA" "D3CA" "D3AA" "D38A") + hx2 ("D36A" "D34A" "D32A" "D30A" "D2EA" "D2CA" "D2AA" "D28A" "D26A" "D24A" "D22A" "D20A" "D1EA" "D1CA" "D1AA" "D18A") + hx2 ("D16A" "D14A" "D12A" "D10A" "D0EA" "D0CA" "D0AA" "D08A" "D06A" "D04A" "D02A" "D00A" "CFEA" "CFCA" "CFAA" "CF8A") + hx2 ("CF6A" "CF4A" "CF2A" "CF0A" "CEEA" "CECA" "CEAA" "CE8A" "CE6A" "CE4A" "CE2A" "CE0A" "CDEA" "CDCA" "CDAA" "CD8A") + hx2 ("CD6A" "CD4A" "CD2A" "CD0A" "CCEA" "CCCA" "CCAA" "CC8A" "CC6A" "CC4A" "CC2A" "CC0A" "CBEA" "CBCA" "CBAA" "CB8A") + hx2 ("CB6A" "CB4A" "CB2A" "CB0A" "CAEA" "CACA" "CAAA" "CA8A" "CA6A" "CA4A" "CA2A" "CA0A" "C9EA" "C9CA" "C9AA" "C98A") + hx2 ("C96A" "C94A" "C92A" "C90A" "C8EA" "C8CA" "C8AA" "C88A" "C86A" "C84A" "C82A" "C80A" "C7EA" "C7CA" "C7AA" "C78A") + hx2 ("C76A" "C74A" "C72A" "C70A" "C6EA" "C6CA" "C6AA" "C68A" "C66A" "C64A" "C62A" "C60A" "C5EA" "C5CA" "C5AA" "C58A") + hx2 ("C56A" "C54A" "C52A" "C50A" "C4EA" "C4CA" "C4AA" "C48A" "C46A" "C44A" "C42A" "C40A" "C3EA" "C3CA" "C3AA" "C38A") + hx2 ("C36A" "C34A" "C32A" "C30A" "C2EA" "C2CA" "C2AA" "C28A" "C26A" "C24A" "C22A" "C20A" "C1EA" "C1CA" "C1AA" "C18A") + hx2 ("C16A" "C14A" "C12A" "C10A" "C0EA" "C0CA" "C0AA" "C08A" "C06A" "C04A" "C02A" "C00A" "BFEA" "BFCA" "BFAA" "BF8A") + hx2 ("BF6A" "BF4A" "BF2A" "BF0A" "BEEA" "BECA" "BEAA" "BE8A" "BE6A" "BE4A" "BE2A" "BE0A" "BDEA" "BDCA" "BDAA" "BD8A") + hx2 ("BD6A" "BD4A" "BD2A" "BD0A" "BCEA" "BCCA" "BCAA" "BC8A" "BC6A" "BC4A" "BC2A" "BC0A" "BBEA" "B2E0" "B568" "B548") + hx2 ("BB6A" "BB4A" "BB2A" "BB0A" "BAEA" "BACA" "BAAA" "BA8A" "BA6A" "BA4A" "BA2A" "BA0A" "B9EA" "B9CA" "B9AA" "B98A") + hx2 ("B96A" "B94A" "B92A" "B90A" "B8EA" "B8CA" "B8AA" "B88A" "B86A" "B84A" "B82A" "B80A" "B7EA" "B7CA" "B7AA" "B78A") + hx2 ("B76A" "B74A" "B72A" "B70A" "B6EA" "B6CA" "B6AA" "B68A" "B66A" "B64A" "B62A" "B60A" "B5EA" "B5CA" "B5AA" "B58A") + hx2 ("B56A" "B54A" "B52A" "B50A" "B4EA" "B4CA" "B4AA" "B48A" "B46A" "B44A" "B42A" "B40A" "B3EA" "B3CA" "B3AA" "B38A") + hx2 ("B36A" "B34A" "B32A" "B30A" "B2EA" "B2CA" "B2AA" "B28A" "B26A" "B24A" "B22A" "B20A" "B1EA" "B1CA" "B1AA" "B18A") + hx2 ("B16A" "B14A" "B12A" "B10A" "B0EA" "B0CA" "B0AA" "B08A" "B06A" "B04A" "B02A" "B00A" "AFEA" "AFCA" "AFAA" "AF8A") + hx2 ("AF6A" "AF4A" "AF2A" "AF0A" "AEEA" "AECA" "AEAA" "AE8A" "AE6A" "AE4A" "AE2A" "AE0A" "ADEA" "ADCA" "ADAA" "AD8A") + hx2 ("AD6A" "AD4A" "AD2A" "AD0A" "ACEA" "ACCA" "ACAA" "AC8A" "AC6A" "AC4A" "AC2A" "AC0A" "ABEA" "ABCA" "ABAA" "AB8A") + hx2 ("AB6A" "AB4A" "AB2A" "AB0A" "AAEA" "AACA" "AAAA" "AA8A" "AA6A" "AA4A" "AA2A" "AA0A" "A9EA" "A9CA" "A9AA" "A98A") + hx2 ("A96A" "A94A" "A92A" "A90A" "A8EA" "A8CA" "A8AA" "A88A" "A86A" "A84A" "A82A" "A80A" "A7EA" "A7CA" "A7AA" "A78A") + hx2 ("A76A" "A74A" "A72A" "A70A" "A6EA" "A6CA" "A6AA" "A68A" "A66A" "A64A" "A62A" "A60A" "A5EA" "A5CA" "A5AA" "A58A") + hx2 ("A56A" "A54A" "A52A" "A50A" "A4EA" "A4CA" "A4AA" "A48A" "A46A" "A44A" "A42A" "A40A" "A3EA" "A3CA" "A3AA" "A38A") + hx2 ("A36A" "A34A" "A32A" "A30A" "A2EA" "A2CA" "A2AA" "A28A" "A26A" "A24A" "A22A" "A20A" "A1EA" "A1CA" "A1AA" "A18A") + hx2 ("A16A" "A14A" "A12A" "A10A" "A0EA" "A0CA" "A0AA" "A08A" "A06A" "A04A" "A02A" "A00A" "9FEA" "9FCA" "9FAA" "9F8A") + hx2 ("9F6A" "9F4A" "9F2A" "9F0A" "9EEA" "9ECA" "9EAA" "9E8A" "9E6A" "9E4A" "9E2A" "9E0A" "9DEA" "9DCA" "9DAA" "9D8A") + hx2 ("9D6A" "9D4A" "9D2A" "9D0A" "9CEA" "9CCA" "9CAA" "9C8A" "9C6A" "9C4A" "9C2A" "9C0A" "9BEA" "9BCA" "9BAA" "9B8A") + hx2 ("9B6A" "9B4A" "9B2A" "9B0A" "9AEA" "9ACA" "9AAA" "9A8A" "9A6A" "9A4A" "9A2A" "9A0A" "99EA" "99CA" "99AA" "998A") + hx2 ("996A" "994A" "992A" "990A" "98EA" "98CA" "98AA" "988A" "986A" "984A" "982A" "980A" "97EA" "97CA" "97AA" "978A") + hx2 ("976A" "974A" "972A" "970A" "96EA" "96CA" "96AA" "968A" "966A" "964A" "962A" "960A" "95EA" "95CA" "95AA" "958A") + hx2 ("956A" "954A" "952A" "950A" "94EA" "94CA" "94AA" "948A" "946A" "944A" "942A" "940A" "93EA" "93CA" "93AA" "938A") + hx2 ("936A" "934A" "932A" "930A" "92EA" "92CA" "92AA" "928A" "926A" "924A" "922A" "920A" "91EA" "91CA" "91AA" "918A") + hx2 ("916A" "914A" "912A" "910A" "90EA" "90CA" "90AA" "908A" "906A" "904A" "902A" "900A" "8FEA" "8FCA" "8FAA" "8F8A") + hx2 ("8F6A" "8F4A" "8F2A" "8F0A" "8EEA" "8ECA" "8EAA" "8E8A" "8E6A" "8E4A" "8E2A" "8E0A" "8DEA" "8DCA" "8DAA" "8D8A") + hx2 ("8D6A" "8D4A" "8D2A" "8D0A" "8CEA" "8CCA" "8CAA" "8C8A" "8C6A" "8C4A" "8C2A" "8C0A" "8BEA" "8BCA" "8BAA" "8B8A") + hx2 ("8B6A" "8B4A" "8B2A" "8B0A" "8AEA" "8ACA" "8AAA" "8A8A" "8A6A" "8A4A" "8A2A" "8A0A" "89EA" "89CA" "89AA" "898A") + hx2 ("896A" "894A" "892A" "890A" "88EA" "88CA" "88AA" "888A" "886A" "884A" "882A" "880A" "87EA" "87CA" "87AA" "878A") + hx2 ("876A" "874A" "872A" "870A" "86EA" "86CA" "86AA" "868A" "866A" "864A" "862A" "860A" "85EA" "85CA" "85AA" "858A") + hx2 ("856A" "854A" "852A" "850A" "84EA" "84CA" "84AA" "848A" "846A" "844A" "842A" "840A" "83EA" "83CA" "83AA" "838A") + hx2 ("836A" "834A" "832A" "830A" "82EA" "82CA" "82AA" "828A" "826A" "824A" "822A" "820A" "81EA" "81CA" "81AA" "818A") + hx2 ("816A" "814A" "812A" "810A" "80EA" "80CA" "80AA" "808A" "806A" "804A" "802A" "800A" "7FEA" "7FCA" "7FAA" "7F8A") + hx2 ("7F6A" "7F4A" "7F2A" "7F0A" "7EEA" "7ECA" "7EAA" "7E8A" "7E6A" "7E4A" "7E2A" "7E0A" "7DEA" "7DCA" "7DAA" "7D8A") + hx2 ("7D6A" "7D4A" "7D2A" "7D0A" "7CEA" "7CCA" "7CAA" "7C8A" "7C6A" "7C4A" "7C2A" "7C0A" "7BEA" "7BCA" "7BAA" "7B8A") + hx2 ("7B6A" "7B4A" "7B2A" "7B0A" "7AEA" "7ACA" "7AAA" "7A8A" "7A6A" "7A4A" "7A2A" "7A0A" "79EA" "79CA" "79AA" "798A") + hx2 ("796A" "794A" "792A" "790A" "78EA" "78CA" "78AA" "788A" "786A" "784A" "782A" "780A" "77EA" "77CA" "77AA" "778A") + hx2 ("776A" "774A" "772A" "770A" "76EA" "76CA" "76AA" "768A" "766A" "764A" "762A" "760A" "75EA" "75CA" "75AA" "758A") + hx2 ("756A" "754A" "752A" "750A" "74EA" "74CA" "74AA" "748A" "746A" "744A" "742A" "740A" "73EA" "73CA" "73AA" "738A") + hx2 ("736A" "734A" "732A" "730A" "72EA" "72CA" "72AA" "728A" "726A" "724A" "722A" "720A" "71EA" "71CA" "71AA" "718A") + hx2 ("716A" "714A" "712A" "710A" "70EA" "70CA" "70AA" "708A" "706A" "704A" "702A" "700A" "6FEA" "6FCA" "6FAA" "6F8A") + hx2 ("6F6A" "6F4A" "6F2A" "6F0A" "6EEA" "6ECA" "6EAA" "6E8A" "6E6A" "6E4A" "6E2A" "6E0A" "6DEA" "6DCA" "6DAA" "6D8A") + hx2 ("6D6A" "6D4A" "6D2A" "6D0A" "6CEA" "6CCA" "6CAA" "6C8A" "6C6A" "6C4A" "6C2A" "6C0A" "6BEA" "6BCA" "6BAA" "6B8A") + hx2 ("6B6A" "6B4A" "6B2A" "6B0A" "6AEA" "6ACA" "6AAA" "6A8A" "6A6A" "6A4A" "6A2A" "6A0A" "69EA" "60F0" "6368" "6348") + hx2 ("696A" "694A" "692A" "690A" "68EA" "68CA" "68AA" "688A" "686A" "684A" "682A" "680A" "67EA" "67CA" "67AA" "678A") + hx2 ("676A" "674A" "672A" "670A" "66EA" "66CA" "66AA" "668A" "666A" "664A" "662A" "660A" "65EA" "65CA" "65AA" "658A") + hx2 ("656A" "654A" "652A" "650A" "6B26" "6DE1" "6E9C" "5E48" "5E28" "5E08" "5DE8" "5DC8" "5DA8" "5D88" "5D68" "5D48") + hx2 ("5D28" "5D08" "5CE8" "5CC8" "5CA8" "5C88" "5C68" "5C48" "5C28" "5C08" "5BE8" "5BC8" "5BA8" "5B88" "5B68" "5B48") + hx2 ("5B28" "5B08" "5AE8" "5AC8" "5AA8" "5A88" "5A68" "5A48" "5A28" "5A08" "59E8" "59C8" "59A8" "5988" "5968" "5948") + hx2 ("5928" "5908" "58E8" "58C8" "58A8" "5888" "5868" "5848" "5828" "5808" "57E8" "57C8" "57A8" "5788" "5768" "5748") + hx2 ("5D6A" "5D4A" "5D2A" "5D0A" "5CEA" "5CCA" "5CAA" "5C8A" "5C6A" "5C4A" "5C2A" "5C0A" "5BEA" "5BCA" "5BAA" "5B8A") + hx2 ("5B6A" "5B4A" "5B2A" "5B0A" "5AEA" "5ACA" "5AAA" "5A8A" "5A6A" "5A4A" "5A2A" "5A0A" "59EA" "59CA" "59AA" "598A") + hx2 ("596A" "594A" "592A" "590A" "58EA" "58CA" "58AA" "588A" "586A" "584A" "582A" "580A" "57EA" "57CA" "57AA" "578A") + hx2 ("576A" "574A" "572A" "570A" "56EA" "56CA" "56AA" "568A" "566A" "564A" "562A" "560A" "55EA" "55CA" "55AA" "558A") + hx2 ("556A" "554A" "552A" "550A" "54EA" "54CA" "54AA" "548A" "546A" "544A" "542A" "540A" "53EA" "53CA" "53AA" "538A") + hx2 ("536A" "534A" "532A" "530A" "52EA" "52CA" "52AA" "528A" "526A" "524A" "522A" "520A" "51EA" "51CA" "51AA" "518A") + hx2 ("516A" "514A" "512A" "510A" "50EA" "50CA" "50AA" "508A" "506A" "504A" "502A" "500A" "4FEA" "4FCA" "4FAA" "4F8A") + hx2 ("4F6A" "4F4A" "4F2A" "4F0A" "4EEA" "4ECA" "4EAA" "4E8A" "4E6A" "4E4A" "4E2A" "4E0A" "4DEA" "4DCA" "4DAA" "4D8A") + hx2 ("4D6A" "4D4A" "4D2A" "4D0A" "4CEA" "4CCA" "4CAA" "4C8A" "4C6A" "4C4A" "4C2A" "4C0A" "4BEA" "4BCA" "4BAA" "4B8A") + hx2 ("4B6A" "4B4A" "4B2A" "4B0A" "4AEA" "4ACA" "4AAA" "4A8A" "4A6A" "4A4A" "4A2A" "4A0A" "49EA" "49CA" "49AA" "498A") + hx2 ("496A" "494A" "492A" "490A" "48EA" "48CA" "48AA" "488A" "486A" "484A" "482A" "480A" "47EA" "47CA" "47AA" "478A") + hx2 ("476A" "474A" "472A" "470A" "46EA" "46CA" "46AA" "468A" "466A" "464A" "462A" "460A" "45EA" "45CA" "45AA" "458A") + hx2 ("456A" "454A" "452A" "450A" "44EA" "44CA" "44AA" "448A" "446A" "444A" "442A" "440A" "43EA" "43CA" "43AA" "438A") + hx2 ("436A" "434A" "432A" "430A" "42EA" "42CA" "42AA" "428A" "426A" "424A" "422A" "420A" "41EA" "41CA" "41AA" "418A") + hx2 ("416A" "414A" "412A" "410A" "40EA" "40CA" "40AA" "408A" "406A" "404A" "402A" "400A" "3FEA" "3FCA" "3FAA" "3F8A") + hx2 ("3F6A" "3F4A" "3F2A" "3F0A" "3EEA" "3ECA" "3EAA" "3E8A" "3E6A" "3E4A" "3E2A" "3E0A" "3DEA" "3DCA" "3DAA" "3D8A") + hx2 ("3D6A" "3D4A" "3D2A" "3D0A" "3CEA" "3CCA" "3CAA" "3C8A" "3C6A" "3C4A" "3C2A" "3C0A" "3BEA" "3BCA" "3BAA" "3B8A") + hx2 ("3B6A" "3B4A" "3B2A" "3B0A" "3AEA" "3ACA" "3AAA" "3A8A" "3A6A" "3A4A" "3A2A" "3A0A" "39EA" "39CA" "39AA" "398A") + hx2 ("396A" "394A" "392A" "390A" "38EA" "38CA" "38AA" "388A" "386A" "384A" "382A" "380A" "37EA" "37CA" "37AA" "378A") + hx2 ("376A" "374A" "372A" "370A" "36EA" "36CA" "36AA" "368A" "366A" "364A" "362A" "360A" "35EA" "35CA" "35AA" "358A") + hx2 ("356A" "354A" "352A" "350A" "34EA" "34CA" "34AA" "348A" "346A" "344A" "342A" "340A" "33EA" "33CA" "33AA" "338A") + hx2 ("336A" "334A" "332A" "330A" "32EA" "32CA" "32AA" "328A" "326A" "324A" "322A" "320A" "31EA" "28F2" "2B68" "2B48") + hx2 ("3C2B" "3C0B" "3BEB" "3BCB" "3BAB" "3B8B" "3B6B" "3B4B" "3B2B" "3B0B" "3AEB" "3ACB" "3AAB" "3A8B" "3A6B" "3A4B") + hx2 ("3A2B" "3A0B" "39EB" "39CB" "39AB" "398B" "396B" "394B" "392B" "390B" "38EB" "38CB" "38AB" "388B" "386B" "384B") + hx2 ("382B" "380B" "37EB" "37CB" "37AB" "378B" "376B" "374B" "372B" "370B" "36EB" "36CB" "36AB" "368B" "366B" "364B") + hx2 ("362B" "360B" "35EB" "35CB" "35AB" "358B" "356B" "354B" "352B" "350B" "34EB" "34CB" "34AB" "348B" "346B" "344B") + hx2 ("344B" "342B" "340B" "33EB" "33CB" "33AB" "338B" "336B" "334B" "332B" "330B" "32EB" "32CB" "32AB" "328B" "326B") + hx2 ("324B" "322B" "320B" "31EB" "31CB" "31AB" "318B" "316B" "314B" "312B" "310B" "30EB" "30CB" "30AB" "308B" "306B") + hx2 ("304B" "302B" "300B" "2FEB" "2FCB" "2FAB" "2F8B" "2F6B" "2F4B" "2F2B" "2F0B" "2EEB" "2ECB" "2EAB" "2E8B" "2E6B") + hx2 ("2E4B" "2E2B" "2E0B" "2DEB" "2DCB" "2DAB" "2D8B" "2D6B" "2D4B" "2D2B" "2D0B" "2CEB" "2CCB" "2CAB" "2C8B" "2C6B") + hx2 ("2C4B" "2C2B" "2C0B" "2BEB" "2BCB" "2BAB" "2B8B" "2B6B" "2B4B" "2B2B" "2B0B" "2AEB" "2ACB" "2AAB" "2A8B" "2A6B") + hx2 ("2A4B" "2A2B" "2A0B" "29EB" "29CB" "29AB" "298B" "296B" "294B" "292B" "290B" "28EB" "28CB" "28AB" "288B" "286B") + hx2 ("284B" "282B" "280B" "27EB" "27CB" "27AB" "278B" "276B" "274B" "272B" "270B" "26EB" "26CB" "26AB" "268B" "266B") + hx2 ("264B" "262B" "260B" "25EB" "25CB" "25AB" "258B" "256B" "254B" "252B" "250B" "24EB" "24CB" "24AB" "248B" "246B") + hx2 ("244B" "242B" "240B" "23EB" "23CB" "23AB" "238B" "236B" "234B" "232B" "230B" "22EB" "22CB" "22AB" "228B" "226B") + hx2 ("224B" "222B" "220B" "21EB" "21CB" "21AB" "218B" "216B" "214B" "212B" "210B" "20EB" "20CB" "20AB" "208B" "206B") + hx2 ("204B" "202B" "200B" "1FEB" "1FCB" "1FAB" "1F8B" "1F6B" "1F4B" "1F2B" "1F0B" "1EEB" "1ECB" "1EAB" "1E8B" "1E6B") + hx2 ("1E4B" "1E2B" "1E0B" "1DEB" "1DCB" "1DAB" "1D8B" "1D6B" "1D4B" "1D2B" "1D0B" "1CEB" "1CCB" "1CAB" "1C8B" "1C6B") + hx2 ("1C4B" "1C2B" "1C0B" "1BEB" "1BCB" "1BAB" "1B8B" "1B6B" "106A" "104A" "102A" "100A" "FEA" "FCA" "FAA" "F8A") + hx2 ("F6A" "668" "8E8" "8C8" "8A8" "888" "868" "848" "7D7" "194B" "7B6" "D1C" "CFC" "CB2" "CA9" "C9C") + hx2 ("C7C" "C5C" "C3C" "C1C" "BFC" "BDC" "BBC" "B9C" "B7C" "B5E" "B2C" "B1C" "AB8" "ADC" "A9C" "2C2") + hx2 ("528" "166B" "1667" "3FF" "9FC" "9DC" "9BC" "659" "BB8" "15A7" "FC6" "1C0" "1B1" "9CB" "82C" "1285") + +: CaseData + hx2 ("3001" "3082" "3001" "3082" "3001" "3082" "3001" "3082" "3001" "3082" "3001" "3082" "3001" "3082" "3001" "3082") + hx2 ("3001" "3082" "3001" "3082" "3001" "3082" "3E80" "3E80" "3001" "3082" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80") + hx2 ("3A85" "3A85" "3E80" "3E80" "3E80" "3A85" "3A85" "3A85" "3E80" "3E80" "3E80" "3A85" "3A85" "3A85" "3A85" "3A85") + hx2 ("3A85" "3A85" "3A85" "3E80" "3A85" "3A85" "3A85" "3E80" "3E80" "3E80" "3E80" "5B88" "5B88" "3E80" "3A85" "3A85") + hx2 ("3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3E80" "3A85" "3A85" "3A85" "3E80" "3A85" "3A85" "3A85" "3A85" "3A85") + hx2 ("3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85") + hx2 ("3A85" "3A85" "3E80" "3E80" "3E80" "3E80" "5198" "3E80" "3E80" "3E80" "3E80" "4606" "3E80" "3E80" "3A85" "3A85") + hx2 ("3A85" "3A85" "3A85" "3A85" "3E80" "3E80" "3E80" "3E80" "3A85" "3A85" "3E80" "3E80" "3A85" "3A85" "3A85" "3A85") + hx2 ("3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85") + hx2 ("3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80") + hx2 ("3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80") + hx2 ("3E80" "3E80" "5405" "5405" "5405" "5405" "5405" "5405" "5405" "5405" "5405" "5405" "5405" "5405" "3E80" "3E80") + hx2 ("3E80" "3E80" "5202" "5202" "5202" "5202" "5202" "5202" "5202" "5202" "5202" "5202" "5202" "5202" "5202" "5202") + hx2 ("5202" "5202" "5202" "5202" "5202" "5202" "5202" "5202" "5202" "5202" "5202" "5202" "5202" "5202" "5202" "5202") + hx2 ("5202" "2E82" "3E80" "5198" "2A14" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "4606" "4606" "4606" "4606" "4606") + hx2 ("4606" "4606" "4606" "4606" "4606" "4606" "4606" "4606" "4606" "4606" "4686" "4606" "4606" "4606" "4606" "4606") + hx2 ("4606" "4606" "4606" "4606" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80") + hx2 ("3E80" "3E80" "3E80" "3E80" "3E80" "1A1B" "1A1B" "3E80" "3E80" "3E80" "3E80" "4584" "3E80" "3E80" "3E80" "298") + hx2 ("3E80" "298" "6615" "6696" "298" "1A97" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85") + hx2 ("4584" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85") + hx2 ("3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "4584") + hx2 ("4584" "1A1B" "1A1B" "1A1B" "1A1B" "1A1B" "1A1B" "1A1B" "1A1B" "1A1B" "1A1B" "1A1B" "1A1B" "1A1B" "1A1B" "4584") + hx2 ("4584" "1A1B" "1A1B" "1A1B" "1A1B" "1A1B" "1A1B" "1A1B" "1A1B" "1A1B" "1A1B" "1A1B" "1A1B" "1A1B" "1A1B" "2E82") + hx2 ("7282" "2E82" "3E80" "2E82" "4902" "7481" "7481" "7481" "7481" "7383" "1A1B" "1A1B" "1A1B" "6D82" "6D82" "4902") + hx2 ("4902" "3E80" "3E80" "2E82" "4902" "6E01" "6E01" "7501" "7501" "3E80" "1A1B" "1A1B" "1A1B" "1B02" "1B82" "1C02") + hx2 ("1C82" "1D02" "1D82" "1E02" "1E82" "1F02" "1F82" "2002" "2082" "2102" "2182" "2202" "2282" "2302" "2382" "2402") + hx2 ("2482" "2502" "2582" "2602" "2682" "2702" "2782" "455" "C99" "4D6" "C99" "F" "F" "F" "F" "F") + hx2 ("10F" "F" "F" "F" "F" "F" "F" "F" "F" "F" "F" "F" "F" "F" "F" "F") + hx2 ("F" "F" "F" "F" "F" "F" "F" "F" "F" "F" "F" "8F" "10F" "8F" "18F" "10F") + hx2 ("F" "F" "F" "F" "F" "F" "F" "F" "F" "F" "F" "F" "F" "F" "10F" "10F") + hx2 ("10F" "8F" "20C" "298" "298" "318" "39A" "318" "298" "298" "455" "4D6" "298" "519" "598" "614") + hx2 ("598" "698" "709" "789" "809" "889" "909" "989" "A09" "A89" "B09" "B89" "598" "298" "C59" "C99") + hx2 ("C59" "298" "D01" "D81" "E01" "E81" "F01" "F81" "1001" "1081" "1101" "1181" "1201" "1281" "1301" "1381") + hx2 ("1401" "1481" "1501" "1581" "1601" "1681" "1701" "1781" "1801" "1881" "1901" "1981" "455" "298" "4D6" "1A1B") + hx2 ("1A97" "298" "298" "298" "C99" "455" "4D6" "3E80" "298" "298" "298" "298" "298" "298" "3E80" "3E80") + hx2 ("3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80") + hx2 ("282C" "298" "39A" "39A" "39A" "39A" "289C" "289C" "1A1B" "289C" "2902" "29DD" "C99" "2A14" "289C" "1A1B") + hx2 ("2A9C" "519" "2B0B" "2B8B" "1A1B" "2C02" "289C" "298" "1A1B" "2C8B" "2902" "2D5E" "2D8B" "2D8B" "2D8B" "298") + hx2 ("298" "519" "614" "C99" "C99" "C99" "3E80" "298" "39A" "318" "298" "3E80" "3E80" "3E80" "3E80" "5405") + hx2 ("5405" "5405" "3E80" "5405" "3E80" "5405" "5405" "5405" "5405" "5405" "5405" "5405" "5405" "5405" "5405" "5405") + hx2 ("5405" "5405" "3E80" "3E80" "3E80" "4606" "4606" "4606" "4606" "4606" "4606" "4606" "4606" "4606" "4606" "4606") + hx2 ("4606" "4606" "4606" "4606" "4606" "4606" "4606" "4606" "4606" "4606" "4606" "4606" "4606" "4606" "4606" "4606") + hx2 ("4606" "4606" "4606" "4606" "4606" "3E80" "501C" "501C" "4F81" "4F81" "4F81" "4F81" "4F81" "4F81" "4F81" "4F81") + hx2 ("4F81" "4F81" "4F81" "4F81" "4F81" "4F81" "4F81" "4F81" "2E01" "2E01" "2E01" "2E01" "2E01" "2E01" "2E01" "2E01") + hx2 ("2E01" "2E01" "2E01" "2E01" "2E01" "2E01" "2E01" "2E01" "2E01" "2E01" "2E01" "2E01" "2E01" "2E01" "2E01" "C99") + hx2 ("2E01" "2E01" "2E01" "2E01" "2E01" "2E01" "2E01" "2E82" "2E82" "2E82" "4902" "4902" "2E82" "2E82" "3E80" "3E80") + hx2 ("3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "2E82" "2E82" "2E82" "2E82" "2E82" "3E80") + hx2 ("3E80" "3E80" "3E80" "3E80" "5305" "4606" "5305" "5305" "3E80" "5305" "5305" "3E80" "5305" "5305" "5305" "5305") + hx2 ("5305" "5305" "5305" "5305" "5305" "5305" "5405" "5405" "5405" "5405" "5405" "5405" "5405" "5405" "5405" "5405") + hx2 ("5405" "5405" "5405" "5405" "5405" "5405" "5405" "5405" "5405" "5405" "5398" "5405" "4606" "4606" "4606" "4606") + hx2 ("4606" "4606" "4606" "5087" "5087" "4606" "5087" "5087" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80") + hx2 ("3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80") + hx2 ("3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "2D8B" "2D8B" "2D8B" "2D8B" "2D8B" "2D8B" "2D8B" "2D8B") + hx2 ("2D8B" "2D8B" "2D8B" "2D8B" "840B" "3082" "3001" "3082" "3001" "3082" "3001" "3082" "3001" "3082" "2E82" "3001") + hx2 ("3082" "3001" "3082" "3001" "3082" "3001" "3082" "3001" "3082" "3001" "3082" "3001" "3082" "3001" "3082" "3001") + hx2 ("3082" "3001" "3082" "3001" "3082" "3001" "3082" "3001" "3082" "3001" "3082" "3001" "3082" "3001" "3082" "3E80") + hx2 ("3E80" "3E80" "3E80" "3E80" "3E80" "5C09" "5C89" "5D09" "5D89" "5E09" "5E89" "5F09" "5F89" "6009" "6089" "4606") + hx2 ("4606" "3A85" "3A85" "3A85" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "1A1B") + hx2 ("1A1B" "4701" "298" "4781" "4781" "4781" "3E80" "4801" "3E80" "4881" "4881" "4902" "2E01" "2E01" "2E01" "2E01") + hx2 ("2E01" "2E01" "2E01" "2E01" "2E01" "2E01" "2E01" "2E01" "2E01" "2E01" "2E01" "2E01" "2F02" "2F02" "2F02" "2F02") + hx2 ("2F02" "2F02" "2F02" "2F02" "2F02" "2F02" "2F02" "2F02" "2F02" "2F02" "2F02" "2F02" "2F02" "2F02" "2F02" "2F02") + hx2 ("2F02" "2F02" "2F02" "C99" "2F02" "2F02" "2F02" "2F02" "2F02" "2F02" "2F02" "2F82" "2F02" "2F02" "4A82" "2F02") + hx2 ("2F02" "2F02" "2F02" "2F02" "2F02" "2F02" "2F02" "2F02" "4B02" "4B82" "4B82" "3E80" "4C02" "4C82" "4D01" "4D01") + hx2 ("4D01" "4D82" "4E02" "2902" "3E80" "3E80" "3001" "3082" "3001" "3082" "3001" "3082" "3001" "3082" "3001" "3082") + hx2 ("3001" "3082" "3001" "3082" "3001" "3082" "2E82" "3B81" "3C03" "3C82" "3001" "3082" "3D81" "3E01" "3001" "3082") + hx2 ("3001" "3082" "3001" "3082" "3001" "3082" "3001" "3082" "3001" "3082" "3001" "3082" "3001" "3082" "3101" "3182") + hx2 ("3001" "3082" "3001" "3082" "3001" "3082" "2902" "3001" "3082" "3001" "3082" "3001" "3082" "3001" "3082" "3001") + hx2 ("3082" "3001" "3082" "3001" "3082" "3001" "3082" "4E82" "4F02" "3D02" "2902" "3E80" "3E80" "3E80" "3E80" "3E80") + hx2 ("3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "5B10" "5B10" "5B10" "5B10" "5B10" "5B10" "7F0B" "3E80" "3E80") + hx2 ("3E80" "7F8B" "800B" "808B" "810B" "818B" "820B" "519" "519" "C99" "455" "4D6" "2902" "3301" "3001" "3082") + hx2 ("3001" "3082" "3381" "3001" "3082" "3401" "3401" "3001" "3082" "2902" "3481" "3501" "3581" "3001" "3082" "3401") + hx2 ("3601" "3682" "3701" "3781" "3001" "3082" "2902" "2902" "3701" "3801" "2902" "3881" "3A85" "3A85" "3A85" "3A85") + hx2 ("3B81" "3C03" "3C82" "3B81" "3C03" "3C82" "3B81" "3C03" "3C82" "3001" "3082" "3001" "3082" "3001" "3082" "3001") + hx2 ("3082" "3001" "3082" "3001" "3082" "3001" "3082" "3001" "3082" "3D02" "3001" "3082" "501C" "4606" "4606" "4606") + hx2 ("4606" "3E80" "5087" "5087" "3E80" "3E80" "3001" "3082" "3001" "3082" "3001" "3082" "3001" "3082" "3001" "3082") + hx2 ("3001" "3082" "3001" "3082" "3001" "3082" "3001" "3082" "3001" "3082" "3001" "3082" "3001" "3082" "3201" "3001") + hx2 ("3082" "3001" "3082" "3001" "3082" "3282" "3001" "3082" "3001" "3082" "3001" "3082" "3901" "3001" "3082" "3901") + hx2 ("2902" "2902" "3001" "3082" "3901" "3001" "3082" "3981" "3981" "3001" "3082" "3001" "3082" "3A01" "3001" "3082") + hx2 ("2902" "3A85" "3001" "3082" "2902" "3B02" "4D01" "3001" "3082" "3001" "3082" "3E80" "3E80" "3001" "3082" "3E80") + hx2 ("3E80" "3001" "3082" "3E80" "3E80" "3E80" "3001" "3082" "3001" "3082" "3001" "3082" "3001" "3082" "3001" "3082") + hx2 ("3001" "3082" "3001" "3082" "3001" "3082" "3001" "3082" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80") + hx2 ("3E80" "3E80" "3E80" "3E80" "598" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80") + hx2 ("3E80" "3E80" "3E80" "5398" "3E80" "3E80" "3E80" "5398" "5398" "5398" "5398" "5398" "5398" "5398" "5398" "5398") + hx2 ("5398" "5398" "5398" "5398" "5398" "3E80" "5B10" "5405" "4606" "5405" "5405" "5405" "5405" "5405" "5405" "5405") + hx2 ("5405" "5405" "5405" "5405" "5405" "5405" "5405" "5405" "5405" "5405" "5405" "5405" "5405" "5405" "5405" "5405") + hx2 ("5405" "5405" "5405" "5405" "5405" "5405" "3E80" "3E80" "5B10" "4D01" "4D01" "4D01" "4D01" "4D01" "4D01" "4D01") + hx2 ("4D01" "4D01" "4D01" "4D01" "4D01" "4D01" "4D01" "4D01" "4D01" "4D01" "4D01" "4D01" "4D01" "4D01" "4D01" "4D01") + hx2 ("4D01" "4D01" "4D01" "4D01" "4D01" "4D01" "4D01" "4D01" "4D01" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80") + hx2 ("3E80" "3E80" "3E80" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85") + hx2 ("3A85" "3A85" "3A85" "3A85" "3A85" "3E80" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3E80") + hx2 ("3A85" "3E80" "3E80" "3E80" "3E80" "3E80" "5C09" "5C89" "5D09" "5D89" "5E09" "5E89" "5F09" "5F89" "6009" "6089") + hx2 ("3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80") + hx2 ("3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "2902" "2902" "2902" "3F02" "3F82" "2902" "4002" "4002" "2902" "4082") + hx2 ("2902" "4102" "2902" "2902" "2902" "2902" "4002" "2902" "2902" "4182" "2902" "2902" "2902" "2902" "4202" "4282") + hx2 ("2902" "2902" "2902" "2902" "2902" "4282" "2902" "2902" "4302" "2902" "2902" "4382" "2902" "2902" "2902" "2902") + hx2 ("2902" "2902" "2902" "2902" "2902" "2902" "4402" "2902" "2902" "4402" "2902" "2902" "2902" "2902" "4402" "2902") + hx2 ("4482" "4482" "2902" "2902" "2902" "2902" "2902" "2902" "4502" "2902" "2902" "2902" "2902" "2902" "2902" "2902") + hx2 ("2902" "2902" "2902" "2902" "2902" "2902" "2902" "3E80" "3E80" "4584" "4584" "4584" "4584" "4584" "4584" "4584") + hx2 ("4584" "4584" "1A1B" "1A1B" "4584" "4584" "4584" "4584" "4584" "1A1B" "1A1B" "1A1B" "1A1B" "1A1B" "1A1B" "1A1B") + hx2 ("1A1B" "1A1B" "4584" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80") + hx2 ("3E80" "3E80" "3E80" "3E80" "5101" "5101" "5101" "5101" "5101" "5101" "5101" "5101" "5101" "5101" "5101" "5101") + hx2 ("5101" "5101" "5101" "5101" "5101" "5101" "5101" "5101" "5101" "5101" "5101" "3E80" "3E80" "4584" "5198" "5198") + hx2 ("5198" "5198" "5198" "5198" "2E01" "2E01" "3E80" "2E01" "2E01" "2E01" "2E01" "2E01" "2E01" "2E01" "2E01" "2E01") + hx2 ("4982" "4A02" "4A02" "4A02" "4902" "2F02" "2F02" "2F02" "2F02" "2F02" "2F02" "2F02" "2F02" "2F02" "2F02" "2F02") + hx2 ("2F02" "2F02" "2F02" "2F02" "2F02" "4F02" "4F02" "4F02" "4F02" "4F02" "4F02" "4F02" "4F02" "4F02" "4F02" "4F02") + hx2 ("4F02" "4F02" "4F02" "4F02" "4F02" "4606" "4606" "4606" "4606" "4606" "5198" "4606" "4606" "3A85" "3A85" "3A85") + hx2 ("3A85" "3E80" "3E80" "3E80" "3E80" "4606" "4606" "4606" "4606" "4606" "4606" "4606" "4606" "3E80" "4606" "4606") + hx2 ("4606" "4606" "4606" "4606" "4606" "4606" "4606" "4606" "4606" "4606" "4606" "4606" "4606" "4606" "4606" "4606") + hx2 ("4606" "4606" "4606" "4606" "4606" "3E80" "4606" "4606" "4606" "5298" "4606" "4606" "5298" "4606" "3E80" "3E80") + hx2 ("3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "5305" "5305" "5305" "5305" "5305" "5305" "5305") + hx2 ("5305" "5305" "5305" "5305" "5305" "5305" "5305" "5305" "5305" "3E80" "3E80" "3E80" "3E80" "3E80" "5305" "5305") + hx2 ("5305" "5298" "5298" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "5C89" "5D09") + hx2 ("5D89" "5E09" "5E89" "5F09" "5F89" "6009" "6089" "640B" "648B" "650B" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80") + hx2 ("3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "4606" "5B88" "3E80" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85") + hx2 ("3E80" "3E80" "3E80" "3A85" "3A85" "3A85" "3E80" "3A85" "3A85" "3A85" "3A85" "3E80" "3E80" "3E80" "3A85" "3A85") + hx2 ("3E80" "3A85" "3E80" "3A85" "3A85" "3A85" "3A85" "3E80" "3E80" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85") + hx2 ("3E80" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3E80" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85") + hx2 ("3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3E80" "3E80" "3E80" "3E80") + hx2 ("3E80" "3E80" "4606" "4606" "4606" "4606" "4606" "4606" "4606" "4606" "4606" "4606" "4606" "4606" "4606" "4606") + hx2 ("5B88" "5B88" "5B88" "5B88" "3E80" "4606" "4606" "4606" "3E80" "4606" "4606" "4606" "4606" "3E80" "3E80" "3E80") + hx2 ("3E80" "3E80" "3E80" "3E80" "4606" "4606" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "4606") + hx2 ("5B88" "5B88" "3E80" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3E80" "3E80" "3A85" "3A85" "3E80") + hx2 ("3E80" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3E80" "3E80") + hx2 ("3E80" "3E80" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85") + hx2 ("3A85" "3E80" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85") + hx2 ("3A85" "3A85" "3E80" "3E80" "3E80" "3E80" "5B88" "5B88" "3E80" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85") + hx2 ("3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3E80" "3E80" "3E80" "3A85" "3A85") + hx2 ("3A85" "3A85" "3A85" "3A85" "3E80" "3E80" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3E80" "3E80" "3A85" "3A85") + hx2 ("3A85" "3A85" "3A85" "3A85" "3E80" "3E80" "3A85" "3A85" "3A85" "3E80" "3E80" "3E80" "3E80" "5C09" "5C89" "5D09") + hx2 ("5D89" "5E09" "5E89" "5F09" "5F89" "6009" "6089" "501C" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80") + hx2 ("3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "5509" "5589" "5609" "5689" "5709" "5789" "5809" "5889" "5909") + hx2 ("5989" "318" "5A18" "5A18" "5398" "3E80" "3E80" "4606" "5405" "5405" "5405" "5405" "5405" "5405" "5405" "5405") + hx2 ("5405" "5405" "5405" "5405" "5405" "5405" "5405" "5405" "3E80" "3E80" "5405" "5405" "5405" "5405" "5405" "5405") + hx2 ("5405" "5405" "5405" "5405" "5405" "5405" "5405" "5405" "5405" "5405" "5405" "5405" "5405" "5405" "5405" "5405") + hx2 ("5405" "5405" "5405" "5405" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80") + hx2 ("3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "5405" "5405" "5405" "5405") + hx2 ("5405" "5405" "5405" "5405" "5405" "5405" "5405" "5405" "5405" "5405" "5405" "5405" "5405" "5405" "5405" "5405") + hx2 ("5405" "5405" "5405" "5405" "5405" "5405" "5405" "5405" "5405" "5405" "5405" "5405" "6615" "6696" "5484" "5405") + hx2 ("5405" "5405" "5405" "5405" "5405" "5405" "5405" "5405" "5405" "4606" "4606" "4606" "4606" "4606" "4606" "4606") + hx2 ("4606" "4606" "4606" "4606" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80") + hx2 ("3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "5B88" "5B88" "5198" "3E80" "3E80" "3E80" "3E80") + hx2 ("3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "4606" "4606" "5B88" "3E80" "3A85" "3A85" "3A85" "3A85" "3A85") + hx2 ("3A85" "3A85" "3E80" "3A85" "3E80" "3A85" "3A85" "3A85" "3E80" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85") + hx2 ("3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "5198" "5198" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85") + hx2 ("3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "4606" "4606" "4606" "4606" "4606" "5484" "5484") + hx2 ("4606" "4606" "289C" "4606" "4606" "4606" "4606" "3E80" "3E80" "709" "789" "809" "889" "909" "989" "A09") + hx2 ("A89" "B09" "B89" "5405" "5405" "5405" "5A9C" "5A9C" "3E80" "3A85" "3A85" "3A85" "3E80" "3A85" "3E80" "3A85") + hx2 ("3E80" "3E80" "3A85" "3A85" "3E80" "3A85" "3A85" "3A85" "3A85" "4606" "3A85" "3A85" "4606" "4606" "4606" "4606") + hx2 ("4606" "4606" "3E80" "4606" "4606" "3A85" "3E80" "3E80" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85") + hx2 ("3A85" "3E80" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3E80" "3A85" "3A85" "3A85") + hx2 ("3A85" "3A85" "3E80" "3E80" "3E80" "3E80" "4606" "4606" "5B88" "3E80" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85") + hx2 ("3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85") + hx2 ("3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3E80" "3E80" "4606" "3A85" "5B88" "5B88") + hx2 ("5B88" "5B88" "5B88" "3E80" "4606" "5B88" "5B88" "3E80" "5B88" "5B88" "4606" "4606" "3E80" "3E80" "3E80" "3E80") + hx2 ("3E80" "3E80" "3E80" "5B88" "5B88" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3A85" "3E80" "5198" "5198") + hx2 ("5198" "5198" "5198" "5198" "5198" "5198" "5C89" "5D09" "5D89" "5E09" "5E89" "5F09" "5F89" "6009" "6089" "640B") + hx2 ("670B" "678B" "680B" "688B" "690B" "698B" "6A0B" "6A8B" "648B" "6B0B" "3E80" "3E80" "3E80" "3A85" "3A85" "3A85") + hx2 ("3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3E80" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3E80" "3A85") + hx2 ("3A85" "3E80" "3E80" "3A85" "3A85" "3A85" "3A85" "3E80" "3E80" "4606" "3A85" "5B88" "4606" "4606" "4606" "4606") + hx2 ("4606" "4606" "4606" "4606" "5B88" "5B88" "5B88" "5B88" "4606" "3E80" "3E80" "3A85" "4606" "4606" "4606" "4606") + hx2 ("3E80" "3E80" "3E80" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3E80" "3A85" "3A85" "3A85") + hx2 ("3A85" "3A85" "3A85" "3A85" "3E80" "3A85" "3E80" "3E80" "3E80" "3A85" "3A85" "3A85" "3A85" "3E80" "3E80" "4606") + hx2 ("3E80" "5B88" "5B88" "5B88" "3E80" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3E80" "3A85" "3A85") + hx2 ("3A85" "3E80" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85") + hx2 ("3A85" "3E80" "3A85" "3E80" "3A85" "3A85" "3A85" "3A85" "3E80" "3E80" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85") + hx2 ("3A85" "3E80" "3A85" "3E80" "3A85" "3A85" "3A85" "3A85" "3E80" "3E80" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85") + hx2 ("3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "4606" "3A85" "3A85" "4606" "4606") + hx2 ("4606" "4606" "4606" "4606" "4606" "3E80" "3E80" "3E80" "3E80" "39A" "39A" "39A" "39A" "39A" "39A" "39A") + hx2 ("39A" "39A" "39A" "39A" "39A" "39A" "39A" "39A" "39A" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80") + hx2 ("3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3A85" "3A85" "4606" "4606" "5198" "5198" "5C09") + hx2 ("5C89" "5D09" "5D89" "5E09" "5E89" "5F09" "5F89" "6009" "6089" "5198" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80") + hx2 ("3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "298" "298" "318" "39A" "318" "298" "298") + hx2 ("6615" "6696" "298" "519" "598" "614" "598" "698" "709" "789" "809" "889" "909" "989" "A09" "A89") + hx2 ("B09" "B89" "598" "298" "C99" "C99" "C99" "298" "298" "298" "298" "298" "298" "2A14" "298" "298") + hx2 ("298" "298" "5B10" "5B10" "5B10" "5B10" "3E80" "5C09" "5C89" "5D09" "5D89" "5E09" "5E89" "5F09" "5F89" "6009") + hx2 ("6089" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85") + hx2 ("3E80" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3E80" "3A85" "3A85" "3A85" "3A85") + hx2 ("3A85" "3E80" "3E80" "3E80" "3E80" "5B88" "4606" "4606" "4606" "4606" "3E80" "3E80" "5B88" "5B88" "3E80" "3E80") + hx2 ("5B88" "5B88" "4606" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "5B88" "3E80" "3E80" "3E80") + hx2 ("3E80" "3A85" "3A85" "3E80" "3A85" "3E80" "3E80" "3A85" "3A85" "3E80" "3A85" "3E80" "3E80" "3A85" "3E80" "3E80") + hx2 ("3E80" "3E80" "3E80" "3E80" "3A85" "3A85" "3A85" "3A85" "3E80" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85") + hx2 ("3A85" "3A85" "3E80" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3E80" "3A85" "3A85" "3E80" "3A85" "3A85") + hx2 ("3E80" "3A85" "3A85" "3E80" "3E80" "4606" "3E80" "5B88" "5B88" "4606" "4606" "3E80" "3E80" "3E80" "3E80" "4606") + hx2 ("4606" "3E80" "3E80" "4606" "4606" "4606" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80") + hx2 ("3E80" "3A85" "3A85" "3A85" "3A85" "3E80" "3A85" "3E80" "3A85" "3A85" "4606" "4606" "3E80" "3E80" "5C09" "5C89") + hx2 ("5D09" "5D89" "5E09" "5E89" "5F09" "5F89" "6009" "6089" "3A85" "3A85" "39A" "39A" "610B" "618B" "620B" "628B") + hx2 ("630B" "638B" "501C" "3E80" "3E80" "3E80" "3E80" "3E80" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85") + hx2 ("3A85" "3E80" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3E80" "3A85" "3A85" "3E80" "3A85" "3A85" "3A85") + hx2 ("3A85" "3A85" "3E80" "3E80" "4606" "3A85" "5B88" "5B88" "4606" "4606" "4606" "4606" "4606" "3E80" "4606" "4606") + hx2 ("5B88" "3E80" "5B88" "5B88" "4606" "3E80" "3E80" "3A85" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80") + hx2 ("3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "5C09" "5C89" "5D09" "5D89" "5E09" "5E89" "5F09" "5F89" "6009") + hx2 ("6089" "630B" "630B" "630B" "630B" "630B" "630B" "630B" "630B" "630B" "630B" "501C" "4606" "501C" "4606" "501C") + hx2 ("4606" "6615" "6696" "6615" "6696" "5B88" "5B88" "4606" "4606" "4606" "3E80" "3E80" "3E80" "5B88" "5B88" "3E80") + hx2 ("3E80" "5B88" "5B88" "4606" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "4606" "5B88" "3E80" "3E80") + hx2 ("3E80" "3E80" "3A85" "3A85" "3E80" "3A85" "3A85" "3A85" "3A85" "3A85" "3E80" "3A85" "3A85" "3E80" "5B88" "4606") + hx2 ("4606" "4606" "4606" "5B88" "4606" "3E80" "3E80" "3E80" "4606" "4606" "5B88" "4606" "3E80" "3E80" "3E80" "3E80") + hx2 ("3E80" "3E80" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85") + hx2 ("3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "5B88" "5B88" "5B88" "4606" "4606" "4606" "4606" "4606" "4606" "4606") + hx2 ("5B88" "5B88" "3E80" "3E80" "3E80" "5B88" "5B88" "5B88" "3E80" "5B88" "5B88" "5B88" "4606" "3E80" "3E80" "3E80") + hx2 ("3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "5B88" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3A85") + hx2 ("3A85" "3A85" "3A85" "3A85" "3E80" "4584" "3E80" "4606" "4606" "4606" "4606" "4606" "4606" "3E80" "3E80" "5C09") + hx2 ("5C89" "5D09" "5D89" "5E09" "5E89" "5F09" "5F89" "6009" "6089" "3E80" "3E80" "3A85" "3A85" "3E80" "3E80" "3E80") + hx2 ("3E80" "5C09" "5C89" "5D09" "5D89" "5E09" "5E89" "5F09" "5F89" "6009" "6089" "3E80" "3E80" "3E80" "3E80" "3E80") + hx2 ("3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "4606" "4606" "4606" "4606" "4606") + hx2 ("4606" "4606" "4606" "4606" "4606" "4606" "4606" "4606" "5087" "5087" "5087" "5B88" "4606" "4606" "4606" "3E80") + hx2 ("3E80" "5B88" "5B88" "5B88" "3E80" "5B88" "5B88" "5B88" "4606" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80") + hx2 ("3E80" "3E80" "5B88" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3A85" "3A85" "3A85" "3A85" "3A85") + hx2 ("3A85" "3A85" "3E80" "3E80" "3E80" "4606" "3E80" "3E80" "3E80" "3E80" "5B88" "5B88" "5B88" "4606" "4606" "4606") + hx2 ("3E80" "4606" "3E80" "5B88" "5B88" "5B88" "5B88" "5B88" "5B88" "5B88" "5B88" "4606" "5B88" "5B88" "4606" "4606") + hx2 ("4606" "4606" "4606" "4606" "4606" "4606" "4606" "4606" "4606" "5198" "5198" "5198" "5198" "5198" "5198" "5198") + hx2 ("39A" "5198" "3E80" "3E80" "3E80" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "4584" "4606" "4606" "4606" "4606") + hx2 ("4606" "4606" "4606" "4606" "5198" "5C09" "5C89" "5D09" "5D89" "5E09" "5E89" "5F09" "5F89" "6009" "6089" "5198") + hx2 ("5198" "3E80" "3E80" "3E80" "3E80" "3A85" "501C" "501C" "501C" "5198" "5198" "5198" "5198" "5198" "5198" "5198") + hx2 ("5198" "65B8" "5198" "5198" "5198" "5198" "5198" "5198" "501C" "501C" "501C" "501C" "501C" "4606" "4606" "501C") + hx2 ("501C" "501C" "501C" "501C" "501C" "4606" "501C" "501C" "501C" "501C" "501C" "501C" "3E80" "3E80" "501C" "3E80") + hx2 ("3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "289C") + hx2 ("289C" "289C" "289C" "289C" "289C" "289C" "289C" "289C" "289C" "289C" "289C" "3E80" "3E80" "3E80" "3E80" "3A85") + hx2 ("3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3E80" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85") + hx2 ("3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85") + hx2 ("3A85" "3A85" "3E80" "3E80" "3E80" "3E80" "3E80" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85") + hx2 ("3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85") + hx2 ("3A85" "3A85" "1A97" "4584" "4584" "4584" "3E80" "5C09" "5C89" "5D09" "5D89" "5E09" "5E89" "5F09" "5F89" "6009") + hx2 ("6089" "5198" "5198" "5198" "5198" "5198" "5198" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "5B88" "5B88" "4606") + hx2 ("4606" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "20C" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85") + hx2 ("3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85") + hx2 ("3A85" "3A85" "6615" "6696" "3E80" "3E80" "3E80" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85") + hx2 ("3A85" "3A85" "5198" "5198" "5198" "6B8B" "6C0B" "6C8B" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80") + hx2 ("3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85") + hx2 ("4606" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80") + hx2 ("3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3001" "3082" "3001" "3082" "3001" "3082" "3001" "3082" "3001") + hx2 ("3082" "3001" "3082" "3001" "3082" "3001" "3082" "3001" "3082" "3001" "3082" "3001" "3082" "2E82" "2E82" "2E82") + hx2 ("2E82" "2E82" "6D02" "3E80" "3E80" "3E80" "3E80" "6D82" "6D82" "6D82" "6D82" "6D82" "6D82" "6D82" "6D82" "6E01") + hx2 ("6E01" "6E01" "6E01" "6E01" "6E01" "6E01" "6E01" "6D82" "6D82" "6D82" "6D82" "6D82" "6D82" "6D82" "6D82" "6E01") + hx2 ("6E01" "6E01" "6E01" "6E01" "6E01" "6E01" "6E01" "6D82" "6D82" "6D82" "6D82" "6D82" "6D82" "3E80" "3E80" "6E01") + hx2 ("6E01" "6E01" "6E01" "6E01" "6E01" "3E80" "3E80" "2E82" "6D82" "4902" "6D82" "4902" "6D82" "4902" "6D82" "3E80") + hx2 ("6E01" "3E80" "6E01" "3E80" "6E01" "3E80" "6E01" "6D82" "6D82" "6D82" "6D82" "6D82" "6D82" "6D82" "6D82" "6E01") + hx2 ("6E01" "6E01" "6E01" "6E01" "6E01" "6E01" "6E01" "6E82" "6E82" "6F02" "6F02" "6F02" "6F02" "6F82" "6F82" "7002") + hx2 ("7002" "7082" "7082" "7102" "7102" "3E80" "3E80" "7182" "7182" "7182" "7182" "7182" "7182" "7182" "7182" "7203") + hx2 ("7203" "7203" "7203" "7203" "7203" "7203" "7203" "7182" "7182" "7182" "7182" "7182" "7182" "7182" "7182" "7203") + hx2 ("7203" "7203" "7203" "7203" "7203" "7203" "7203" "6D82" "6D82" "2E82" "7282" "2E82" "3E80" "2E82" "4902" "6E01") + hx2 ("6E01" "7301" "7301" "7383" "1A1B" "7402" "1A1B" "1B02" "1B82" "1C02" "1C82" "1D02" "1D82" "1E02" "1E82" "1F02") + hx2 ("1F82" "2002" "2082" "2102" "2182" "2202" "2282" "2302" "2382" "2402" "2482" "2502" "2582" "2602" "2682" "2702") + hx2 ("2782" "6615" "C99" "6696" "C99" "3E80" "6D82" "6D82" "4902" "4902" "2E82" "7582" "2E82" "4902" "6E01" "6E01") + hx2 ("7601" "7601" "7681" "1A1B" "1A1B" "1A1B" "3E80" "3E80" "2E82" "7282" "2E82" "3E80" "2E82" "4902" "7701" "7701") + hx2 ("7781" "7781" "7383" "1A1B" "1A1B" "3E80" "20C" "20C" "20C" "20C" "20C" "20C" "20C" "782C" "20C" "20C") + hx2 ("20C" "788C" "5B10" "5B10" "7910" "7990" "2A14" "7A34" "2A14" "2A14" "2A14" "2A14" "298" "298" "7A9D" "7B1E") + hx2 ("6615" "7A9D" "7A9D" "7B1E" "6615" "7A9D" "298" "298" "298" "298" "298" "298" "298" "298" "7B8D" "7C0E") + hx2 ("7C90" "7D10" "7D90" "7E10" "7E90" "782C" "318" "318" "318" "318" "318" "298" "298" "298" "298" "29DD") + hx2 ("2D5E" "298" "298" "298" "298" "1A97" "7F0B" "2C8B" "2B0B" "2B8B" "7F8B" "800B" "808B" "810B" "818B" "820B") + hx2 ("519" "519" "C99" "455" "4D6" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80") + hx2 ("3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85") + hx2 ("3A85" "3A85" "3A85" "3E80" "3E80" "3E80" "289C" "289C" "289C" "289C" "289C" "289C" "289C" "289C" "289C" "289C") + hx2 ("289C" "289C" "289C" "289C" "289C" "289C" "289C" "289C" "289C" "289C" "3E80" "3E80" "3E80" "3E80" "3E80" "289C") + hx2 ("289C" "289C" "289C" "289C" "289C" "289C" "4D01" "289C" "289C" "289C" "289C" "4D01" "289C" "289C" "2902" "4D01") + hx2 ("4D01" "4D01" "2902" "2902" "4D01" "4D01" "4D01" "2902" "289C" "4D01" "289C" "289C" "289C" "4D01" "4D01" "4D01") + hx2 ("4D01" "4D01" "289C" "289C" "A20A" "A28A" "A30A" "A38A" "A40A" "A48A" "A50A" "A58A" "A60A" "4606" "4606" "4606") + hx2 ("4606" "4606" "4606" "2A14" "4584" "4584" "4584" "4584" "4584" "289C" "289C" "A68A" "A70A" "A78A" "3E80" "3E80") + hx2 ("3E80" "289C" "289C" "289C" "289C" "3E80" "289C" "289C" "289C" "289C" "3E80" "3E80" "289C" "289C" "289C" "289C") + hx2 ("289C" "289C" "289C" "289C" "289C" "289C" "289C" "289C" "289C" "289C" "289C" "289C" "289C" "289C" "289C" "289C") + hx2 ("289C" "289C" "289C" "C99" "289C" "289C" "289C" "289C" "289C" "289C" "289C" "289C" "289C" "289C" "289C" "289C") + hx2 ("289C" "289C" "C99" "C99" "289C" "289C" "C99" "289C" "C99" "289C" "289C" "289C" "289C" "289C" "289C" "289C") + hx2 ("289C" "289C" "289C" "289C" "289C" "289C" "289C" "289C" "C99" "289C" "289C" "3E80" "3E80" "3E80" "3E80" "3E80") + hx2 ("3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "948A" "950A" "958A" "960A" "3E80" "3E80" "3E80") + hx2 ("3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "C99" "C99" "C99" "C99" "C99" "289C" "289C") + hx2 ("289C" "289C" "289C" "C99" "C99" "289C" "289C" "289C" "289C" "4D01" "289C" "8281" "289C" "4D01" "289C" "8301") + hx2 ("8381" "4D01" "4D01" "2A9C" "2902" "4D01" "4D01" "289C" "4D01" "2902" "3A85" "3A85" "3A85" "3A85" "2902" "289C") + hx2 ("3E80" "3E80" "3E80" "3E80" "3E80" "848A" "850A" "858A" "860A" "868A" "870A" "878A" "880A" "888A" "890A" "898A") + hx2 ("8A0A" "8A8A" "8B0A" "8B8A" "8C0A" "8C8A" "8D0A" "8D8A" "8E0A" "8E8A" "8F0A" "8F8A" "900A" "908A" "910A" "918A") + hx2 ("920A" "928A" "930A" "938A" "940A" "C99" "C99" "C59" "C59" "C99" "C99" "C59" "C59" "C59" "C59" "C59") + hx2 ("C59" "C59" "C59" "C59" "C59" "C59" "C59" "C59" "C59" "C59" "C59" "C59" "C59" "C59" "C99" "C99") + hx2 ("C99" "C99" "C99" "C59" "C59" "C59" "C59" "C99" "C99" "C99" "C99" "C99" "C99" "C99" "C99" "C99") + hx2 ("C59" "C59" "C59" "C59" "C59" "C99" "C99" "C59" "C59" "C99" "C99" "C99" "C99" "C59" "C59" "C59") + hx2 ("C59" "C59" "C59" "C59" "C59" "C59" "C59" "C59" "C59" "C59" "C99" "C99" "C59" "C59" "C59" "C59") + hx2 ("C99" "C99" "C99" "C99" "C99" "C59" "C99" "C99" "C99" "C99" "C99" "C99" "C99" "289C" "289C" "C99") + hx2 ("289C" "289C" "C99" "289C" "289C" "289C" "289C" "289C" "289C" "289C" "C99" "289C" "289C" "289C" "289C" "289C") + hx2 ("289C" "289C" "289C" "289C" "289C" "289C" "289C" "289C" "289C" "289C" "289C" "289C" "289C" "289C" "289C" "289C") + hx2 ("289C" "289C" "289C" "289C" "289C" "289C" "289C" "289C" "289C" "289C" "289C" "3E80" "289C" "289C" "289C" "289C") + hx2 ("289C" "289C" "289C" "289C" "289C" "289C" "289C" "289C" "289C" "289C" "289C" "289C" "289C" "289C" "289C" "289C") + hx2 ("289C" "289C" "289C" "289C" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80") + hx2 ("3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "C99" "C59" "C59") + hx2 ("C59" "C59" "C99" "C99" "C99" "C59" "C59" "C59" "C59" "C59" "C59" "C99" "C99" "C99" "C59" "519") + hx2 ("519" "C99" "C59" "C59" "C99" "C99" "C99" "C59" "C59" "C59" "C59" "C99" "C59" "C99" "C59" "C99") + hx2 ("C99" "C99" "C99" "C59" "C59" "C59" "C59" "C59" "C59" "C59" "C59" "C59" "C99" "C99" "C99" "C99") + hx2 ("C99" "C59" "C99" "C59" "C59" "C59" "C59" "C59" "289C" "289C" "289C" "289C" "289C" "289C" "289C" "455") + hx2 ("4D6" "289C" "289C" "289C" "289C" "289C" "289C" "289C" "289C" "289C" "289C" "289C" "501C" "501C" "501C" "501C") + hx2 ("501C" "501C" "501C" "501C" "501C" "501C" "501C" "501C" "501C" "501C" "501C" "501C" "501C" "501C" "501C" "501C") + hx2 ("501C" "501C" "501C" "3E80" "3E80" "3E80" "3E80" "501C" "501C" "501C" "501C" "501C" "501C" "501C" "501C" "501C") + hx2 ("501C" "501C" "501C" "501C" "501C" "501C" "501C" "501C" "501C" "501C" "501C" "501C" "501C" "9C1C" "9C1C" "9C1C") + hx2 ("9C1C" "9C1C" "9C1C" "9C1C" "9C1C" "9C1C" "9C1C" "9C1C" "9C1C" "9C1C" "9C1C" "9C1C" "9C1C" "9C9C" "9C9C" "9C9C") + hx2 ("9C9C" "9C9C" "9C9C" "9C9C" "9C9C" "9C9C" "9C9C" "9C9C" "9C9C" "9C9C" "9C9C" "9C9C" "9C9C" "7F0B" "3E80" "3E80") + hx2 ("3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80") + hx2 ("3E80" "3E80" "3E80" "C59" "C99" "C59" "C99" "C59" "C59" "C59" "C59" "C59" "C59" "C59" "C59" "C99") + hx2 ("C99" "C59" "C59" "C59" "C59" "C59" "C59" "C59" "C59" "C59" "C59" "C59" "C59" "C59" "C59" "C59") + hx2 ("C59" "C59" "C59" "C99" "C99" "C59" "C59" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80") + hx2 ("3E80" "3E80" "3E80" "3E80" "3E80" "39A" "39A" "C99" "1A1B" "289C" "39A" "39A" "3E80" "289C" "C99" "C99") + hx2 ("C99" "C99" "289C" "289C" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "5B10" "5B10") + hx2 ("5B10" "289C" "289C" "3E80" "3E80" "289C" "289C" "289C" "289C" "289C" "289C" "289C" "289C" "289C" "289C" "289C") + hx2 ("289C" "289C" "289C" "289C" "289C" "3E80" "289C" "289C" "289C" "289C" "289C" "289C" "289C" "289C" "289C" "289C") + hx2 ("289C" "289C" "289C" "289C" "3E80" "289C" "3E80" "289C" "289C" "289C" "289C" "3E80" "3E80" "3E80" "289C" "3E80") + hx2 ("289C" "289C" "289C" "289C" "289C" "289C" "289C" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80") + hx2 ("3E80" "3E80" "3E80" "3E80" "3E80" "840B" "9D0B" "9D8B" "9E0B" "9E8B" "9F0B" "9F8B" "A00B" "A08B" "A10B" "840B") + hx2 ("9D0B" "9D8B" "9E0B" "9E8B" "9F0B" "9F8B" "A00B" "A08B" "A10B" "289C" "3E80" "3E80" "3E80" "289C" "289C" "289C") + hx2 ("289C" "289C" "289C" "289C" "289C" "C59" "C59" "C59" "C59" "289C" "289C" "289C" "289C" "289C" "289C" "289C") + hx2 ("289C" "289C" "289C" "289C" "289C" "289C" "289C" "289C" "289C" "289C" "289C" "289C" "289C" "289C" "501C" "289C") + hx2 ("289C" "289C" "289C" "289C" "3E80" "3E80" "3E80" "3E80" "3E80" "630B" "630B" "630B" "630B" "630B" "630B" "630B") + hx2 ("630B" "630B" "630B" "501C" "501C" "501C" "501C" "501C" "501C" "501C" "501C" "501C" "501C" "501C" "501C" "501C") + hx2 ("501C" "501C" "501C" "501C" "501C" "501C" "501C" "501C" "501C" "501C" "501C" "501C" "501C" "501C" "501C" "501C") + hx2 ("501C" "501C" "501C" "3E80" "3E80" "3E80" "501C" "610B" "618B" "620B" "628B" "A80B" "A88B" "A90B" "A98B" "AA0B") + hx2 ("640B" "501C" "501C" "501C" "501C" "501C" "501C" "501C" "501C" "501C" "501C" "501C" "501C" "501C" "501C" "501C") + hx2 ("501C" "501C" "501C" "501C" "501C" "501C" "501C" "501C" "501C" "501C" "501C" "501C" "289C" "3E80" "289C" "289C") + hx2 ("289C" "3E80" "289C" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80") + hx2 ("3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "2C8B" "2B0B" "2B8B" "7F8B") + hx2 ("800B" "808B" "810B" "818B" "820B" "968B" "970B" "978B" "980B" "988B" "990B" "998B" "9A0B" "9A8B" "9B0B" "9B8B") + hx2 ("2C8B" "2B0B" "2B8B" "7F8B" "800B" "808B" "810B" "818B" "820B" "968B" "970B" "978B" "980B" "988B" "990B" "998B") + hx2 ("9A0B" "9A8B" "9B0B" "9B8B" "501C" "501C" "501C" "501C" "20C" "298" "298" "298" "289C" "4584" "3A85" "A18A") + hx2 ("455" "4D6" "455" "4D6" "455" "4D6" "455" "4D6" "455" "4D6" "289C" "289C" "455" "4D6" "455" "4D6") + hx2 ("455" "4D6" "455" "4D6" "2A14" "6615" "6696" "6696" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85") + hx2 ("3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3E80" "3E80" "3E80") + hx2 ("3E80" "4606" "4606" "1A1B" "1A1B" "4584" "4584" "3E80" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85") + hx2 ("3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3E80" "501C" "501C" "630B" "630B" "630B" "630B" "501C" "501C") + hx2 ("501C" "501C" "501C" "501C" "501C" "501C" "501C" "501C" "501C" "501C" "501C" "501C" "501C" "501C" "501C" "3E80") + hx2 ("3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80") + hx2 ("3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "AA93" "AA93" "AA93" "AA93" "AA93") + hx2 ("AA93" "AA93" "AA93" "AA93" "AA93" "AA93" "AA93" "AA93" "AA93" "AA93" "AA93" "AA93" "AA93" "AA93" "AA93" "AA93") + hx2 ("AA93" "AA93" "AA93" "AA93" "AA93" "AA93" "AA93" "AA93" "AA93" "AA93" "AA93" "AB12" "AB12" "AB12" "AB12" "AB12") + hx2 ("AB12" "AB12" "AB12" "AB12" "AB12" "AB12" "AB12" "AB12" "AB12" "AB12" "AB12" "AB12" "AB12" "AB12" "AB12" "AB12") + hx2 ("AB12" "AB12" "AB12" "AB12" "AB12" "AB12" "AB12" "AB12" "AB12" "AB12" "AB12" "5305" "5305" "5305" "5305" "5305") + hx2 ("5305" "5305" "5305" "5305" "519" "5305" "5305" "5305" "5305" "5305" "5305" "5305" "5305" "5305" "5305" "5305") + hx2 ("5305" "5305" "3E80" "5305" "5305" "5305" "5305" "5305" "3E80" "5305" "3E80" "4606" "4606" "4606" "4606" "3E80") + hx2 ("3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "298" "2A14" "2A14" "1A97" "1A97") + hx2 ("6615" "6696" "6615" "6696" "6615" "6696" "6615" "6696" "6615" "6696" "6615" "6696" "3E80" "3E80" "3E80" "3E80") + hx2 ("298" "298" "298" "298" "1A97" "1A97" "1A97" "598" "298" "598" "3E80" "298" "598" "298" "298" "2A14") + hx2 ("6615" "6696" "6615" "6696" "6615" "6696" "318" "298" "D01" "D81" "E01" "E81" "F01" "F81" "1001" "1081") + hx2 ("1101" "1181" "1201" "1281" "1301" "1381" "1401" "1481" "1501" "1581" "1601" "1681" "1701" "1781" "1801" "1881") + hx2 ("1901" "1981" "6615" "298" "6696" "1A1B" "1A97") + +: CaseUpper + hx2 ("0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0") + hx2 ("0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0") + hx2 ("0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0") + hx2 ("0" "0" "0" "0" "0" "0" "FFE0" "FFE0" "FFE0" "FFE0" "FFE0" "FFE0" "FFE0" "FFE0" "FFE0" "FFE0") + hx2 ("FFE0" "FFE0" "FFE0" "FFE0" "FFE0" "FFE0" "FFE0" "FFE0" "FFE0" "FFE0" "FFE0" "FFE0" "FFE0" "FFE0" "FFE0" "FFE0") + hx2 ("0" "0" "0" "0" "0" "0" "0" "0" "2E7" "0" "0" "0" "0" "0" "FFE0" "79") + hx2 ("0" "FFFF" "0" "FF18" "0" "FED4" "0" "0" "0" "0" "0" "0" "0" "61" "0" "0") + hx2 ("0" "0" "0" "0" "0" "0" "38" "0" "FFFF" "FFFE" "FFB1" "0" "0" "0" "FF2E" "FF32") + hx2 ("FF33" "FF36" "FF35" "FF31" "FF2F" "FF2D" "FF2B" "FF2A" "FF26" "FF27" "FF25" "0" "0" "54" "0" "0") + hx2 ("0" "0" "0" "FFDA" "FFDB" "FFE1" "FFC0" "FFC1" "FFC2" "FFC7" "0" "FFD1" "FFCA" "FFAA" "FFB0" "0") + hx2 ("0" "0" "0" "0" "FFD0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0") + hx2 ("0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0") + hx2 ("0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0") + hx2 ("0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "FFC5" "8" "0" "4A" "56" "64") + hx2 ("80" "70" "7E" "8" "0" "9" "0" "0" "E3DB" "0" "0" "7" "0" "0" "0" "0") + hx2 ("0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0") + hx2 ("0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0") + hx2 ("0" "0" "0" "0" "0" "0" "0" "0" "0" "FFF0" "FFF0" "FFF0" "FFF0" "FFF0" "FFF0" "FFF0") + hx2 ("FFF0" "FFF0" "FFF0" "FFF0" "FFF0" "FFF0" "FFF0" "FFF0" "FFF0" "0" "0" "0" "0" "0" "0" "0") + hx2 ("0" "0" "0" "0" "0" "0" "0" "0" "0" "FFE6" "0" "0" "0" "0" "0" "0") + hx2 ("0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0") + hx2 ("0" "0" "0" "0" "0" "0" "0") + +: CaseLower + hx2 ("0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0") + hx2 ("0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "20" "20" "20" "20" "20" "20") + hx2 ("20" "20" "20" "20" "20" "20" "20" "20" "20" "20" "20" "20" "20" "20" "20" "20") + hx2 ("20" "20" "20" "20" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0") + hx2 ("0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0") + hx2 ("0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "20" "0" "0" "0") + hx2 ("1" "0" "FF39" "0" "FF87" "0" "D2" "CE" "CD" "4F" "CA" "CB" "CF" "0" "D3" "D1") + hx2 ("D5" "D6" "DA" "D9" "DB" "0" "0" "2" "1" "0" "0" "FF9F" "FFC8" "0" "0" "0") + hx2 ("0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "26" "25") + hx2 ("40" "3F" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "50") + hx2 ("0" "0" "30" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0") + hx2 ("0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0") + hx2 ("0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0") + hx2 ("0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "FFF8" "0" "0" "0") + hx2 ("0" "0" "0" "0" "FFF8" "0" "FFB6" "FFF7" "0" "FFAA" "FF9C" "0" "FF90" "FFF9" "FF80" "FF82") + hx2 ("0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0") + hx2 ("0" "0" "0" "0" "0" "E2A3" "DF41" "DFBA" "0" "10" "10" "10" "10" "10" "10" "10") + hx2 ("10" "10" "10" "10" "10" "10" "10" "10" "10" "0" "0" "0" "0" "0" "0" "0") + hx2 ("0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0") + hx2 ("0" "0" "0" "0" "0" "0" "0" "0" "1A" "0" "0" "0" "0" "0" "0" "0") + hx2 ("0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0") + hx2 ("0" "0" "0" "0" "0" "0" "0") + +# vi:et:ts=3:sw=3 diff --git a/src64/ht.l b/src64/ht.l @@ -0,0 +1,727 @@ +# 01apr10abu +# (c) Software Lab. Alexander Burger + +### Hypertext I/O functions ### +(data 'HtOK) +align 8 asciz "<b>" +align 8 asciz "</b>" +align 8 asciz "<i>" +align 8 asciz "</i>" +align 8 asciz "<u>" +align 8 asciz "</u>" +align 8 asciz "<p>" +align 8 asciz "</p>" +align 8 asciz "<pre>" +align 8 asciz "</pre>" +align 8 asciz "<div " +align 8 asciz "</div>" +align 8 asciz "<br>" +align 8 asciz "<hr>" +: HtOkEnd + +: HtLt asciz "&lt;" +: HtGt asciz "&gt;" +: HtAmp asciz "&amp;" +: HtQuot asciz "&quot;" +: HtNbsp asciz "&nbsp;" + +: HtEsc ascii " \\\"#%&:;<=>?_" +(equ HTESC 12) + +(code 'findHtOkY_FE 0) + push X + ld X HtOK + do + push X + push Y + do + ld B (X) # Compare bytes + cmp B (Y) # Equal? + while eq # Yes + add X 1 # End of HtOk string? + nul (X) + if z # Yes: Found + slen C Y # Length of the remaining string + ld B (char ">") # Is there a closing tag? + memb Y C + ldz E Y # Yes: Return pointer to next char in E + pop Y + pop X + pop X + ret # 'z' or 'nz' + end + add Y 1 # End of data? + nul (Y) + until z # Yes + pop Y + pop X + add X 8 # Try next + cmp X HtOkEnd # Done? + until gt # Yes + pop X + ret # 'nz' + +# (ht:Prin 'sym ..) -> sym +(code 'Prin 2) + push X + push Y + push Z + ld X (E CDR) # Args + do + ld E (X) # Eval next + eval + num E # Number? + jnz 20 # Yes + atom E # Cell? + jz 20 # Yes + sym (E TAIL) # External symbol? + if nz # Yes +20 call prinE_E # Plain print + else + push E # Save return value + call bufStringE_SZ # Write to stack buffer + ld Y S # Point to string + do + nul (Y) # Null byte? + while nz # No + call findHtOkY_FE # Preserved pattern? + if z # Yes + do + ld B (Y) # Output partial string + call envPutB + add Y 1 # till end pointer in E + cmp Y E + until eq + else + ld B (Y) # Next byte + cmp B (char "<") # Escape special characters + if eq + ld C HtLt # "&lt;" + call outStringC + else + cmp B (char ">") + if eq + ld C HtGt # "&gt;" + call outStringC + else + cmp B (char "&") + if eq + ld C HtAmp # "&amp;" + call outStringC + else + cmp B (char "\"") + if eq + ld C HtQuot # "&quot;" + call outStringC + else + cmp B (hex "FF") + if eq + ld B (hex "EF") + call envPutB + ld B (hex "BF") + call envPutB + ld B (hex "BF") + call envPutB + else + ld C A # Save char + call envPutB # Output it + test C (hex "80") # Double byte? + if nz # Yes + add Y 1 # Next + ld B (Y) # Output second byte + call envPutB + test C (hex "20") # Triple byte? + if nz # Yes + add Y 1 # Next + ld B (Y) # Output third byte + call envPutB + end + end + end + end + end + end + end + add Y 1 # Increment string pointer + end + loop + ld S Z # Drop buffer + pop E + end + ld X (X CDR) # X on rest + atom X # More? + until nz # No + pop Z + pop Y + pop X + ret + +(code 'putHexB 0) # E + ld E A # Save B + ld B (char "%") # Prefix with "%" + call envPutB + ld A E # Get B + shr B 4 # Get upper nibble + and B 15 + cmp B 9 # Letter? + if gt # Yes + add B 7 + end + add B (char "0") + call envPutB # Output upper nibble + ld A E # Get B again + and B 15 # Get lower nibble + cmp B 9 # Letter? + if gt # Yes + add B 7 + end + add B (char "0") + jmp envPutB # Output lower nibble + +(code 'htFmtE 0) + cmp E Nil # NIL? + if ne # No + num E # Number? + if nz # Yes + ld B (char "+") # Prefix with "+" + call envPutB + jmp prinE # and print it + end + push X + atom E # List? + if z # Yes + ld X E + do + ld B (char "_") # Prefix with "_" + call envPutB + ld E (X) # Print next item + call htFmtE + ld X (X CDR) # End of list? + atom X + until nz # Yes + else # Symbol + ld X (E TAIL) + call nameX_X # Get name + cmp X ZERO # Any? + if ne # Yes + sym (E TAIL) # External symbol? + if nz # Yes + ld B (char "-") # Prefix with "-" + call envPutB + call prExtNmX # Print external + else + push Y + ld Y Intern + call isInternEXY_F # Internal symbol? + ld C 0 + if eq # Yes + ld B (char "$") # Prefix with "$" + call envPutB + else + call symByteCX_FACX # Get first byte + cmp B (char "$") # Dollar, plus or dot? + jeq 40 + cmp B (char "+") + jeq 40 + cmp B (char "-") + if eq +40 call putHexB # Encode hexadecimal + else + call envPutB + end + end + do + call symByteCX_FACX # Next byte + while nz + memb HtEsc HTESC # Escape? + if eq # Yes + call putHexB # Encode hexadecimal + else + ld E A # Save char + call envPutB # Output it + test E (hex "80") # Double byte? + if nz # Yes + call symByteCX_FACX # Next byte + call envPutB # Output second byte + test E (hex "20") # Triple byte? + if nz # Yes + call symByteCX_FACX # Next byte + call envPutB # Output third byte + end + end + end + loop + pop Y + end + end + end + pop X + end + ret + +# (ht:Fmt 'any ..) -> sym +(code 'Fmt 2) + push X + push Y + push Z + ld X (E CDR) # X on args + link + do + ld E (X) + eval+ # Eval next arg + push E + ld X (X CDR) + atom X # More args? + until nz # No + lea Y (L -I) # Y on first arg + ld Z S # Z on last arg + link + call begString # Start string + ld E (Y) + call htFmtE # Format first arg + do + cmp Y Z # More args? + while ne # Yes + ld B (char "&") + call envPutB + sub Y I # Next arg + ld E (Y) + call htFmtE # Format it + loop + call endString_E # Retrieve result + drop + pop Z + pop Y + pop X + ret + +(code 'getHexX_A 0) + ld A ((X) TAIL) # Get first hex digit + call firstByteA_B + sub B (char "0") # Convert + cmp B 9 + if gt + and B (hex "DF") + sub B 7 + end + ld X (X CDR) # Next symbol + ret + +(code 'getUnicodeX_FAX 0) + ld E X # Save X + ld C 0 # Init unicode value + do + ld X (X CDR) + ld A ((X) TAIL) # Get next character symbol + call firstByteA_B + cmp B (char "0") # Digit? + while ge + cmp B (char "9") + while le # Yes + sub B (char "0") # Convert + push A # Save digit + ld A C # Get accu + mul 10 # Build decimal number + pop C # Get digit + add C A # New unicode value + loop + cmp B (char ";") # Terminator? + if eq # Yes + ld X (X CDR) # Skip ";" + ld A C # Get value + null A # Any? + jnz Ret # Yes + end + ld X E # Restore X + setz # 'z' + ret + +(code 'headCX_FX 0) # E + ld E X # Save X + do + add C 1 # Point to next char + nul (C) # Any? + while nz # Yes + ld A ((X) TAIL) # Get next character symbol + call firstByteA_B + cmp B (C) # Matched? + while eq # Yes + ld X (X CDR) + loop + ldnz X E # Restore X when no match + ret # 'z' if match + +# (ht:Pack 'lst) -> sym +(code 'Pack 2) + push X + ld E ((E CDR)) # Eval arg + eval + link + push E # Save + link + ld X E # List in X + call begString # Start string + do + atom X # More items? + while z # Yes + ld E (X) # Get next character symbol + ld A (E TAIL) + call firstByteA_B + cmp B (char "%") # Hex-escaped? + if eq # Yes + ld X (X CDR) # Skip "%" + call getHexX_A # Get upper nibble + shl A 4 + ld C A # into C + call getHexX_A # Get lower nibble + or A C # Combine + call envPutB # Output + else + ld X (X CDR) # Next symbol + cmp B (char "&") # Ampersand? + if ne # No + call outNameE # Normal output + else + ld C HtLt # "&lt;" + call headCX_FX + if eq + ld B (char "<") + call envPutB + else + ld C HtGt # "&gt;" + call headCX_FX + if eq + ld B (char ">") + call envPutB + else + ld C HtAmp # "&amp;" + call headCX_FX + if eq + ld B (char "&") + call envPutB + else + ld C HtQuot # "&quot;" + call headCX_FX + if eq + ld B (char "\"") + call envPutB + else + ld C HtNbsp # "&nbsp;" + call headCX_FX + if eq + ld B (char " ") + call envPutB + else + ld A ((X) TAIL) # Get next byte + call firstByteA_B + cmp B (char "#") # Hash? + jne 40 # No + call getUnicodeX_FAX # Unicode? + if nz # Yes + call mkCharA_A # Make symbol + ld E A + call outNameE # Output unicode char + else +40 ld B (char "&") # Else ouput an ampersand + call envPutB + end + end + end + end + end + end + end + end + loop + call endString_E # Retrieve result + drop + pop X + ret + +### Read content length bytes ### +# (ht:Read 'cnt) -> lst +(code 'Read 2) + push X + ld X E + ld E ((E CDR)) # E on arg + call evCntEX_FE # Eval 'cnt' + if nsz # > 0 + ld A (Chr) # Look ahead char? + null A + if z # No + call envGet_A # Get next char + end + null A # EOF? + if ns # No + call getChar_A # Read first char + cmp A 128 # Double byte? + if ge # Yes + sub E 1 # Decrement count + cmp A 2048 # Triple byte? + if ge # Yes + sub E 1 # Decrement count + end + end + sub E 1 # Less than zero? + if ns # No + call mkCharA_A # First character + call consA_X # Build first cell + ld (X) A + ld (X CDR) Nil + link + push X # <L I> Result + link + do + null E # Count? + if z # No + ld E (L I) # Return result + break T + end + call envGet_A # Get next char + null A # EOF? + if s # Yes + ld E Nil # Return NIL + break T + end + call getChar_A + cmp A 128 # Double byte? + if ge # Yes + sub E 1 # Decrement count + cmp A 2048 # Triple byte? + if ge # Yes + sub E 1 # Decrement count + end + end + sub E 1 # Less than zero? + if s # Yes + ld E Nil # Return NIL + break T + end + call mkCharA_A # Build next character + call consA_C # And next cell + ld (C) A + ld (C CDR) Nil + ld (X CDR) C # Append to result + ld X C + loop + ld (Chr) 0 # Clear look ahead char + drop + pop X + ret + end + end + end + ld E Nil # Return NIL + pop X + ret + + +### Chunked Encoding ### +(equ CHUNK 4000) + +(data 'Chunk 0) +word 0 # <Y> Chunk size count +word 0 # <Y I> Saved EnvGet_A function +word 0 # <Y II> Saved EnvPutB function +skip CHUNK # <Y III> Chunk buffer + +: Newlines asciz "0\\r\\n\\r\\n" + +(code 'chrHex_AF 0) + ld B (Chr) + cmp B (char "0") # Decimal digit? + if ge + cmp B (char "9") + if le + sub B 48 # Yes + ret # 'nc' + end + end + and B (hex "DF") # Force upper case + cmp B (char "A") # Hex letter? + if ge + cmp B (char "F") + if le + sub B 55 # Yes + ret # 'nc' + end + end + ld A 0 + sub A 1 # -1 + ret # 'c' + +(code 'chunkSize 0) + push X + ld X Chunk # Get Chunk + null (Chr) # 'Chr'? + if z # No + ld A (X I) # Call saved 'get' + call (A) + end + call chrHex_AF # Read encoded count + ld (X) A # Save in count + if ge # >= 0 + do + ld A (X I) # Call saved 'get' + call (A) + call chrHex_AF # Read encoded count + while ge # >= 0 + ld C (X) # Get count + shl C 4 # Combine + or C A + ld (X) C + loop + do + cmp (Chr) 10 # Fine linefeed + while ne + null (Chr) # EOF? + js 90 # Return + ld A (X I) # Call saved 'get' + call (A) + loop + ld A (X I) # Call saved 'get' + call (A) + null (X) # Count is zero? + if z # Yes + ld A (X I) # Call saved 'get' + call (A) # Skip '\r' of empty line + ld (Chr) 0 # Discard '\n' + end + end +90 pop X + ret + +(code 'getChunked_A 0) + push Y + ld Y Chunk # Get Chunk + null (Y) # Count <= 0 + if sz # Yes + ld A -1 # Return EOF + ld (Chr) A + else + ld A (Y I) # Call saved 'get' + call (A) + sub (Y) 1 # Decrement count + if z + ld A (Y I) # Call saved 'get' + call (A) + ld A (Y I) # Skip '\n', '\r' + call (A) + call chunkSize + end + end + pop Y + ret + +# (ht:In 'flg . prg) -> any +(code 'In 2) + push X + ld X (E CDR) # Args + ld E (X) # Eval 'flg' + eval + ld X (X CDR) # X on 'prg' + cmp E Nil # 'flg? + if eq # No + prog X # Run 'prg' + else + push Y + ld Y Chunk # Get Chunk + ld (Y I) (EnvGet_A) # Save current 'get' + ld (EnvGet_A) getChunked_A # Set new + call chunkSize + prog X # Run 'prg' + ld (EnvGet_A) (Y I) # Restore 'get' + ld (Chr) 0 # Clear look ahead char + pop Y + end + pop X + ret + + +(code 'outHexA 0) + cmp A 15 # Single digit? + if gt # No + push A + shr A 4 # Divide by 16 + call outHexA # Recurse + pop A + and B 15 + end + cmp B 9 # Digit? + if gt # No + add B 39 # Make lower case letter + end + add B (char "0") # Make ASCII digit + jmp envPutB + +(code 'wrChunkY 0) # X + ld (EnvPutB) (Y II) # Restore 'put' + ld A (Y) # Get count + call outHexA # Print as hex + ld B 13 # Output 'return' + call envPutB + ld B 10 # Output 'newline' + call envPutB + lea X (Y III) # X on chunk buffer + do + ld B (X) # Next byte from chunk buffer + call envPutB # Output + add X 1 # Increment pointer + sub (Y) 1 # Decrement 'Cnt' + until z + ld B 13 # Output 'return' + call envPutB + ld B 10 # Output 'newline' + call envPutB + ld (Y II) (EnvPutB) # Save 'put' + ld (EnvPutB) putChunkedB # Set new + ret + +(code 'putChunkedB 0) + push X + push Y + ld Y Chunk # Get Chunk + lea X (Y III) # X on chunk buffer + add X (Y) # Count index + ld (X) B # Store byte + add (Y) 1 # Increment count + cmp (Y) CHUNK # Max reached? + if eq # Yes + call wrChunkY # Write buffer + end + pop Y + pop X + ret + +# (ht:Out 'flg . prg) -> any +(code 'Out 2) + push X + ld X (E CDR) # Args + ld E (X) # Eval 'flg' + eval + ld X (X CDR) # X on 'prg' + cmp E Nil # 'flg? + if eq # No + prog X # Run 'prg' + else + push Y + ld Y Chunk # Get Chunk + ld (Y) 0 # Clear count + ld (Y II) (EnvPutB) # Save current 'put' + ld (EnvPutB) putChunkedB # Set new + prog X # Run 'prg' + null (Y) # Count? + if nz # Yes + call wrChunkY # Write rest + end + ld (EnvPutB) (Y II) # Restore 'put' + ld C Newlines # Output termination string + call outStringC + pop Y + end + ld A (OutFile) # Flush OutFile + call flushA_F # OK? + pop X + ret + +# vi:et:ts=3:sw=3 diff --git a/src64/io.l b/src64/io.l @@ -0,0 +1,5001 @@ +# 14apr10abu +# (c) Software Lab. Alexander Burger + +# Close file descriptor +(code 'closeAX) + cc close(A) + nul4 # OK? + jz Ret # Yes + ld E A # Get file descriptor + shl E 4 # Make short number + or E CNT + jmp closeErrEX + +# Lock/unlock file +(code 'unLockFileAC) + st2 (Flock) # 'l_type' + ld (Flock L_START) 0 # Start position ('l_whence' is SEEK_SET) + shr A 16 # Get length + ld (Flock L_LEN) A # Length + cc fcntl(C F_SETLK Flock) # Try to unlock + ret + +(code 'wrLockFileC) + ld A F_WRLCK # Write lock, length 0 + jmp lockFileAC +(code 'rdLockFileC) + ld A F_RDLCK # Read lock, length 0 +(code 'lockFileAC) + st2 (Flock) # 'l_type' + ld (Flock L_START) 0 # Start position ('l_whence' is SEEK_SET) + shr A 16 # Get length + ld (Flock L_LEN) A # Length + do + cc fcntl(C F_SETLKW Flock) # Try to lock + nul4 # OK? + jns Ret # Yes + call errno_A + cmp A EINTR # Interrupted? + jne lockErr # No + loop + +# Set the close-on-exec flag +(code 'closeOnExecAX) + cc fcntl(A F_SETFD FD_CLOEXEC) + nul4 # OK? + jns Ret # Yes + ld Y SetFD + jmp errnoEXY +: SetFD asciz "SETFD %s" + +# Set file descriptor to non-blocking / blocking +(code 'nonblockingA_A) + push C + ld C A # Keep fd + cc fcntl(C F_GETFL 0) # Get file status flags + push A # Save flags + or A O_NONBLOCK + cc fcntl(C F_SETFL A) # Set file status flags + pop A # Return old flags + pop C + ret + +# Initialize input file +(code 'initInFileA_A) # E + ld C 0 # No name +: initInFileAC_A + xchg A C +: initInFileCA_A + push A # Save 'name' + push C # and 'fd' + shl C 3 # Vector index + cmp C (InFDs) # 'fd' >= 'InFDs'? + if ge # Yes + push X + ld X (InFDs) # Keep old 'InFDs' + ld E C # Get vector index + add E I # Plus 1 + ld (InFDs) E # Store new 'InFDs' + ld A (InFiles) # Get vector + call allocAE_A # Extend vector + ld (InFiles) A + add X A # X on beg + add A E # A on end + do + ld (X) 0 # Clear new range + add X I + cmp X A + until eq + pop X + end + add C (InFiles) # Get vector + ld A (C) # Old inFile (should be NULL!) + ld E (+ VII BUFSIZ) # sizeof(inFile) + call allocAE_A + ld (C) A # New inFile + pop (A) # Set 'fd' + ld (A I) 0 # Clear 'ix' + ld (A II) 0 # Clear 'cnt' + ld (A III) 0 # Clear 'next' + ld C 1 + ld (A IV) C # line = 1 + ld (A V) C # src = 1 + pop (A VI) # Set filename + ret + +# Initialize output file +(code 'initOutFileA_A) + ld C A + push A # Save 'fd' + cc isatty(A) + push A # Save 'tty' flag + shl C 3 # Vector index + cmp C (OutFDs) # 'fd' >= 'OutFDs'? + if ge # Yes + push X + ld X (OutFDs) # Keep old 'OutFDs' + ld E C # Get vector index + add E I # Plus 1 + ld (OutFDs) E # Store new 'OutFDs' + ld A (OutFiles) # Get vector + call allocAE_A # Extend vector + ld (OutFiles) A + add X A # X on beg + add A E # A on end + do + ld (X) 0 # Clear new range + add X I + cmp X A + until eq + pop X + end + add C (OutFiles) # Get vector + ld A (C) # Old outFile (should be NULL!) + ld E (+ III BUFSIZ) # sizeof(outFile) + call allocAE_A + ld (C) A # New outFile + pop (A II) # Set 'tty' + ld (A I) 0 # Clear 'ix' + pop (A) # Set 'fd' + ret + +# Close input file +(code 'closeInFileA) + shl A 3 # Vector index + cmp A (InFDs) # 'fd' < 'InFDs'? + if lt # Yes + push X + add A (InFiles) # Get vector + ld X (A) + null X # Any? + if nz # Yes + cmp X (InFile) # Current Infile? + if eq # Yes + ld (InFile) 0 # Clear it + end + ld (A) 0 # Clear slot + cc free((X VI)) # Free filename + cc free(X) # And inFile + end + pop X + end + ret + +# Close output file +(code 'closeOutFileA) + shl A 3 # Vector index + cmp A (OutFDs) # 'fd' < 'OutFDs'? + if lt # Yes + push X + add A (OutFiles) # Get vector + ld X (A) + null X # Any? + if nz # Yes + cmp A (OutFile) # Current Outfile? + if eq # Yes + ld (OutFile) 0 # Clear it + end + ld (A) 0 # Clear slot + cc free(X) # And inFile + end + pop X + end + ret + +# Interruptible read +(code 'slowZ_F) + ld (Z I) 0 # Clear 'ix' + ld (Z II) 0 # Clear 'cnt' + do + cc read((Z) &(Z VII) BUFSIZ) # Read into buffer + null A # OK? + if ns # Yes + ld (Z II) A # Set new 'cnt' + ret # Return 'ge' + end + call errno_A + cmp A EINTR # Interrupted? + if ne # No + setz # Return 'z' + ret + end + nul (Signal) # Signal? + if nz # Yes + call sighandler0 + end + loop + +(code 'slowNbC_FA) + ld (C I) 0 # Clear 'ix' + ld (C II) 0 # Clear 'cnt' + do + ld A (C) # Set non-blocking + call nonblockingA_A + push A # Save old file status flags + cc read((C) &(C VII) BUFSIZ) # Read into buffer + xchg A (S) + cc fcntl((C) F_SETFL A) # Restore file status flags + pop A # Get 'read' return value + null A # OK? + if ns # Yes + ld (C II) A # Set new 'cnt' + ret # Return 'ge' + end + call errno_A + cmp A EAGAIN # No data available? + if eq # Yes + setc # Return 'lt' + ret + end + cmp A EINTR # Interrupted? + if ne # No + setz # Return 'z' + ret + end + nul (Signal) # Signal? + if nz # Yes + call sighandler0 + end + loop + +(code 'rdBytesCEX_F) + do + do + cc read(C X E) # Read into buffer + null A # OK? + while sz # No + jz Ret # EOF + call errno_A + cmp A EINTR # Interrupted? + jne Retz # No: Return 'z' + nul (Signal) # Signal? + if nz # Yes + call sighandler0 + end + loop + add X A # Increment buffer pointer + sub E A # Decrement count + until z + null A # 'nsz' + ret + +(code 'rdBytesNbCEX_F) + do + ld A C # Set non-blocking + call nonblockingA_A + push A # Save old file status flags + cc read(C X E) # Read into buffer + xchg A (S) + cc fcntl(C F_SETFL A) # Restore file status flags + pop A # Get 'read' return value + null A # OK? + if nsz # Yes + do + add X A # Increment buffer pointer + sub E A # Decrement count + if z # Got all + null A # 'nsz' + ret + end + do + cc read(C X E) # Read into buffer + null A # OK? + while sz # No + jz Ret # EOF + call errno_A + cmp A EINTR # Interrupted? + jne Retz # No: Return 'z' + nul (Signal) # Signal? + if nz # Yes + call sighandler0 + end + loop + loop + end + jz Ret # EOF + call errno_A + cmp A EAGAIN # No data available? + if eq # Yes + setc # Return 'lt' + ret + end + cmp A EINTR # Interrupted? + jne Retz # No: Return 'z' + nul (Signal) # Signal? + if nz # Yes + call sighandler0 + end + loop + +(code 'wrBytesCEX_F) + do + cc write(C X E) # Write buffer + null A # OK? + if ns # Yes + sub E A # Decrement count + jz Ret # Return 'z' if OK + add X A # Increment buffer pointer + else + call errno_A + cmp A EBADF # Bad file number? + jz retnz # Return 'nz' + cmp A EPIPE # Broken pipe? + jz retnz # Return 'nz' + cmp A ECONNRESET # Connection reset by peer? + jz retnz # Return 'nz' + cmp A EINTR # Interrupted? + jne wrBytesErr # No + end + nul (Signal) # Signal? + if nz # Yes + call sighandler0 + end + loop + +(code 'clsChildY 0) + ld (Y) 0 # Clear 'pid' + cc close((Y I)) # Close 'hear' + cc close((Y II)) # and 'tell' + cc free((Y V)) # Free buffer + ret + +(code 'wrChildCXY) # E + ld E (Y IV) # Get buffer count + null E # Any? + if z # No + do + cc write((Y II) X C) # Write buffer to 'tell' pipe + null A # OK? + if ns # Yes + sub C A # Decrement count + jz Ret # Done + add X A # Increment buffer pointer + else + call errno_A + cmp A EAGAIN # Would block? + break eq # Yes + cmp A EPIPE # Broken pipe? + jeq clsChildY # Close child + cmp A ECONNRESET # Connection reset by peer? + jeq clsChildY # Close child + cmp A EINTR # Interrupted? + jne wrChildErr # No + end + loop + end + ld A (Y V) # Get buffer + add E C # Increment count + add E 2 # plus count size + call allocAE_A # Extend buffer + ld (Y V) A # Store + ld E (Y IV) # Get buffer count again + add E (Y IV) # Point to new count + ld A C # Store new + st2 (E) + add E 2 # Point to new data + movn (E) (X) C # Copy data + add C 2 # Total new size + add (Y IV) # Add to buffer count + ret + +(code 'flushA_F 0) + null A # Output file? + if nz # Yes + push E + ld E (A I) # Get 'ix' + null E # Any? + if nz # Yes + push C + push X + ld (A I) 0 # Clear 'ix' + ld C (A) # Get 'fd' + lea X (A III) # Buffer pointer + call wrBytesCEX_F # Write buffer + pop X + pop C + end + pop E + end + ret # Return 'z' if OK + +(code 'flushAll) # C + ld C 0 # Iterate output files + do + cmp C (OutFDs) # 'fd' < 'OutFDs'? + while lt + ld A C # Get vector index + add A (OutFiles) # Get OutFile + ld A (A) + call flushA_F # Flush it + add C I # Increment vector index + loop + ret + +### Low level I/O ### +(code 'stdinByte_FA) + push Z + ld Z ((InFiles)) # Get stdin + null Z # Open? + if nz # Yes + call getBinaryZ_FB # Get byte + zxt + pop Z + ret + end + setc + pop Z + ret + +(code 'getBinaryZ_FB 0) + ld A (Z I) # Get 'ix' + cmp A (Z II) # Equals 'cnt'? + if eq # Yes + call slowZ_F # Read into buffer + jz retc # EOF (c) + ld A 0 # 'ix' + end + add (Z I) 1 # Increment 'ix' + add A Z # Fetch byte (nc) + ld B (A VII) # from buffer + ret # nc + +# Add next byte to a number +(code 'byteNumBCX_CX 0) + zxt + big X # Big number? + if z # No: Direct buffer pointer + # xxxxx.xxxxxxx.xxxxxxx.xxxxxxx.xxxxxxx.xxxxxxx.xxxxxxx.xxxxxxS010 + # 59 51 43 35 27 19 11 3 + cmp C 59 # Short digit full? + if ne # No + shl A C # Shift byte to character position + or (X) A # Combine with short number + add C 8 # Increment position + ret + end + ld C (X) # Get short number + shr C 3 # De-normalize, keep sign bit + shl A 56 # Combine byte with digit + or C A + call boxNum_A # Box number + ld (A DIG) C + ld (X) A + ld X A + ld C 0 # Start new digit + ret + end + null C # Last bit of big digit? + if z # Yes + ld C (X DIG) + shr A 1 # Get lowest bit + rcr C 1 # into highest bit of big digit + ld (X DIG) C + rcl A 1 # Get sign bit into A + shl A 3 # Normalize with sign + or A CNT # Make short number + ld (X BIG) A + ld C 11 # Set up for second byte + ret + end + cmp C 59 # Short digit full? + if ne # No + shl A C # Shift byte to character position + or (X BIG) A # Combine with name digit + add C 8 # Increment position + ret + end + ld C (X BIG) # Get short number + shr C 3 # De-normalize, keep sign bit + shl A 56 # Combine byte with digit + or C A + call boxNum_A # Box number + ld (A DIG) C + ld (X BIG) A + ld X A + ld C 0 # Start new digit + ret + +# Read binary expression +(code 'binReadZ_FE) + call (GetBinZ_FB) # Tag byte? + jc ret # No + nul B # NIX? + jz retNil # Return NIL + zxt + test B (hex "FC") # Atomic? + if z # No + ld E A + cmp B BEG # Begin a list? + jnz retnc # No: Return DOT or END (also in B) + call binReadZ_FE # Else read list + jc ret + push X + call consE_X # First cell + ld (X) E + ld (X CDR) Nil + link + push X # <L I> Save it + link + do + call binReadZ_FE # Next item + jc 10 # EOF + cmp E END # Any? + while ne # Yes + cmp E DOT # Dotted pair? + if eq + cmp B DOT # Only if B is also DOT (to distinguish from Zero) + if eq # Yes + call binReadZ_FE # Get CDR + if c # EOF +10 drop + pop X + ret # Return 'c' + end + cmp E END # Circular list? + ldz E (L I) # Yes: Get first cell + ld (X CDR) E # Store in last cell + break T + end + end + call consE_C # Append next cell + ld (C) E + ld (C CDR) Nil + ld (X CDR) C + ld X C + loop + ld E (L I) # Return list + drop # Return 'nc' + pop X + ret + end + push X + link + push ZERO # <L I> Result + ld X S + link + ld E A # Get tag byte + shr E 2 # Count + and A 3 # Tag + if z # NUMBER + ld C 3 # Build signed number + cmp E 63 # More than one chunk? + if eq # Yes + do + do + call (GetBinZ_FB) # Next byte? + jc 90 # No + call byteNumBCX_CX + sub E 1 # Decrement count + until z + call (GetBinZ_FB) # Next count? + jc 90 # No + zxt + ld E A + cmp B 255 # Another chunk? + until ne # No + or B B # Empty? + jz 20 # Yes + end + do + call (GetBinZ_FB) # Next byte? + jc 90 # No + call byteNumBCX_CX # (B is zero (not DOT) if Zero) + sub E 1 # Decrement count + until z +20 ld E (L I) # Get result + big X # Big number? + if nz # Yes + ld A (X BIG) # Get last short + and A SIGN # Sign bit + off (X BIG) SIGN + or E A # Set sign bit in result + end + else # INTERN, TRANSIENT or EXTERN + push A # Tag + ld C 4 # Build name + cmp E 63 # More than one chunk? + if eq # Yes + do + do + call (GetBinZ_FB) # Next byte? + jc 90 # No + call byteSymBCX_CX + sub E 1 # Decrement count + until z + call (GetBinZ_FB) # Next count? + jc 90 # No + zxt + ld E A + cmp B 255 # Another chunk? + until ne # No + or B B # Empty? + jz 30 # Yes + end + do + call (GetBinZ_FB) # Next byte? + jc 90 # No + call byteSymBCX_CX + sub E 1 # Decrement count + until z +30 ld X (L I) # Get name + pop A # Get tag + cmp A TRANSIENT # Transient? + if eq # Yes + call consSymX_E # Build symbol + else + cmp A INTERN # Internal? + if eq # Yes + push Y + call findSymX_E # Find or create it + pop Y + else # External + null (Extn) # External symbol offset? + if nz # Yes + ld A X # Get file number + shr A 24 # Lower 8 bits + ld C A # into C + and C (hex "FF") + shr A 12 # Upper 8 bits + and A (hex "FF00") + or A C + add A (Extn) # Add external symbol offset + shl A 24 + ld C A # Lower result bits + shl A 12 + or A C + and A (hex "000FF000FF000000") # Mask file number + and X (hex "FFF00FFF00FFFFFF") # Mask object ID + or X A # Combine + end + call externX_E # New external symbol + end + end + end + clrc +90 drop + pop X + ret + +# Binary print next byte from a number +(code 'prByteCEXY 0) + null C # New round? + if z # Yes + cnt X # Short number? + if z # No + ld E (X DIG) # Next digit + ld X (X BIG) + else + ld E X # Get short + shr E 4 # Normalize + end + shr Y 1 # Get overflow bit + rcl E 1 # Shift into digit + rcl Y 1 # Keep new overflow bit + ld C 8 # Init count + end + ld A E # Output next byte + call (PutBinBZ) + shr E 8 # Shift to next + sub C 1 # Decrement count + ret + +# Binary print short number +(code 'prCntCE 0) + ld A E + do + shr A 8 # More bytes? + while nz # Yes + add C 4 # Increment count + loop + ld A C # Output tag byte + call (PutBinBZ) + shr C 2 # Discard tag bits + do + ld A E # Next data byte + shr E 8 + call (PutBinBZ) # Output data byte + sub C 1 # More? + until z # No + ret + +# Binary print expression +(code 'prTellEZ 0) + ld (PutBinBZ) putTellBZ # Set binary print function + ld (Extn) 0 # Set external symbol offset to zero + call binPrintEZ + ret + +(code 'prE) + ld (PutBinBZ) putStdoutB # Set binary print function +(code 'binPrintEZ) + cnt E # Short number? + if nz # Yes + ld C 4 # Count significant bytes (adjusted to tag) + shr E 3 # Normalize + jmp prCntCE # Output 'cnt' + end + big E # Big number? + if nz # Yes + push X + push Y + push E # Save signed number + off E SIGN # Make positive + ld X E # Keep in X + ld A 8 # Count 8 significant bytes + do + ld C (E DIG) # Keep digit + ld E (E BIG) # More cells? + cnt E + while z # Yes + add A 8 # Increment count by 8 + loop + shr E 4 # Normalize short + shl C 1 # Get most significant bit of last digit + addc E E # Any significant bits in short number? + if nz # Yes + do + add A 1 # Increment count + shr E 8 # More bytes? + until z # No + end + pop Y # Get sign + shr Y 3 # into lowest bit + ld C 0 # Init byte count + cmp A 63 # Single chunk? + if lt # Yes + push A # <S> Count + shl A 2 # Adjust to tag byte + call (PutBinBZ) # Output tag byte + do + call prByteCEXY # Output next data bye + sub (S) 1 # More? + until z # No + else + sub A 63 # Adjust count + push A # <S I> Count + ld A (* 4 63) # Output first tag byte + call (PutBinBZ) + push 63 # <S> and first 63 data bytes + do + call prByteCEXY # Output next data bye + sub (S) 1 # More? + until z # No + do + cmp (S I) 255 # Count greater or equal 255? + while ge # Yes + ld A 255 # Next chunk + ld (S) A # and the next 255 data bytes + call (PutBinBZ) # Output count byte + do + call prByteCEXY # Output next data bye + sub (S) 1 # More? + until z # No + sub (S I) 255 # Decrement counter + loop + pop A # Drop second count + ld A (S) # Retrieve count + call (PutBinBZ) # Output last count + do + sub (S) 1 # More? + while ge # Yes + call prByteCEXY # Output next data bye + loop + end + pop A # Drop count + pop Y + pop X + ret + end + sym E # Symbol? + if nz # Yes + cmp E Nil # NIL? + if eq # Yes + ld A NIX + jmp (PutBinBZ) # Output NIX + end + sym (E TAIL) # External symbol? + if nz # Yes + ld E (E TAIL) + call nameE_E # Get name + null (Extn) # External symbol offset? + if nz # Yes + ld A E # Get file number + shr A 24 # Lower 8 bits + ld C A # into C + and C (hex "FF") + shr A 12 # Upper 8 bits + and A (hex "FF00") + or A C + sub A (Extn) # Subtract external symbol offset + shl A 24 + ld C A # Lower result bits + shl A 12 + or A C + and A (hex "000FF000FF000000") # Mask file number + and E (hex "FFF00FFF00FFFFFF") # Mask object ID + or E A # Combine + end + shl E 2 # Strip status bits + shr E 6 # Normalize + ld C (+ 4 EXTERN) # Count significant bytes (adjusted to tag) + jmp prCntCE # Output external name + end + push X + push Y + ld X (E TAIL) + call nameX_X # Get name + zero X # Any? + if eq # No + ld A NIX + call (PutBinBZ) # Output NIX + else + ld Y Intern + call isInternEXY_F # Internal symbol? + ld C INTERN # Yes + ldnz C TRANSIENT # No + cnt X # Short name? + if nz # Yes + add C 4 # Count significant bytes (adjusted to tag) + ld E X # Get name + shr E 4 # Normalize + call prCntCE # Output internal or transient name + else # Long name + ld E X # Into E + ld A 8 # Count significant bytes + do + ld E (E BIG) # More cells? + cnt E + while z # Yes + add A 8 # Increment count + loop + shr E 4 # Any significant bits in short name? + if nz # Yes + do + add A 1 # Increment count + shr E 8 # More bytes? + until z # No + end + ld E A # Keep count in E + cmp A 63 # Single chunk? + if lt # Yes + shl A 2 # Adjust to tag byte + or A C # Combine with tag + call (PutBinBZ) # Output tag byte + ld C 0 + do + call symByteCX_FACX # Next data byte + call (PutBinBZ) # Output it + sub E 1 # More? + until z # No + else + ld A (* 4 63) # Output first tag byte + or A C # Combine with tag + call (PutBinBZ) + sub E 63 # Adjust count + push E # <S> Count + ld E 63 # and first 63 data bytes + ld C 0 + do + call symByteCX_FACX # Next data byte + call (PutBinBZ) # Output it + sub E 1 # More? + until z # No + do + cmp (S) 255 # Count greater or equal 255? + while ge # Yes + ld A 255 # Next chunk + ld E A # and the next 255 data bytes + call (PutBinBZ) # Output count byte + do + call symByteCX_FACX # Next data byte + call (PutBinBZ) # Output it + sub E 1 # More? + until z # No + sub (S) 255 # Decrement counter + loop + pop E # Retrieve count + ld A E + call (PutBinBZ) # Output last count + do + sub E 1 # More? + while ge # Yes + call symByteCX_FACX # Next data byte + call (PutBinBZ) # Output it + loop + end + end + end + pop Y + pop X + ret + end + push X + push Y + ld X E # Get expression + ld Y E # in X and Y + ld A BEG # Begin list + call (PutBinBZ) + do + ld E (X) # Next item + call binPrintEZ + ld X (X CDR) # More? + cmp X Nil + while ne # Yes + cmp X Y # Circular? + if eq # Yes + ld A DOT # Output dotted pair + call (PutBinBZ) + break T + end + atom X # End of list? + if nz # Yes + ld A DOT # Output dotted pair + call (PutBinBZ) + ld E X # Output atom + call binPrintEZ + pop Y # Return + pop X + ret + end + loop + pop Y + pop X + ld A END # End list + jmp (PutBinBZ) + +# Family IPC +(code 'putTellBZ 0) + ld (Z) B # Store byte + add Z 1 # Increment pointer + lea A ((TellBuf) (- PIPE_BUF 1)) # Reached (TellBuf + PIPE_BUF - 1)? + cmp Z A + jeq tellErr # Yes + ret + +(code 'tellBegZ_Z 0) + ld (TellBuf) Z # Set global buffer + add Z 2 # 2 bytes space for count + set (Z) BEG # Begin a list + add Z 1 + ret + +(code 'tellEndZ) + push X + push Y + set (Z) END # Close list + add Z 1 + ld X (TellBuf) # Get buffer + ld E Z # Calculate total size + sub E X + ld A E # Size in A + sub A 2 # without count + st2 (X) # Store in buffer count + push A # <S> Size + ld C (Tell) # File descriptor + null C # Any? + if nz # Yes + call wrBytesCEX_F # Write buffer to pipe + if nz # Not successful + cc close(C) # Close 'Tell' + ld (Tell) 0 # Clear 'Tell' + end + end + ld Y (Child) # Iterate children + ld Z (Children) # Count + do + sub Z VI # More? + while ge # Yes + null (Y) # 'pid'? + if nz # Yes + ld C (S) # Get size + lea X ((TellBuf) 2) # and data + call wrChildCXY # Write to child + end + add Y VI # Increment by sizeof(child) + loop + pop A # Drop size + pop Y + pop X + ret + +(code 'rdHear_FE) + push Z + ld A (Hear) # Get 'hear' fd + shl A 3 # Vector index + add A (InFiles) # Get vector + ld Z (A) # Input file + ld (GetBinZ_FB) getBinaryZ_FB # Set binary read function + ld (Extn) 0 # Set external symbol offset to zero + call binReadZ_FE # Read item + pop Z + ret + +# Return next byte from symbol name +(code 'symByteCX_FACX 0) + null C # New round? + if z # Yes + zero X # Done? + jeq ret # Yes: Return 'z' + cnt X # Short? + if nz # Yes + ld C X # Get short + shr C 4 # Normalize + ld X ZERO # Clear for next round + else + ld C (X DIG) # Get next digit + ld X (X BIG) + end + end + ld A C # Get byte + shr C 8 # Shift out + or B B # Return B + zxt + ret + +(code 'symCharCX_FACX 0) # Return next char from symbol name + call symByteCX_FACX # First byte + jz ret # Return 'z' if none + cmp B (hex "FF") # Special? + if ne # No + cmp B 128 # Single byte? + if ge # No + test B (hex "20") # Two bytes? + if z # Yes + and B (hex "1F") # First byte 110xxxxx + shl A 6 # xxxxx000000 + push A + else # Three bytes + and B (hex "F") # First byte 1110xxxx + shl A 6 # xxxx000000 + push A + call symByteCX_FACX # Second byte + and B (hex "3F") # 10xxxxxx + or A (S) # Combine + shl A 6 # xxxxxxxxxx000000 + ld (S) A + end + call symByteCX_FACX # Last byte + and B (hex "3F") # 10xxxxxx + or (S) A # Combine + pop A # Get result + end + ret + end + ld A TOP # Return special "top" character + or A A + ret + +(code 'bufStringE_SZ 0) + ld Z S # 8-byte-buffer + push (Z) # Save return address + push X # and X + cmp E Nil # Empty? + if ne # No + ld X (E TAIL) + call nameX_X # Get name + ld C 0 + do + call symByteCX_FACX + while nz + ld (Z) B # Store next byte + add Z 1 + test Z 7 # Buffer full? + if z # Yes + sub S 8 # Extend buffer + movm (S) (S 8) (Z) + sub Z 8 # Reset buffer pointer + end + loop + end + set (Z) 0 # Null byte + add Z 8 # Round up + off Z 7 + pop X + ret + +(code 'pathStringE_SZ 0) + ld Z S # 8-byte-buffer + push (Z) # Save return address + push X # and X + cmp E Nil # Empty? + if ne # No + ld X (E TAIL) + call nameX_X # Get name + ld C 0 + call symByteCX_FACX # First byte + if nz + cmp B (char "+") # Plus? + if eq + ld (Z) B # Store "+" + add Z 1 + call symByteCX_FACX # Second byte + end + cmp B (char "@") # Home path? + if ne + do + ld (Z) B # Store byte + add Z 1 + test Z 7 # Buffer full? + if z # Yes + sub S 8 # Extend buffer + movm (S) (S 8) (Z) + sub Z 8 # Reset buffer pointer + end + call symByteCX_FACX # Next byte? + until z # No + else + push E + ld E (Home) # Home directory? + null E + if nz # Yes + do + ld B (E) + ld (Z) B # Store next byte + add Z 1 + test Z 7 # Buffer full? + if z # Yes + sub S 8 # Extend buffer + movm (S) (S 8) (Z) + sub Z 8 # Reset buffer pointer + end + add E 1 + nul (E) # More? + until z # No + end + pop E + do + call symByteCX_FACX + while nz + ld (Z) B # Store next byte + add Z 1 + test Z 7 # Buffer full? + if z # Yes + sub S 8 # Extend buffer + movm (S) (S 8) (Z) + sub Z 8 # Reset buffer pointer + end + loop + end + end + end + set (Z) 0 # Null byte + add Z 8 # Round up + off Z 7 + pop X + ret + +# (path 'any) -> sym +(code 'doPath 2) + push Z + ld E ((E CDR)) # Get arg + call evSymE_E # Evaluate to a symbol + call pathStringE_SZ # Write to stack buffer + ld E S # Make transient symbol + call mkStrE_E + ld S Z # Drop buffer + pop Z + ret + +# Add next char to symbol name +(code 'charSymACX_CX 0) + cmp A (hex "80") # ASCII?? + jlt byteSymBCX_CX # Yes: 0xxxxxxx + cmp A (hex "800") # Double-byte? + if lt # Yes + push A # 110xxxxx 10xxxxxx + shr A 6 # Upper five bits + and B (hex "1F") + or B (hex "C0") + call byteSymBCX_CX # Add first byte + pop A + and B (hex "3F") # Lower 6 bits + or B (hex "80") + jmp byteSymBCX_CX # Add second byte + end + cmp A TOP # Special "top" character? + if eq # Yes + ld B (hex "FF") + jmp byteSymBCX_CX + end + push A # 1110xxxx 10xxxxxx 10xxxxxx + shr A 12 # Hightest four bits + and B (hex "0F") + or B (hex "E0") + call byteSymBCX_CX # Add first byte + ld A (S) + shr A 6 # Middle six bits + and B (hex "3F") + or B (hex "80") + call byteSymBCX_CX # Add second byte + pop A + and B (hex "3F") # Lowest 6 bits + or B (hex "80") # Add third byte + +# Add next byte to symbol name +(code 'byteSymBCX_CX 0) + zxt + big X # Long name? + if z # No: Direct buffer pointer + # 0000.xxxxxxx.xxxxxxx.xxxxxxx.xxxxxxx.xxxxxxx.xxxxxxx.xxxxxxx0010 + # 60 52 44 36 28 20 12 4 + cmp C 60 # Short digit full? + if ne # No + shl A C # Shift byte to character position + or (X) A # Combine with name digit + add C 8 # Increment position + ret + end + ld C (X) # Get short number + shr C 4 # De-normalize + shl A 56 # Combine byte with digit + or C A + call boxNum_A # Box number + ld (A DIG) C + ld (X) A + ld X A + ld C 4 # Start new digit + ret + end + cmp C 60 # Short digit full? + if ne # No + shl A C # Shift byte to character position + or (X BIG) A # Combine with name digit + add C 8 # Increment position + ret + end + ld C (X BIG) # Get short number + shr C 4 # De-normalize + shl A 56 # Combine byte with digit + or C A + call boxNum_A # Box number + ld (A DIG) C + ld (X BIG) A + ld X A + ld C 4 # Start new digit + ret + +(code 'currFdX_C 0) + ld C (EnvInFrames) # InFrames or OutFrames? + or C (EnvOutFrames) + jz noFdErrX # No +(code 'currFd_C) + ld C (EnvOutFrames) # OutFrames? + null C + if z # No + ld C (EnvInFrames) # Use InFrames + else + null (EnvInFrames) # InFrames? + if nz # Both + cmp C (EnvInFrames) # OutFrames > InFrames? + if gt # Yes + ld C (EnvInFrames) # Take InFrames + end + end + end + ld C (C I) # Get 'fd' + ret + +(code 'rdOpenEXY) + cmp E Nil # Standard input? + if eq # Yes + ld (Y I) 0 # fd = stdin + ld (Y II) 0 # pid = 0 + else + num E # Descriptor? + if nz # Yes + cnt E # Need short + jz cntErrEX + ld (Y II) 0 # pid = 0 + ld A E # Get fd + shr A 4 # Normalize + if c # Negative + ld C (EnvInFrames) # Fetch from input frames + do + ld C (C) # Next frame + null C # Any? + jz badFdErrEX # No + sub A 1 # Found frame? + until z # Yes + ld A (C I) # Get fd from frame + end + ld (Y I) A # Store 'fd' + shl A 3 # Vector index + cmp A (InFDs) # 'fd' >= 'InFDs'? + jge badFdErrEX # Yes + add A (InFiles) # Get vector + ld A (A) # Input file + null A # Any? + jz badFdErrEX # No + else + push Z + sym E # File name? + if nz # Yes + ld (Y II) 1 # pid = 1 + call pathStringE_SZ + do + ld B (S) # First char + cmp B (char "+") # Plus? + if eq # Yes + cc open(&(S 1) (| O_APPEND O_CREAT O_RDWR) (oct "0666")) + else + cc open(S O_RDONLY) + end + nul4 # OK? + while s # No + call errno_A + cmp A EINTR # Interrupted? + jne openErrEX # No + nul (Signal) # Signal? + if nz # Yes + call sighandlerX + end + loop + ld (Y I) A # Save 'fd' + ld B (S) # First char + cmp B (char "+") # Plus? + if eq # Yes + cc strdup(&(S 1)) # Duplicate name + else + cc strdup(S) # Duplicate name + end + ld C (Y I) # Get 'fd' + call initInFileCA_A + ld A (Y I) # Get fd + call closeOnExecAX + ld S Z # Drop buffer + else # Else pipe + push X + push 0 # End-of-buffers marker + ld X E # Get list + ld E (X) # Pathname + call xSymE_E # Make symbol + call pathStringE_SZ # Write to stack buffer + do + ld X (X CDR) # Arguments? + atom X + while z # Yes + push Z # Buffer chain + ld E (X) # Next argument + call xSymE_E # Make symbol + call bufStringE_SZ # Write to stack buffer + loop + push Z + ld Z S # Point to chain + ld X Z + push 0 # NULL terminator + do + lea A (X I) # Buffer pointer + push A # Push to vector + ld X (X) # Follow chain + null (X) # Done? + until z # Yes + ld X (X I) # Retrieve X + push A # Create 'pipe' structure + cc pipe(S) # Open pipe + nul4 # OK? + jnz pipeErrX + ld4 (S) # Get pfd[0] + call closeOnExecAX + ld4 (S 4) # Get pfd[1] + call closeOnExecAX + cc fork() # Fork child process + ld (Y II) A # Set 'pid' + nul4 # In child? + js forkErrX + if z # Yes + cc setpgid(0 0) # Set process group + ld4 (S) # Close read pipe + call closeAX + ld4 (S 4) # Get write pipe + cmp A 1 # STDOUT_FILENO? + if ne # No + cc dup2(A 1) # Dup to STDOUT_FILENO + ld4 (S 4) # Close write pipe + call closeAX + end + cc execvp((S 8) &(S 8)) # Execute program + jmp execErrS # Error if failed + end + cc setpgid(A 0) # Set process group + ld4 (S 4) # Close write pipe + call closeAX + ld4 (S) # Get read pipe + ld (Y I) A # Set 'fd' + call initInFileA_A + pop A # Drop 'pipe' structure + do + ld S Z # Clean up buffers + pop Z # Chain + null Z # End? + until z # Yes + pop X + end + pop Z + end + end + ret + +(code 'wrOpenEXY) + cmp E Nil # Standard output? + if eq # Yes + ld (Y I) 1 # fd = stdout + ld (Y II) 0 # pid = 0 + else + num E # Descriptor? + if nz # Yes + cnt E # Need short + jz cntErrEX + ld (Y II) 0 # pid = 0 + ld A E # Get fd + shr A 4 # Normalize + if c # Negative + ld C (EnvOutFrames) # Fetch from output frames + do + ld C (C) # Next frame + null C # Any? + jz badFdErrEX # No + sub A 1 # Found frame? + until z # Yes + ld A (C I) # Get fd from frame + end + ld (Y I) A # Store 'fd' + shl A 3 # Vector index + cmp A (OutFDs) # 'fd' >= 'OutFDs'? + jnc badFdErrEX # Yes + add A (OutFiles) # Get vector + ld A (A) # Slot? + null A # Any? + jz badFdErrEX # No + else + push Z + sym E # File name? + if nz # Yes + ld (Y II) 1 # pid = 1 + call pathStringE_SZ + do + ld B (S) # First char + cmp B (char "+") # Plus? + if eq # Yes + cc open(&(S 1) (| O_APPEND O_CREAT O_WRONLY) (oct "0666")) + else + cc open(S (| O_CREAT O_TRUNC O_WRONLY) (oct "0666")) + end + nul4 # OK? + while s # No + call errno_A + cmp A EINTR # Interrupted? + jne openErrEX # No + nul (Signal) # Signal? + if nz # Yes + call sighandlerX + end + loop + ld (Y I) A # Save 'fd' + call initOutFileA_A + ld A (Y I) # Get fd + call closeOnExecAX + ld S Z # Drop buffer + else # Else pipe + push X + push 0 # End-of-buffers marker + ld X E # Get list + ld E (X) # Pathname + call xSymE_E # Make symbol + call pathStringE_SZ # Write to stack buffer + do + ld X (X CDR) # Arguments? + atom X + while z # Yes + push Z # Buffer chain + ld E (X) # Next argument + call xSymE_E # Make symbol + call bufStringE_SZ # Write to stack buffer + loop + push Z + ld Z S # Point to chain + ld X Z + push 0 # NULL terminator + do + lea A (X I) # Buffer pointer + push A # Push to vector + ld X (X) # Follow chain + null (X) # Done? + until z # Yes + ld X (X I) # Retrieve X + push A # Create 'pipe' structure + cc pipe(S) # Open pipe + nul4 # OK? + jnz pipeErrX + ld4 (S) # Get pfd[0] + call closeOnExecAX + ld4 (S 4) # Get pfd[1] + call closeOnExecAX + cc fork() # Fork child process + ld (Y II) A # Set 'pid' + nul4 # In child? + js forkErrX + if z # Yes + cc setpgid(0 0) # Set process group + ld4 (S 4) # Close write pipe + call closeAX + ld4 (S) # Get read pipe + cmp A 0 # STDIN_FILENO? + if ne # No + cc dup2(A 0) # Dup to STDIN_FILENO + ld4 (S) # Close read pipe + call closeAX + end + cc execvp((S 8) &(S 8)) # Execute program + jmp execErrS # Error if failed + end + cc setpgid(A 0) # Set process group + ld4 (S) # Close read pipe + call closeAX + ld4 (S 4) # Get write pipe + ld (Y I) A # Set 'fd' + call initOutFileA_A + pop C # Drop 'pipe' structure + do + ld S Z # Clean up buffers + pop Z # Chain + null Z # End? + until z # Yes + pop X + end + pop Z + end + end + ret + +(code 'ctOpenEXY) + num E # Need symbol + jnz symErrEX + sym E + jz symErrEX + cmp E Nil # Shared lock on current I/O channel? + if eq # Yes + ld (Y I) -1 # 'fd' + call currFdX_C # Get current fd + call rdLockFileC + else + cmp E TSym # Exclusive lock on current I/O channel? + if eq # Yes + ld (Y I) -1 # 'fd' + call currFdX_C # Get current fd + call wrLockFileC + else + push Z + call pathStringE_SZ # File name + do + ld B (S) # First char + cmp B (char "+") # Plus? + if eq # Yes + cc open(&(S 1) (| O_CREAT O_RDWR) (oct "0666")) + else + cc open(S (| O_CREAT O_RDWR) (oct "0666")) + end + nul4 # OK? + while s # No + call errno_A + cmp A EINTR # Interrupted? + jne openErrEX # No + nul (Signal) # Signal? + if nz # Yes + call sighandlerX + end + loop + ld S Z # Drop buffer + pop Z + ld (Y I) A # Save 'fd' + ld C A # Keep in C + ld B (S) # First char + cmp B (char "+") # Plus? + if eq # Yes + call rdLockFileC # Read lock + else + call wrLockFileC # Write lock + end + ld A (Y I) # Get fd + call closeOnExecAX + end + end + ret + +(code 'getStdin_A 0) + push Z + ld Z (InFile) # Current InFile + null Z # Any? + if nz # Yes + cmp Z ((InFiles)) # On stdin? + if ne # No + ld A (Z I) # Get 'ix' + cmp A (Z II) # Equals 'cnt'? + if eq # Yes + call slowZ_F # Read into buffer + jz 90 # Return -1 + ld A 0 # 'ix' + end + add (Z I) 1 # Increment 'ix' + add A Z # Fetch byte + ld B (A VII) # from buffer + cmp B 10 # Newline? + if z # Yes + add (Z IV) 1 # Increment line + end + zxt # Extend into A + else + push C + push E + push X + atom (Led) # Line editor? + if nz # No + ld C 0 # Standard input + ld E -1 # No timeout + ld X 0 # Runtime expression + call waitFdCEX_A # Wait for events + call stdinByte_FA # Get byte? + if c # No + ld A -1 # Return -1 + end + else + ld C (LineC) + null C # First call? + if ns # No + ld X (LineX) # Get line status + else + ld E (Led) # Run line editor + call runE_E + cmp E Nil # NIL + if eq # Yes + ld X ZERO # Empty + else + ld X (E TAIL) + call nameX_X # Get name + end + ld C 0 + end + call symByteCX_FACX # Extract next byte + if z # None + ld A 10 # Default to linefeed + ld C -1 + end + ld (LineX) X # Save line status + ld (LineC) C + end + pop X + pop E + pop C + end + else +90 ld A -1 # Return EOF + end + ld (Chr) A + pop Z + ret + +(code 'getParse_A 0) + push C + push X + ld X (EnvParseX) # Get parser status + ld C (EnvParseC) + call symByteCX_FACX # Extract next byte + if z # Done + ld A (EnvParseEOF) # Yes + ld B (hex "FF") # Fill upper bits + ror A 8 # Get next eof byte in B + ld (EnvParseEOF) A + sxt # Extend B + end + ld (Chr) A + ld (EnvParseX) X # Save status + ld (EnvParseC) C + pop X + pop C + ret + +(code 'pushInFilesY) + ld A (InFile) # Current InFile? + null A + if nz # Yes + ld (A III) (Chr) # Save Chr in next + end + ld A (Y I) # Get 'fd' + shl A 3 # Vector index + add A (InFiles) # Get InFile + ld A (A) + ld (InFile) A # Store new + null A # Any? + if nz # Yes + ld A (A III) # Get 'next' + else + ld A -1 + end + ld (Chr) A # Save in 'Chr' + ld (Y III) (EnvGet_A) # Save 'get' + ld (EnvGet_A) getStdin_A # Set new + ld (Y) (EnvInFrames) # Set link + ld (EnvInFrames) Y # Link frame + ret + +(code 'pushOutFilesY) + ld A (Y I) # Get 'fd' + shl A 3 # Vector index + add A (OutFiles) # Get OutFile + ld (OutFile) (A) # Store new + ld (Y III) (EnvPutB) # Save 'put' + ld (EnvPutB) putStdoutB # Set new + ld (Y) (EnvOutFrames) # Set link + ld (EnvOutFrames) Y # Link frame + ret + +(code 'pushCtlFilesY) + ld (Y) (EnvCtlFrames) # Set link + ld (EnvCtlFrames) Y # Link frame + ret + +(code 'popInFiles) # C + ld C (EnvInFrames) # Get InFrames + null (C II) # 'pid'? + if nz # Yes + cc close((C I)) # Close 'fd' + ld A (C I) # Close input file + call closeInFileA + cmp (C II) 1 # 'pid' > 1? + if gt # Yes + do + cc waitpid((C II) 0 0) # Wait for pipe process + nul4 # OK? + while s # No + call errno_A + cmp A EINTR # Interrupted? + jne closeErrX + nul (Signal) # Signal? + if nz # Yes + call sighandler0 + end + loop + end + end + ld (EnvGet_A) (C III) # Retrieve 'get' + ld C (C) # Get link + ld (EnvInFrames) C # Restore InFrames + null C # Any? + if z # No + ld A ((InFiles)) # InFiles[0] (stdin) + else + ld A (C I) # Get 'fd' + shl A 3 # Vector index + add A (InFiles) + ld A (A) # Get previous InFile + end + ld (InFile) A # Set InFile + null A # Any? + if nz # Yes + ld A (A III) # Get 'next' + else + ld A -1 + end + ld (Chr) A # Save in 'Chr' + ret + +(code 'popOutFiles) # C + ld A (OutFile) # Flush OutFile + call flushA_F + ld C (EnvOutFrames) # Get OutFrames + null (C II) # 'pid'? + if nz # Yes + cc close((C I)) # Close 'fd' + ld A (C I) # Close input file + call closeOutFileA + cmp (C II) 1 # 'pid' > 1? + if gt # Yes + do + cc waitpid((C II) 0 0) # Wait for pipe process + nul4 # OK? + while s # No + call errno_A + cmp A EINTR # Interrupted? + jne closeErrX + nul (Signal) # Signal? + if nz # Yes + call sighandler0 + end + loop + end + end + ld (EnvPutB) (C III) # Retrieve 'put' + ld C (C) # Get link + ld (EnvOutFrames) C # Restore OutFrames + null C # Any? + if z # No + ld A ((OutFiles) I) # OutFiles[1] (stdout) + else + ld A (C I) # Get 'fd' + shl A 3 # Vector index + add A (OutFiles) + ld A (A) # Get previous OutFile + end + ld (OutFile) A # Set OutFile + ret + +(code 'popCtlFiles) # C + ld C (EnvCtlFrames) # Get CtlFrames + null (C I) # 'fd' >= 0? + if ns # Yes + cc close((C I)) # Close 'fd' + else + call currFd_C # Get current fd + ld A (| F_UNLCK (hex "00000")) # Unlock, length 0 + call unLockFileAC # Unlock + end + ld (EnvCtlFrames) ((EnvCtlFrames)) # Restore CtlFrames + ret + +# Get full char from input channel +(code 'getChar_A 0) + ld A (Chr) # Get look ahead + cmp B (hex "FF") # Special "top" character? + if ne # No + cmp B 128 # Single byte? + if ge # No + test B (hex "20") # Two bytes? + if z # Yes + and B (hex "1F") # First byte 110xxxxx + shl A 6 # xxxxx000000 + push A + else # Three bytes + and B (hex "F") # First byte 1110xxxx + shl A 6 # xxxx000000 + push A + call (EnvGet_A) # Get second byte + and B (hex "3F") # 10xxxxxx + or A (S) # Combine + shl A 6 # xxxxxxxxxx000000 + ld (S) A + end + call (EnvGet_A) # Get last byte + and B (hex "3F") # 10xxxxxx + or (S) A # Combine + pop A # Get result + end + ret + end + ld A TOP + ret + +# Skip White Space and Comments +(code 'skipC_A 0) + ld A (Chr) + do + null A # EOF? + while ns # No + do + cmp B 32 # White space? + while le # Yes + call (EnvGet_A) # Get next + null A # EOF? + js ret # Yes + loop + cmp A C # Comment char? + while eq # Yes + call (EnvGet_A) + cmp C (char "#") # Block comment? + jne 10 # No + cmp B (char "{") + if ne # No +10 do + cmp B 10 # Linefeed? + while ne #No + null A # EOF? + js ret # Yes + call (EnvGet_A) + loop + else # Block comment + do + call (EnvGet_A) + null A # EOF? + js ret # Yes + cmp B (char "}") # End of block comment? + if eq + call (EnvGet_A) + cmp B (char "#") + break eq # Yes + end + loop + end + call (EnvGet_A) + loop + ret + +(code 'testEscA_F 0) + do + null A # EOF? + if s # Yes + clrc # Return NO + ret + end + cmp B (char "\^") # Caret? + if eq # Yes + call (EnvGet_A) # Skip '^' + cmp B (char "?") # Question-mark? + if eq # Yes + ld B 127 # DEL + else + and B 31 # Control-character + end +10 setc # Return YES + ret + end + cmp B (char "\\") # Backslash? + jnz 10 # No + call (EnvGet_A) # Skip '\' + cmp B 10 # Newline? + jnz 10 # No + do + call (EnvGet_A) # Skip white space + cmp B 32 + continue eq + cmp B 9 + until ne + loop + +(code 'anonymousX_FE 0) + ld C 0 + call symByteCX_FACX # First byte + cmp B (char "$") # Starting with '$'? + jne Ret # No + call symByteCX_FACX # Second byte + cmp B (char "1") # >= '1'? + if ge # Yes + cmp B (char "7") # <= '7'? + if le # Yes + sub B (char "0") # Digit + ld E A # Calculate number + call symByteCX_FACX # Third byte + do + cmp B (char "0") # >= '0'? + while ge # Yes + cmp B (char "7") # <= '7'? + while le # Yes + shl E 3 # Times 8 + sub B (char "0") # Digit + add E A # Add to result + call symByteCX_FACX # Next byte? + if z # No + shl E 4 # Make symbol pointer + or E SYM + setz + ret + end + loop + end + end + ret + +(code 'rdAtomBYL_E) # X + ld C 4 # Build name + lea X (L I) # Safe + call byteSymBCX_CX # Pack first char + ld A Y # Get second + do + null A # EOF? + while ns # No + memb Delim "(DelimEnd-Delim)" # Delimiter? + jeq 10 # Yes + cmp B (char "\\") # Backslash? + if eq # Yes + call (EnvGet_A) # Get next char + end + call byteSymBCX_CX # Pack char + call (EnvGet_A) # Get next + loop +10 ld X (L I) # Get name + ld A (Scl) # Scale + shr A 4 # Normalize + ld (Sep3) 0 # Thousand separator + ld (Sep0) (char ".") # Decimal separator + call symToNumXA_FE # Legal number? + if nc # No + ld X (L I) # Get name + call anonymousX_FE # Anonymous symbol? + if ne # No + ld X (L I) # Get name + call findSymX_E # Find or create symbol + end + end + ret +: Delim ascii " \\t\\n\\r\\\"'(),[]`~{}" +: DelimEnd + +(code 'rdList_E) + call (EnvGet_A) # Skip paren + do + ld C (char "#") + call skipC_A # and white space + cmp B (char ")") # Empty list? + if eq # Yes + call (EnvGet_A) # Skip paren + ld E Nil # Return NIL + ret + end + cmp B (char "]") # Empty list? + jz retNil # Yes + cmp B (char "~") # Tilde? + if ne # No + ld A 0 + call readA_E # Read expression + call consE_A # Make a pair + ld (A) E + ld (A CDR) Nil + link + push A # <L I> Save it + link + ld E A # Keep last cell in E + jmp 10 # Exit + end + call (EnvGet_A) # Skip tilde + ld A 0 + call readA_E # Read expression + link + push E # <L I> Save it + link + eval # Evaluate + ld (L I) E # Save again + atom E # Pair? + if z # Yes + do + atom (E CDR) # Find last cell + while z + ld E (E CDR) + loop + jmp 10 # Exit + end + drop # Continue + loop +10 do + ld C (char "#") + call skipC_A # Skip white space + cmp B (char ")") # Done? + if eq # Yes + call (EnvGet_A) # Skip paren + jmp 90 # Done + end + cmp B (char "]") # Done? + jz 90 # Yes + cmp B (char ".") # Dotted pair? + if eq # Yes + call (EnvGet_A) # Skip dot + memb Delim "(DelimEnd-Delim)" # Delimiter? + if eq # Yes + ld C (char "#") + call skipC_A # and white space + cmp B (char ")") # Circular list? + jz 20 # Yes + cmp B (char "]") + if eq # Yes +20 ld (E CDR) (L I) # Store list in CDR + else + push E + ld A 0 + call readA_E # Read expression + ld A E + pop E + ld (E CDR) A # Store in CDR + end + ld C (char "#") + call skipC_A # Skip white space + cmp B (char ")") # Done? + if eq # Yes + call (EnvGet_A) # Skip paren + jmp 90 # Done + end + cmp B (char "]") + jz 90 # Done + ld E (L I) # Else bad dottet pair + jmp badDotErrE + end + push X + push Y + link + push ZERO # <L I> Safe + link + push E + ld Y A # Save first char + ld B (char ".") # Restore dot + call rdAtomBYL_E # Read atom + call consE_A # Make a pair + ld (A) E + ld (A CDR) Nil + pop E + ld (E CDR) A # Store in last cell + ld E A + drop + pop Y + pop X + else + cmp B (char "~") # Tilde? + if ne # No + push E + ld A 0 + call readA_E # Read expression + call consE_A # Make a pair + ld (A) E + ld (A CDR) Nil + pop E + ld (E CDR) A # Store in last cell + ld E A + else + call (EnvGet_A) # Skip tilde + push E + ld A 0 + call readA_E # Read expression + ld A (S) + ld (A CDR) E # Save in last cell + eval # Evaluate + pop A + ld (A CDR) E # Store in last cell + ld E A + do + atom (E CDR) # Pair? + while z # Yes + ld E (E CDR) # Find last cell + loop + end + end + loop +90 ld E (L I) # Return list + drop + ret + +(code 'readA_E) + push X + push Y + link + push ZERO # <L I> Safe + link + push A # <L -I> Top flag + ld C (char "#") + call skipC_A + null A # EOF? + if s # Yes + null (L -I) # Top? + jz eofErr # No: Error + ld E Nil # Yes: Return NIL + jmp 99 + end + null (L -I) # Top? + if nz # Yes + ld C (InFile) # And reading file? + null C + if nz # Yes + ld (C V) (C IV) # src = line + end + end + cmp B (char "(") # Opening a list? + if eq # Yes + call rdList_E # Read it + null (L -I) # Top? + if nz # Yes + cmp (Chr) (char "]") # And super-parentheses? + if eq # Yes + call (EnvGet_A) # Skip ']' + end + end + jmp 99 # Return list + end + cmp B (char "[") # Opening super-list? + if eq # Yes + call rdList_E # Read it + cmp (Chr) (char "]") # Matching super-parentheses? + jnz suparErrE # Yes: Error + call (EnvGet_A) # Else skip ']' + jmp 99 + end + cmp B (char "'") # Quote? + if eq # Yes + call (EnvGet_A) # Skip "'" + ld A 0 + call readA_E # Read expression + ld C E + call consC_E # Cons with 'quote' + ld (E) Quote + ld (E CDR) C + jmp 99 + end + cmp B (char ",") # Comma? + if eq # Yes + call (EnvGet_A) # Skip ',' + ld A 0 + call readA_E # Read expression + ld (L I) E # Save it + ld X Uni # Maintain '*Uni' index + ld Y E + call idxPutXY_E + atom E # Pair? + if z # Yes + ld E (E) # Return index entry + else + ld E Y # 'read' value + end + jmp 99 + end + cmp B (char "`") # Backquote? + if eq # Yes + call (EnvGet_A) # Skip '`' + ld A 0 + call readA_E # Read expression + ld (L I) E # Save it + eval # Evaluate + jmp 99 + end + cmp B (char "\"") # String? + if eq # Yes + call (EnvGet_A) # Skip '"' + cmp B (char "\"") # Empty string? + if eq # Yes + call (EnvGet_A) # Skip '"' + ld E Nil # Return NIL + jmp 99 + end + call testEscA_F + jnc eofErr + ld C 4 # Build name + lea X (L I) # Safe + do + call byteSymBCX_CX # Pack char + call (EnvGet_A) # Get next + cmp B (char "\"") # Done? + while ne + call testEscA_F + jnc eofErr + loop + call (EnvGet_A) # Skip '"' + ld X (L I) # Get name + ld Y Transient + ld E 0 # No symbol yet + call internEXY_FE # Check transient symbol + jmp 99 + end + cmp B (char "{") # External symbol? + if eq # Yes + call (EnvGet_A) # Skip '{' + cmp B (char "}") # Empty? + if eq # Yes + call (EnvGet_A) # Skip '}' + call cons_E # New symbol + ld (E) ZERO # anonymous + or E SYM + ld (E) Nil # Set to NIL + jmp 99 + end + ld E 0 # Init file number + do + cmp B (char "@") # File done? + while ge # No + cmp B (char "O") # In A-O range? + jgt badInputErrB # Yes + sub B (char "@") + shl E 4 # Add to file number + add E A + call (EnvGet_A) # Get next char + loop + cmp B (char "0") # Octal digit? + jlt badInputErrB + cmp B (char "7") + jgt badInputErrB # No + sub B (char "0") + zxt + ld C A # Init object ID + do + call (EnvGet_A) # Get next char + cmp B (char "}") # Done? + while ne # No + cmp B (char "0") # Octal digit? + jlt badInputErrB + cmp B (char "7") + jgt badInputErrB # No + sub B (char "0") + shl C 3 # Add to object ID + add C A + loop + call (EnvGet_A) # Skip '}' + call extNmCE_X # Build external symbol name + call externX_E # New external symbol + jmp 99 + end + cmp B (char ")") # Closing paren? + jeq badInputErrB # Yes + cmp B (char "]") + jeq badInputErrB + cmp B (char "~") # Tilde? + jeq badInputErrB # Yes + cmp B (char "\\") # Backslash? + if eq # Yes + call (EnvGet_A) # Get next char + end + ld Y A # Save in Y + call (EnvGet_A) # Next char + xchg A Y # Get first char + call rdAtomBYL_E # Read atom +99 drop + pop Y + pop X + ret + +(code 'readC_E) + null (Chr) # Empty channel? + if z # Yes + call (EnvGet_A) # Fill 'Chr' + end + cmp C (Chr) # Terminator? + if eq # Yes + ld E Nil # Return 'NIL' + else + ld A 1 # Top level + call readA_E # Read expression + push E + ld A (Chr) + do + null A # EOF? + while nsz # No + cmp B 32 # Space? + jz 10 + cmp B 9 # Tab? + jz 10 + cmp B (char ")") # or closing parens? + jz 10 + cmp B (char "]") + while eq # Yes +10 call (EnvGet_A) + loop + pop E + end + ret + +(code 'tokenCE_E) # X + null (Chr) # Look ahead char? + if z # No + call (EnvGet_A) # Get next + end + call skipC_A # Skip white space and comments + null A # EOF? + js retNull # Yes + cmp B (char "\"") # String? + if eq # Yes + call (EnvGet_A) # Skip '"' + cmp B (char "\"") # Empty string? + if eq # Yes + call (EnvGet_A) # Skip '"' + ld E Nil # Return NIL + ret + end + call testEscA_F + jnc retNil + link + push ZERO # <L I> Result + ld C 4 # Build name + ld X S + link + do + call byteSymBCX_CX # Pack char + call (EnvGet_A) # Get next + cmp B (char "\"") # Done? + if eq # Yes + call (EnvGet_A) # Skip '"' + break T + end + call testEscA_F + until nc + ld X (L I) # Get name + drop + jmp consSymX_E # Make transient symbol + end + cmp B (char "0") # Digit? + if ge + cmp B (char "9") + if le # Yes + link + push ZERO # <L I> Result + ld C 4 # Build digit string + ld X S + link + do + call byteSymBCX_CX # Pack char + call (EnvGet_A) # Get next + cmp B (char ".") # Dot? + continue eq # Yes + cmp B (char "0") # Or digit? + while ge + cmp B (char "9") + until gt # No + ld X (L I) # Get name + ld A (Scl) # Scale + shr A 4 # Normalize + drop + ld (Sep3) 0 # Thousand separator + ld (Sep0) (char ".") # Decimal separator + jmp symToNumXA_FE # Convert to number + end + end + push Y + push Z + ld Y A # Keep char in Y + call bufStringE_SZ # <S I/IV> Stack buffer + push A # <S /III> String length + slen (S) (S I) + ld A Y # Restore char + cmp B (char "a") # Lower case letter? + if ge + cmp B (char "z") + jle 10 # Yes + end + cmp B (char "A") # Upper case letter? + if ge + cmp B (char "Z") + jle 10 # Yes + end + cmp B (char "\\") # Backslash? + if eq # Yes + call (EnvGet_A) # Use next char + jmp 10 + end + memb (S I) (S) # Member of character set? + if eq # Yes +10 link + push ZERO # <L I> Result + ld C 4 # Build name + ld X S + link + do + call byteSymBCX_CX # Pack char + call (EnvGet_A) # Get next + cmp B (char "a") # Lower case letter? + if ge + cmp B (char "z") + continue le # Yes + end + cmp B (char "A") # Upper case letter? + if ge + cmp B (char "Z") + continue le # Yes + end + cmp B (char "0") # Digit? + if ge + cmp B (char "9") + continue le # Yes + end + cmp B (char "\\") # Backslash? + if eq # Yes + call (EnvGet_A) # Use next char + continue T + end + memb (S IV) (S III) # Member of character set? + until ne # No + ld X (L I) # Get name + call findSymX_E # Find or create symbol + drop + else + call getChar_A + call mkCharA_A # Return char + ld E A + call (EnvGet_A) # Skip it + end + ld S Z # Drop buffer + pop Z + pop Y + ret + +# (read ['sym1 ['sym2]]) -> any +(code 'doRead 2) + atom (E CDR) # Arg? + if nz # No + ld C 0 # No terminator + call readC_E # Read item + else + push X + ld X (E CDR) # Args + ld E (X) # Eval 'sym1' + eval + sym E # Need symbol + jz symErrEX + link + push E # <L I> Safe + link + ld E ((X CDR)) # Eval 'sym2' + eval + sym E # Need symbol + jz symErrEX + call firstCharE_A # Get first character + ld C A # as comment char + ld E (L I) # Get Set of characters + call tokenCE_E # Read token + null E # Any? + ldz E Nil # No + drop + pop X + end + cmp (Chr) 10 # Hit linefeed? + if eq # Yes + cmp (InFile) ((InFiles)) # Current InFile on stdin? + if eq # Yes + ld (Chr) 0 # Clear it + end + end + ret + +# Check if input channel has data +(code 'inFilesA_FC 0) + ld C A + shl C 3 # Vector index + add C (InFiles) # Get vector + ld C (C) # Slot? + null C # Any? + ret + +(code 'inReadyC_F 0) + cmp (C I) (C II) # 'ix' < 'cnt'? + ret # Yes: 'nz' + +(code 'inReadyA_FC 0) + ld C A + shl C 3 # Vector index + cmp C (InFDs) # 'fd' >= 'InFDs'? + jge ret # No + add C (InFiles) # Get vector + ld C (C) # Slot? + null C # Any? + jz retnc # No + cmp (C I) (C II) # 'ix' < 'cnt'? + ret # Yes: Return 'c' + +(code 'rdSetRdyASL_F 0) # Z + ld C A + shl C 3 # Vector index + cmp C (InFDs) # 'fd' >= 'InFDs'? + jge rdSetASL_F # Yes + add C (InFiles) # Get vector + ld C (C) # Slot? + null C # Any? + jz rdSetASL_F # No + call inReadyC_F # Data in buffer? + if z # No + lea Z (L -III) # Beyond last 'poll' structure + do + sub Z POLLFD # Next structure + cmp Z S # More structures? + jle retz # No: 'z' + cmp4 (Z) # Found 'fd'? + until eq # Yes + ld2 (Z POLL_REVENTS) # 'revents' + test A (| POLLIN POLLHUP) # Ready? + if nz # Yes + call slowNbC_FA # Try non-blocking read + jge retnz + setz + end + end + ret + +(code 'rdSetASL_F 0) # Z + lea Z (L -III) # Beyond last 'poll' structure + do + sub Z POLLFD # Next structure + cmp Z S # More structures? + jle retz # No: 'z' + cmp4 (Z) # Found 'fd'? + until eq # Yes + ld2 (Z POLL_REVENTS) # 'revents' + test A (| POLLIN POLLHUP) # Ready? + ret # Return 'nz' + +(code 'wrSetASL_F 0) # Z + lea Z (L -III) # Beyond last 'poll' structure + do + sub Z POLLFD # Next structure + cmp Z S # More structures? + jle retz # No: 'z' + cmp4 (Z) # Found 'fd'? + until eq # Yes + ld2 (Z POLL_REVENTS) # 'revents' + test A POLLOUT # Ready? + ret # Return 'nz' + +(code 'waitFdCEX_A) + push Y + push Z + push (EnvTask) # <L IV> Save task list + link + push (At) # <L II> '@' + push ZERO # <L I> '*Run' + link + push C # <L -I> File descriptor + push E # <L -II> Milliseconds + push E # <L -III> Timeout + do + ld Z 0 # Structure count + ld A (L -I) # File descriptor + null A # Positive? + if ns # Yes + call inReadyA_FC # Ready? + if c # Yes + ld (L -III) 0 # Timeout = 0 + else + sub S POLLFD # Create 'poll' structure + st4 (S) # Store 'fd' + ld A POLLIN # Poll input + st2 (S POLL_EVENTS) # Store 'events' + add Z 1 # Increment count + end + end + ld Y (Run) # Get '*Run' + ld (L I) Y # Save it + ld (EnvTask) Y + do + atom Y # '*Run' elements? + while z # Yes + ld E (Y) # Next element + ld A (L IV) # memq in saved tasklist? + do + atom A # End of tasklist? + while z # No + cmp E (A) # Member? + jeq 10 # Yes: Skip + ld A (A CDR) + loop + ld A (E) # Get fd or timeout value + shr A 4 # Negative? + if c # Yes + ld A ((E CDR)) # Get CADR + shr A 4 # Normalize + cmp A (L -III) # Less than current timeout? + if lt # Yes + ld (L -III) A # Set new timeout + end + else + cmp A (L -I) # Different from argument-fd? + if ne # Yes + call inReadyA_FC # Ready? + if c # Yes + ld (L -III) 0 # Timeout = 0 + else + sub S POLLFD # Create 'poll' structure + st4 (S) # Store 'fd' + ld A POLLIN # Poll input + st2 (S POLL_EVENTS) # Store 'events' + add Z 1 # Increment count + end + end + end +10 ld Y (Y CDR) + loop + ld A (Hear) # RPC listener? + null A + if nz # Yes + cmp A (L -I) # Different from argument-fd? + if ne # Yes + call inFilesA_FC # Still open? + if nz # Yes + call inReadyC_F # Data in buffer? + if nz # Yes + ld (L -III) 0 # Timeout = 0 + else + sub S POLLFD # Create 'poll' structure + st4 (S) # Store 'Hear' + ld A POLLIN # Poll input + st2 (S POLL_EVENTS) # Store 'events' + add Z 1 # Increment count + end + end + end + end + ld A (Spkr) # Speaker open? + null A + if nz # Yes + sub S POLLFD # Create 'poll' structure + st4 (S) # Store 'Spkr' + ld A POLLIN # Poll input + st2 (S POLL_EVENTS) # Store 'events' + add Z 1 # Increment count + end + ld Y (Child) # Iterate children + ld E (Children) # Count + do + sub E VI # More? + while ge # Yes + null (Y) # 'pid'? + if nz # Yes + sub S POLLFD # Create 'poll' structure + ld A (Y I) # Store child's 'hear' fd + st4 (S) + ld A POLLIN # Poll input + st2 (S POLL_EVENTS) # Store 'events' + add Z 1 # Increment count + null (Y IV) # Child's buffer count? + if nz # Yes + sub S POLLFD # Create 'poll' structure + ld A (Y II) # Store child's 'tell' fd + st4 (S) + ld A POLLOUT # Poll output + st2 (S POLL_EVENTS) # Store 'events' + add Z 1 # Increment count + end + end + add Y VI # Increment by sizeof(child) + loop + call msec_A # Get milliseconds + ld E A # into E + do + cc poll(S Z (L -III)) # Wait for event or timeout + nul4 # OK? + while s # No + call errno_A + cmp A EINTR # Interrupted? + if ne # No + ld (Run) Nil # Clear '*Run' + jmp selectErrX + end + nul (Signal) # Signal? + if nz # Yes + call sighandlerX + end + loop + call msec_A # Get milliseconds + sub A E # Time difference + ld (L -III) A # Save it + set (Flg) 0 # Guarantee flushed pipes + ld Y (Child) # Iterate children + ld Z (Children) # Count + push X # Save context + do + sub Z VI # More? + while ge # Yes + null (Y) # 'pid'? + if nz # Yes + push Z # Outer loop count + ld A (Y I) # Get child's 'hear' fd + call rdSetASL_F # Ready? + if nz # Yes + ld C (Y I) # Get 'hear' fd again + ld E 2 # Size of count + ld X Buf # Buffer pointer + call rdBytesNbCEX_F # Read count + if ns # Greater or equal zero + if z + call clsChildY # Close child + pop Z + continue T + end + sub S PIPE_BUF # <S II> Pipe buffer + push Y # <S> Outer child index + ld C (Y I) # Get 'hear' fd again + ld2 (Buf) # Get size + ld E A + lea X (S II) # Buffer pointer + call rdBytesCEX_F # Read data? + if nz # Yes + set (Flg) 1 # Still got data from pipe + ld Y (Child) # Iterate children + ld Z (Children) # Count + do + cmp Y (S) # Same as outer loop child? + if ne # No + null (Y) # 'pid'? + if nz # Yes + ld2 (Buf) # Get size + ld C A + lea X (S II) # and data + call wrChildCXY # Write to child + end + end + add Y VI # Increment by sizeof(child) + sub Z VI # More? + until z # No + else + call clsChildY # Close child + pop Y + add S PIPE_BUF # Drop 'tell' buffer + pop Z + continue T + end + pop Y + add S PIPE_BUF # Drop 'tell' buffer + end + end + ld A (Y II) # Get child's 'tell' fd + call wrSetASL_F # Ready? + if nz # Yes + ld C (Y II) # Get 'tell' fd again + ld X (Y V) # Get buffer pointer + add X (Y III) # plus buffer offset + ld2 (X) # Get size + ld E A + add X 2 # Point to data (beyond size) + push E # Keep size + call wrBytesCEX_F # Write data? + pop E + if z # Yes + add E (Y III) # Add size to buffer offset + add E 2 # plus size of size + ld (Y III) E # New buffer offset + add E E # Twice the offset + cmp E (Y IV) # greater or equal to buffer count? + if ge # Yes + sub (Y IV) (Y III) # Decrement count by offset + if nz + ld X (Y V) # Get buffer pointer + add X (Y III) # Add buffer offset + movn ((Y V)) (X) (Y IV) # Copy data + ld A (Y V) # Get buffer pointer + ld E (Y IV) # and new count + call allocAE_A # Shrink buffer + ld (Y V) A # Store + end + end + ld (Y III) 0 # Clear buffer offset + else + call clsChildY # Close child + end + end + pop Z + end + add Y VI # Increment by sizeof(child) + loop + nul (Flg) # All pipes flushed? + if z # Yes + ld A (Spkr) # Speaker open? + null A + if nz # Yes + call rdSetASL_F # Ready? + if nz # Yes + ld C (Spkr) # Get fd + ld E I # Size of slot + ld X Buf # Buffer pointer + call rdBytesNbCEX_F # Read slot? + if nsz # Yes + ld Y (Child) # Get child + add Y (Buf) # in slot + null (Y) # 'pid'? + if nz # Yes + ld C 2 # Size of 'TBuf' + ld X TBuf # Buffer pointer + call wrChildCXY # Write to child + end + end + end + end + end + ld A (Hear) # RPC listener? + null A + if nz # Yes + cmp A (L -I) # Different from argument-fd? + if ne # Yes + call rdSetRdyASL_F # Ready? + if nz # Yes + call rdHear_FE # Read expression? + if nc # Yes + cmp E TSym # Read 'T'? + if eq # Yes + set (Sync) 1 # Set sync flag + else + link + push E # Save expression + link + call evListE_E # Execute it + drop + end + else + call closeAX # Close 'Hear' + ld A (Hear) + call closeInFileA + ld A (Hear) + call closeOutFileA + ld (Hear) 0 # Clear value + end + end + end + end + ld Y (L I) # Get '*Run' + do + atom Y # More elements? + while z # Yes + ld E (Y) # Next element + ld A (L IV) # memq in saved tasklist? + do + atom A # End of tasklist? + while z # No + cmp E (A) # Member? + jeq 20 # Yes: Skip + ld A (A CDR) + loop + ld A (E) # Get fd or timeout value + shr A 4 # Negative? + if c # Yes + ld C (E CDR) # Get CDR + ld A (C) # and CADR + shr A 4 # Normalize + sub A (L -III) # Subtract time difference + if nc # Not yet timed out + shl A 4 # Make short number + or A CNT + ld (C) A # Store in '*Run' + else # Timed out + ld A (E) # Timeout value + ld (C) A # Store in '*Run' + ld (At) (E) # Set to CAR + ld Z (C CDR) # Run body + prog Z + end + else + cmp A (L -I) # Different from argument-fd? + if ne # Yes + call rdSetRdyASL_F # Ready? + if nz # Yes + ld (At) (E) # Set to fd + ld Z (E CDR) # Run body + prog Z + end + end + end +20 ld Y (Y CDR) + loop + pop X # Restore context + nul (Signal) # Signal? + if nz # Yes + call sighandlerX + end + ld A (L -II) # Milliseconds + or A A + if nsz # Greater zero + sub A (L -III) # Subtract time difference + if s # < 0 + xor A A # Set to zero, 'z' + end + ld (L -II) A + end + while nz # Milliseconds non-zero + ld (L -III) A # Set timeout + ld A (L -I) # File descriptor + null A # Positive? + while ns # Yes + call rdSetRdyASL_F # Ready? + while z # No + lea S (L -III) # Drop 'poll' structures + loop + ld (At) (L II) # Restore '@' + ld A (L -II) # Return milliseconds + drop + pop (EnvTask) + pop Z + pop Y + ret + +# (wait ['cnt] . prg) -> any +(code 'doWait 2) + push X + push Y + push Z + ld X E + ld Y (E CDR) # Y on args + ld E (Y) # Eval 'cnt' + eval + cmp E Nil # None? + if eq # Yes + push -1 # Wait infinite + else + call xCntEX_FE # Get 'cnt' + push E # <S> Milliseconds + end + ld Y (Y CDR) # Y on 'prg' + do + ld Z Y # Run 'prg' + prog Z + cmp E Nil # NIL? + while eq # Yes + ld C -1 # No file descriptor + ld E (S) # Milliseconds + call waitFdCEX_A # Wait for events + null A # Timeout? + if z # Yes + prog Y # Run 'prg' + break T + end + ld (S) A # New milliseconds + loop + pop A # Drop milliseconds + pop Z + pop Y + pop X + ret + +# (sync) -> flg +(code 'doSync 2) + null (Mic) # No 'mic' channel? + jz retNil # Yes + null (Hear) # No 'hear' channel? + jz retNil # Yes + push X + ld X E + ld E Slot # Buffer pointer + ld C I # Count + do + cc write((Mic) E C) # Write 'Slot' to 'Mic' + nul4 # OK? + if ns # Yes + sub C A # Decrement count + break z # Done + add E A # Increment buffer pointer + else + call errno_A + cmp A EINTR # Interrupted? + jne wrSyncErrX # No + end + nul (Signal) # Signal? + if nz # Yes + call sighandlerX + end + loop + set (Sync) 0 # Clear sync flag + do + ld C -1 # No fd + ld E C # Wait infinite + call waitFdCEX_A # Wait for events + nul (Sync) # Synchronized? + until nz # Yes + ld E TSym # Return T + pop X + ret + +# (hear 'cnt) -> cnt +(code 'doHear 2) + push X + ld X E + ld E ((E CDR)) # E on arg + eval # Eval it + cnt E # # Short number? + jz cntErrEX # No + ld C E # Get fd + shr C 4 # Normalize + jc badFdErrEX # Negative + ld A C # Keep 'fd' in C + shl A 3 # Vector index + cmp A (InFDs) # 'fd' >= 'InFDs'? + jge badFdErrEX # Yes + add A (InFiles) # Get vector + ld A (A) # Slot? + null A # Any? + jz badFdErrEX # No + ld A (Hear) # Current value? + null A + if nz # Yes + call closeAX # Close 'Hear' + ld A (Hear) + call closeInFileA + ld A (Hear) + call closeOutFileA + end + ld (Hear) C # Set new value + pop X + ret + +# (tell 'sym ['any ..]) -> any +(code 'doTell 2) + ld A (Tell) # RPC? + or A (Children) + jz retNil # No + push X + push Y + push Z + push (TellBuf) # Save current 'tell' env + sub S PIPE_BUF # New 'tell' buffer + ld Z S # Buffer pointer + call tellBegZ_Z # Start 'tell' message + ld X (E CDR) # Args + do + ld E (X) # Eval next + eval + ld Y E # Keep result + call prTellEZ # Print to 'tell' + ld X (X CDR) # More args? + atom X + until nz # No + call tellEndZ # Close 'tell' + ld E Y # Get result + add S PIPE_BUF # Drop 'tell' buffer + pop (TellBuf) + pop Z + pop Y + pop X + ret + +# (poll 'cnt) -> cnt | NIL +(code 'doPoll 2) + push X + ld X E + ld E ((E CDR)) # E on arg + eval # Eval it + ld A E # Keep + call xCntEX_FE # Get fd + xchg A E + null A # fd < 0? + js badFdErrEX # Yes + ld C A + shl C 3 # Vector index + cmp C (InFDs) # 'fd' >= 'InFDs'? + jge badFdErrEX # Yes + call inFilesA_FC # Readable input file? + ldz E Nil # No: Return NIL + if nz + do + call inReadyC_F # Data in buffer? + while z # No + sub S POLLFD # Create 'poll' structure + st4 (S) # Store 'fd' + ld A POLLIN # Poll input + st2 (S POLL_EVENTS) # Store 'events' + do + cc poll(S 1 0) # Check + nul4 # OK? + while s # No + call errno_A + cmp A EINTR # Interrupted? + if ne # No + ld (Run) Nil # Clear '*Run' + jmp selectErrX + end + loop + ld2 (S POLL_REVENTS) # 'revents' + add S POLLFD # Drop 'poll' structure + test A (| POLLIN POLLHUP) # Ready? + ldz E Nil # No: Return NIL + while nz + call slowNbC_FA # Try non-blocking read + until ge + end + pop X + ret + +# (key ['cnt]) -> sym +(code 'doKey 2) + push X + ld X E + ld E ((E CDR)) # E on arg + eval # Eval it + cmp E Nil # None? + if eq # Yes + ld E -1 # Wait infinite + else + call xCntEX_FE # Get milliseconds + end + call flushAll # Flush all output channels + call setRaw # Set terminal to raw mode + ld C 0 # Standard input + call waitFdCEX_A # Wait for events + null A # Timeout? + if nz # No + call stdinByte_FA # First byte? + if nc # Yes + cmp B (hex "FF") # Special "top" character? + if ne # No + cmp B 128 # Single byte? + if ge # No + test B (hex "20") # Two bytes? + if z # Yes + and B (hex "1F") # First byte 110xxxxx + shl A 6 # xxxxx000000 + push A + else # Three bytes + and B (hex "F") # First byte 1110xxxx + shl A 6 # xxxx000000 + push A + call stdinByte_FA # Read second byte + and B (hex "3F") # 10xxxxxx + or A (S) # Combine + shl A 6 # xxxxxxxxxx000000 + ld (S) A + end + call stdinByte_FA # Read last byte + and B (hex "3F") # 10xxxxxx + or (S) A # Combine + pop A # Get result + end + else + ld A TOP + end + call mkCharA_A # Return char + ld E A + pop X + ret + end + end + ld E Nil + pop X + ret + +# (peek) -> sym +(code 'doPeek 2) + ld A (Chr) # Look ahead char? + null A + if z # No + call (EnvGet_A) # Get next + end + null A # EOF? + js retNil # Yes + call mkCharA_A # Return char + ld E A + ret + +# (char) -> sym +# (char 'cnt) -> sym +# (char T) -> sym +# (char 'sym) -> cnt +(code 'doChar 2) + push X + ld X E + ld E (E CDR) # Any args? + atom E + if nz # No + ld A (Chr) # Look ahead char? + null A + if z # No + call (EnvGet_A) # Get next + end + null A # EOF? + if ns # No + call getChar_A + call mkCharA_A # Make char + ld E A + call (EnvGet_A) # Get next + else + ld E Nil + end + pop X + ret + end + ld E (E) + eval # Eval arg + cnt E # 'cnt'? + if nz # Yes + ld A E # Get 'cnt' + shr A 4 # Normalize + if nz + call mkCharA_A # Make char + ld E A + else + ld E Nil + end + pop X + ret + end + sym E # 'sym'? + jz atomErrEX # No + cmp E TSym # T? + if ne + call firstCharE_A + shl A 4 # Make short number + or A CNT + else + ld A TOP # Special "top" character + call mkCharA_A + end + ld E A + pop X + ret + +# (skip ['any]) -> sym +(code 'doSkip 2) + ld E ((E CDR)) # Get arg + call evSymE_E # Evaluate to a symbol + call firstCharE_A # Get first character + ld C A # Use as comment char + call skipC_A # Skip white space and comments + null A # EOF? + js retNil # Yes + ld A (Chr) # Return 'Chr' + call mkCharA_A # Return char + ld E A + ret + +# (eol) -> flg +(code 'doEol 2) + cmp (Chr) 10 # Linefeed? + jeq retT # Yes + null (Chr) # Chr <= 0? + jsz retT # Yes + ld E Nil # Return NIL + ret + +# (eof ['flg]) -> flg +(code 'doEof 2) + ld E ((E CDR)) # Get arg + eval # Eval it + cmp E Nil # NIL? + if eq # Yes + ld A (Chr) # Look ahead char? + null A + if z # No + call (EnvGet_A) # Get next + end + null A # EOF? + jns RetNil # No + else + ld (Chr) -1 # Set EOF + end + ld E TSym # Return T + ret + +# (from 'any ..) -> sym +(code 'doFrom 2) + push X + push Z + ld X (E CDR) # X on args + push 0 # End-of-buffers marker + do + call evSymX_E # Next argument + call bufStringE_SZ # <S V> Stack buffer + push 0 # <S IV> Index + link + push E # <S II> Symbol + link + push Z # <S> Buffer chain + ld X (X CDR) # More arguments? + atom X + until nz # No + ld A (Chr) # Look ahead char? + null A + if z # No + call (EnvGet_A) # Get next + end + do + null A # EOF? + while ns # No + ld Z S # Buffer chain + do + do + lea C (Z V) # Stack buffer + add C (Z IV) # Index + cmp B (C) # Bytes match? + if eq # Yes + add (Z IV) 1 # Increment index + nul (C 1) # End of string? + break nz # No + call (EnvGet_A) # Skip next input byte + ld E (Z II) # Return matched symbol + jmp 90 + end + null (Z IV) # Still at beginning of string? + break z # Yes + lea C (Z (+ V 1)) # Offset pointer to second byte + do + sub (Z IV) 1 # Decrement index + while nz + cmpn (Z V) (C) (Z IV) # Compare stack buffer + while nz + add C 1 # Increment offset + loop + loop + ld Z (Z) # Next in chain + null (Z) # Any? + until z # No + call (EnvGet_A) # Get next input byte + loop + ld E Nil # Return NIL +90 pop Z # Clean up buffers + do + drop + ld S Z + pop Z + null Z # End? + until z # Yes + pop Z + pop X + ret + +# (till 'any ['flg]) -> lst|sym +(code 'doTill 2) + push X + push Z + ld X (E CDR) # Args + call evSymX_E # Evaluate to a symbol + call bufStringE_SZ # <S I/IV> Stack buffer + push A # <S /III> String length + slen (S) (S I) + ld A (Chr) # Look ahead char? + null A + if z # No + call (EnvGet_A) # Get next + end + null A # EOF? + if ns # No + memb (S I) (S) # Matched first char? + if ne # No + ld E ((X CDR)) # Eval 'flg' + eval + cmp E Nil # NIL? + if eq # Yes + call getChar_A # Get first character + call mkCharA_A # Make char + call consA_X # Build first cell + ld (X) A + ld (X CDR) Nil + link + push X # <L I> Result list + link + do + call (EnvGet_A) # Get next + null A # EOF? + while nsz # No + memb (S IV) (S III) # Matched char? + while ne # No + call getChar_A # Get next character + call mkCharA_A + call consA_C # Build next cell + ld (C) A + ld (C CDR) Nil + ld (X CDR) C # Append to sublist + ld X C + loop + ld E (L I) # Get result list + else + link + push ZERO # <L I> Result + ld X S + link + ld C 4 # Build name + do + call getChar_A # Get next character + call charSymACX_CX # Insert + call (EnvGet_A) # Get next + null A # EOF? + while nsz # No + memb (S IV) (S III) # Matched char? + until eq # Yes + ld X (L I) # Get result name + call consSymX_E + end + drop + ld S Z # Drop buffer + pop Z + pop X + ret + end + end + ld E Nil # Return NIL + ld S Z # Drop buffer + pop Z + pop X + ret + +(code 'eolA_F 0) + null A # EOF? + js retz # Yes + cmp A 10 # Linefeed? + if ne # No + cmp A 13 # Return? + jne Ret # No + call (EnvGet_A) # Get next + cmp A 10 # Linefeed? + jnz retz + end + ld (Chr) 0 # Clear look ahead + ret # 'z' + +# (line 'flg ['cnt ..]) -> lst|sym +(code 'doLine 2) + ld A (Chr) # Look ahead char? + null A + if z # No + call (EnvGet_A) # Get next + end + call eolA_F # End of line? + jeq retNil # Yes + push X + push Y + push Z + ld Y (E CDR) # Y on args + ld E (Y) # Eval 'flg' + eval + cmp E Nil # 'flg' was non-NIL? + if ne # Yes: Pack + ld Y (Y CDR) # More args? + atom Y + if nz # No + link + push ZERO # <L I> Result + ld X S + link + ld C 4 # Build name + do + call getChar_A # Get next character + call charSymACX_CX # Insert + call (EnvGet_A) # Get next + call eolA_F # End of line? + until eq # Yes + ld X (L I) # Get result name + call consSymX_E + else + call cons_Z # First cell of top list + ld (Z) ZERO + ld (Z CDR) Nil + link + push Z # <L I> Result + link + do + ld C 4 # Build name + ld X Z + call getChar_A # Get next character + call charSymACX_CX # Insert first char + push C + ld E (Y) + eval # Eval next arg + pop C + shr E 4 # Normalize + do + sub E 1 # Decrement count + while nz + call (EnvGet_A) # Get next + call eolA_F # End of line? + if eq # Yes + ld X (Z) # Get last sub-result + call consSymX_E + ld (Z) E + jmp 20 + end + call getChar_A # Get next character + call charSymACX_CX # Insert + loop + ld X (Z) # Get last sub-result + call consSymX_E + ld (Z) E + ld Y (Y CDR) # More args? + atom Y + jnz 10 # No + call (EnvGet_A) # Get next + call eolA_F # End of line? + jeq 20 # Yes + call cons_A # New cell to top list + ld (A) ZERO + ld (A CDR) Nil + ld (Z CDR) A + ld Z A + loop + end + else + call getChar_A # Get first character + call mkCharA_A # Make char + call consA_Z # Build first cell + ld (Z) A + ld (Z CDR) Nil + link + push Z # <L I> Result + link + ld Y (Y CDR) # More args? + atom Y + if z # Yes + ld X Z # Current sublist + call cons_Z # First cell of top list + ld (Z) X + ld (Z CDR) Nil + ld (L I) Z # New result + do + ld E (Y) + eval # Eval next arg + shr E 4 # Normalize + do + sub E 1 # Decrement count + while nz + call (EnvGet_A) # Get next + call eolA_F # End of line? + jeq 20 # Yes + call getChar_A # Get next character + call mkCharA_A + call consA_C # Build next cell + ld (C) A + ld (C CDR) Nil + ld (X CDR) C # Append to sublist + ld X C + loop + ld Y (Y CDR) # More args? + atom Y + while z # Yes + call (EnvGet_A) # Get next + call eolA_F # End of line? + jeq 20 # Yes + call getChar_A # Get next character + call mkCharA_A + call consA_X # Build new sublist + ld (X) A + ld (X CDR) Nil + call consX_A # Append to top list + ld (A) X + ld (A CDR) Nil + ld (Z CDR) A + ld Z A + loop + end +10 do + call (EnvGet_A) # Get next + call eolA_F # End of line? + while ne # No + call getChar_A # Get next character + call mkCharA_A + call consA_C # Build next cell + ld (C) A + ld (C CDR) Nil + ld (Z CDR) C # Append + ld Z C + loop +20 ld E (L I) # Get result + end + drop + pop Z + pop Y + pop X + ret + +# (lines 'any ..) -> cnt +(code 'doLines 2) + push X + push Y + push Z + ld X (E CDR) # Args + ld Y 0 # Result + do + atom X # More args? + while z # Yes + call evSymX_E # Evaluate next file name + call pathStringE_SZ # Write to stack buffer + cc fopen(S _r_) # Open file + ld S Z # Drop buffer + null A # OK? + if nz # Yes + ld E A # File pointer + null Y # First hit? + if z # Yes + ld Y ZERO # Init short number + end + do + cc getc_unlocked(E) # Next char + nul4 # EOF? + while ns # No + cmp A 10 # Linefeed? + if eq # Yes + add Y (hex "10") # Increment count + end + loop + cc fclose(E) # Close file pointer + end + ld X (X CDR) + loop + null Y # Result? + ld E Y # Yes + ldz E Nil # No + pop Z + pop Y + pop X + ret + +(code 'parseBCE_E) + push (EnvParseX) # Save old parser status + push (EnvParseC) + push (EnvParseEOF) + push (EnvGet_A) # Save 'get' status + push (Chr) + ld E (E TAIL) + call nameE_E # Get name + link + push E # Save it + link + ld (EnvParseX) E # Set new parser status + ld (EnvParseC) 0 + null C # Token? + if z # No + ld E (hex "FFFFFFFFFF5D0A00") # linefeed, ']', EOF + else + ld E -1 + end + ld (EnvParseEOF) E + ld (EnvGet_A) getParse_A # Set 'get' status + ld (Chr) 0 + or B B # Skip? + if nz # Yes + call getParse_A # Skip first char + end + null C # Token? + if z # No + call rdList_E # Read a list + else + push X + push C # <S III> Set of characters + ld E C # in E + ld C 0 # No comment char + call tokenCE_E # Read token + null E # Any? + ldz E Nil + if nz # Yes + call consE_X # Build first result cell + ld (X) E + ld (X CDR) Nil + link + push X # <L I> Result + link + do + ld C 0 # No comment char + ld E (S III) # Get set of characters + push X + call tokenCE_E # Next token? + pop X + null E + while nz # Yes + call consE_A # Build next result cell + ld (A) E + ld (A CDR) Nil + ld (X CDR) A + ld X A + loop + ld E (L I) # Get result + drop + end + pop A # Drop set + pop X + end + drop + pop (Chr) # Retrieve 'get' status + pop (EnvGet_A) + pop (EnvParseEOF) # Restore old parser status + pop (EnvParseC) + pop (EnvParseX) + ret + +# (any 'sym) -> any +(code 'doAny 2) + push X + ld X E + ld E ((E CDR)) # E on arg + eval # Eval it + num E # Need symbol + jnz symErrEX + sym E + jz symErrEX + cmp E Nil # NIL? + if ne # No + push (EnvParseX) # Save old parser status + push (EnvParseC) + push (EnvParseEOF) + push (EnvGet_A) # Save 'get' status + push (Chr) + ld E (E TAIL) + call nameE_E # Get name + link + push E # Save it + link + ld (EnvParseX) E # Set new parser status + ld (EnvParseC) 0 + ld (EnvParseEOF) (hex "FFFFFFFFFFFF2000") # Blank, EOF + ld (EnvGet_A) getParse_A # Set 'get' status + ld (Chr) 0 + call getParse_A # Skip first char + ld A 1 # Top level + call readA_E # Read expression + drop + pop (Chr) # Retrieve 'get' status + pop (EnvGet_A) + pop (EnvParseEOF) # Restore old parser status + pop (EnvParseC) + pop (EnvParseX) + end + pop X + ret + +# (sym 'any) -> sym +(code 'doSym 2) + ld E ((E CDR)) # Eval arg + eval + link + push E # Save + link + call begString # Start string + call printE # Print to string + call endString_E # Retrieve result + drop + ret + +# (str 'sym ['sym1]) -> lst +# (str 'lst) -> sym +(code 'doStr 2) + push X + push Y + ld X E + ld Y (E CDR) # Y on args + ld E (Y) # Eval first + eval + cmp E Nil # NIL? + if ne # No + num E # Number? + jnz argErrEX # Yes + sym E # Symbol? + if nz # Yes + link + push E # <L II> 'sym' + link + ld X (Y CDR) # Second arg? + atom X + if nz # No + ld C 0 # No token + else + call evSymX_E # Eval 'sym1' + tuck E # Save + link + ld C E # Get token + ld E (L II) # and 'sym' + end + ld B 0 # Don't skip + call parseBCE_E # Parse + drop + else + link + push E # Save 'lst' + link + call begString # Start string + ld X E # 'lst' + do + ld E (X) # Get CAR + call printE # Print to string + ld X (X CDR) # More items? + atom X + while z # Yes + call space + loop + call endString_E # Retrieve result + drop + end + end + pop Y + pop X + ret + +# Read-Eval-Print loop +(code 'loadBEX_E) + ld C A # Save prompt in C + sym E # Symbolic argument? + if nz # Yes + ld A (E TAIL) + call firstByteA_B # starting with "-"? + cmp B (char "-") + if eq # Yes + ld C 0 # No token + call parseBCE_E # Parse executable list + link + push E # Save expression + link + call evListE_E # Execute it + drop + ret + end + end + push Y + link + push ZERO # <L II> + push ZERO # <L I> + link + push C # <L -I> Prompt + sub S IV # InFrame + ld Y S + call rdOpenEXY + ld E Nil # Close transient scope + call doHide + call pushInFilesY + do + ld A ((InFiles)) # Get stdin + cmp A (InFile) # Reading from file? + if ne # Yes + ld C 0 # No terminator + call readC_E # Read expression + else + ld A (L -I) + or B B # Prompt? + if nz # Yes + null (Chr) + if z + call (EnvPutB) # Output prompt + call space + call flushAll + end + end + ld C 10 # Linefeed terminator + cc isatty(0) # STDIN + nul4 # on a tty? + ldz C 0 # No + call readC_E # Read expression + cmp (Chr) 10 # Hit linefeed? + if eq # Yes + ld (Chr) 0 # Clear it + end + end + cmp E Nil + while ne + ld (L I) E # Save read expression + ld A ((InFiles)) # Get stdin + cmp A (InFile) # Reading from file? + if nz # Yes +10 eval # Evaluate + else + null (Chr) # Line? + jnz 10 # Yes + ld A (L -I) + or B B # Prompt? + jz 10 # No + call flushAll + ld (L II) (At) # Save '@' + eval # Evaluate + ld (At) E # Save result + ld (At3) (At2) + ld (At2) (L II) # Retrieve previous '@' + ld C Arrow + call outStringC + call flushAll + call printE_E + call newline + end + ld (L I) E # Save result + loop + call popInFiles + ld E Nil # Close transient scope + call doHide + ld E (L I) + drop + pop Y + ret +: Arrow asciz "-> " + +# (load 'any ..) -> any +(code 'doLoad 2) + push X + push Y + ld X E + ld Y (E CDR) # Y on args + do + ld E (Y) # Eval arg + eval + cmp E TSym # Load remaining command line args? + if ne # No + ld B (char ">") # Prompt + call loadBEX_E + else + call loadAllX_E + end + ld Y (Y CDR) # More args? + atom Y + until nz # No + pop Y + pop X + ret + +# (in 'any . prg) -> any +(code 'doIn 2) + push X + push Y + ld X E # Expression in X + ld E (E CDR) + ld E (E) # Eval 'any' + eval + sub S IV # InFrame + ld Y S + call rdOpenEXY + call pushInFilesY + ld X ((X CDR) CDR) # Get 'prg' + prog X + call popInFiles + add S IV # Drop InFrame + pop Y + pop X + ret + +# (out 'any . prg) -> any +(code 'doOut 2) + push X + push Y + ld X E # Expression in X + ld E (E CDR) + ld E (E) # Eval 'any' + eval + sub S IV # OutFrame + ld Y S + call wrOpenEXY + call pushOutFilesY + ld X ((X CDR) CDR) # Get 'prg' + prog X + call popOutFiles + add S IV # Drop InFrame + pop Y + pop X + ret + +# (pipe exe) -> cnt +# (pipe exe . prg) -> any +(code 'doPipe 2) + push X + push Y + ld X E # Expression in X + sub S IV # In/OutFrame + ld Y S + push A # Create 'pipe' structure + cc pipe(S) # Open pipe + nul4 # OK? + jnz pipeErrX + ld4 (S) # Get pfd[0] + call closeOnExecAX + ld4 (S 4) # Get pfd[1] + call closeOnExecAX + call forkLispX_FE # Fork child process + if c # In child + atom ((X CDR) CDR) # 'prg'? + if z # Yes + cc setpgid(0 0) # Set process group + end + ld4 (S) # Close read pipe + call closeAX + ld4 (S 4) # Get write pipe + cmp A 1 # STDOUT_FILENO? + if ne # No + cc dup2(A 1) # Dup to STDOUT_FILENO + ld4 (S 4) # Close write pipe + call closeAX + end + ld E Nil # Standard output + call wrOpenEXY + call pushOutFilesY + ld (Run) Nil # Switch off all tasks + ld E ((X CDR)) # Get 'exe' + eval # Evaluate it + ld E 0 # Exit OK + jmp byeE + end + ld (Y II) E # Set 'pid' + ld4 (S 4) # Close write pipe + call closeAX + ld4 (S) # Get read pipe + call initInFileA_A + ld E (A) # Get file descriptor + ld X ((X CDR) CDR) # Get 'prg' + atom X # Any? + if nz # No + shl E 4 # In parent + or E CNT # Return PID + else + ld (Y I) E # Save 'fd' + cc setpgid((Y II) 0) # Set process group + call pushInFilesY + prog X + call popInFiles + end + add S (+ 8 IV) # Drop 'pipe' structure and In/OutFrame + pop Y + pop X + ret + +# (ctl 'sym . prg) -> any +(code 'doCtl 2) + push X + push Y + ld X E # Expression in X + ld E (E CDR) + ld E (E) # Eval 'any' + eval + push A # CtlFrame + push A + ld Y S + call ctOpenEXY + call pushCtlFilesY + ld X ((X CDR) CDR) # Get 'prg' + prog X + call popCtlFiles + pop A # Drop CtlFrame + pop A + pop Y + pop X + ret + +# (open 'sym) -> cnt | NIL +(code 'doOpen 2) + push X + push Z + ld X E + ld E ((E CDR)) # Get arg + call evSymE_E # Evaluate to a symbol + call pathStringE_SZ # Write to stack buffer + do + cc open(S (| O_CREAT O_RDWR) (oct "0666")) # Try to open + nul4 # OK? + while s # No + call errno_A + cmp A EINTR # Interrupted? + if nz # No + ld E Nil # Return NIL + jmp 90 + end + nul (Signal) # Signal? + if nz # Yes + call sighandlerX + end + loop + ld X A # Keep 'fd' + call closeOnExecAX + ld C X # 'fd' + cc strdup(S) # Duplicate name + call initInFileCA_A # Init input file structure + ld A X # 'fd' again + call initOutFileA_A # Init output file structure + ld E X # Return 'fd' + shl E 4 # Make short number + or E CNT +90 ld S Z # Drop buffer + pop Z + pop X + ret + +# (close 'cnt) -> cnt | NIL +(code 'doClose 2) + push X + ld X E + ld E ((E CDR)) # Eval 'cnt' + eval + ld C E # Keep in E + call xCntCX_FC # Get fd + cc close(C) # Close it + nul4 # OK? + ldnz E Nil + if z # Yes + ld A C # Close InFile + call closeInFileA + ld A C # Close OutFile + call closeOutFileA + end + pop X + ret + +# (echo ['cnt ['cnt]] | ['sym ..]) -> sym +(code 'doEcho 2) + push X + push Y + ld X E + ld Y (E CDR) # Y on args + ld E (Y) # Eval first + eval + ld Y (Y CDR) # Next arg + ld A (Chr) # Look ahead char? + null A + if z # No + call (EnvGet_A) # Get next + end + cmp E Nil # Empty arg? + if eq # Yes + atom Y # No further args? + if nz # Yes + do + null A # EOF? + while ns # No + call (EnvPutB) # Output byte + call (EnvGet_A) # Get next + loop + ld E TSym # Return T + pop Y + pop X + ret + end + end + num E # Number? + if nz # Yes + call xCntEX_FE # Get 'cnt' + atom Y # Second 'cnt' arg? + if z # Yes + ld Y (Y) # Get second 'cnt' + xchg Y E # First 'cnt' in Y + call evCntEX_FE # Evaluate second + ld A (Chr) # Get Chr again + do + sub Y 1 # Decrement first 'cnt' + while ns + null A # EOF? + if s # Yes + ld E Nil # Return NIL + pop Y + pop X + ret + end + call (EnvGet_A) # Get next + loop + end + do + sub E 1 # Decrement second 'cnt' + while ns + null A # EOF? + if s # Yes + ld E Nil # Return NIL + pop Y + pop X + ret + end + call (EnvPutB) # Output byte + call (EnvGet_A) # Get next + loop + ld E TSym # Return T + pop Y + pop X + ret + end + sym E # Need symbol + jz argErrEX + push Z + push 0 # End-of-buffers marker + do + call bufStringE_SZ # <S V> Stack buffer + push 0 # <S IV> Index + link + push E # <S II> Symbol + link + push Z # <S> Buffer chain + atom Y # More arguments? + while z # Yes + call evSymY_E # Next argument + ld Y (Y CDR) + loop + ld X 0 # Clear current max + ld A (Chr) # Look ahead char + do + null A # EOF? + while ns # No + ld Y X # Output max + null Y # Any? + if nz # Yes + ld E (Y IV) # Set output index + end + ld Z S # Buffer chain + do + do + lea C (Z V) # Stack buffer + add C (Z IV) # Index + cmp B (C) # Bytes match? + if eq # Yes + add (Z IV) 1 # Increment index + nul (C 1) # End of string? + if nz # No + null X # Current max? + if z # No + ld X Z + else + cmp (X IV) (Z IV) # Smaller than index? + ldc X Z # Yes + end + break T + end + null Y # Output max? + if nz # Yes + lea C (Y V) # Buffer of output max + sub E (Z IV) # Diff to current index + do # Done? + while ge # No + ld B (C) + call (EnvPutB) # Output bytes + add C 1 + sub E 1 + loop + end + call (EnvGet_A) # Skip next input byte + ld E (Z II) # Return matched symbol + jmp 90 + end + null (Z IV) # Still at beginning of string? + break z # Yes + lea C (Z (+ V 1)) # Offset pointer to second byte + do + sub (Z IV) 1 # Decrement index + while nz + cmpn (Z V) (C) (Z IV) # Compare stack buffer + while nz + add C 1 # Increment offset + loop + cmp X Z # On current max? + if eq # Yes + ld X 0 # Clear current max + ld C S # Buffer chain + do + null (C IV) # Index? + if nz # Yes + null X # Current max? + if z # No + ld X C + else + cmp (X IV) (C IV) # Smaller than index? + ldc X C # Yes + end + end + ld C (C) # Next in chain + null (C) # Any? + until z # No + end + loop + ld Z (Z) # Next in chain + null (Z) # Any? + until z # No + null X # Current max? + if z # No + null Y # Output max? + if nz + push A # Save current byte + push E # and output index + lea C (Y V) # Buffer of output max + do + ld B (C) + call (EnvPutB) # Output bytes + add C 1 + sub E 1 # Done? + until z # Yes + pop E + pop A + end + call (EnvPutB) # Output current byte + else + null Y # Output max? + if nz + lea C (Y V) # Buffer of output max + sub E (X IV) # Diff to current max index + do # Done? + while ge # No + ld B (C) + call (EnvPutB) # Output bytes + add C 1 + sub E 1 + loop + end + end + call (EnvGet_A) # Get next input byte + loop + ld E Nil # Return NIL +90 pop Z # Clean up buffers + do + drop + ld S Z + pop Z + null Z # End? + until z # Yes + pop Z + pop Y + pop X + ret + +(code 'putStdoutB 0) + push Y + ld Y (OutFile) # OutFile? + null Y + if nz # Yes + push E + push X + ld E (Y I) # Get 'ix' + lea X (Y III) # Buffer pointer + cmp E BUFSIZ # Reached end of buffer? + if eq # Yes + push A + push C + ld (Y I) 0 # Clear 'ix' + ld C (Y) # Get 'fd' + call wrBytesCEX_F # Write buffer + ld E 0 # Get 'ix' + lea X (Y III) # Buffer pointer + pop C + pop A + end + add X E # Buffer index + ld (X) B # Store byte + add E 1 # Increment ix + ld (Y I) E # Store 'ix' + cmp B 10 # Linefeed? + if eq # Yes + null (Y II) # and 'tty'? + if nz # Yes + push C + ld (Y I) 0 # Clear 'ix' + ld C (Y) # Get 'fd' + lea X (Y III) # Buffer pointer + call wrBytesCEX_F # Write buffer + pop C + end + end + pop X + pop E + end + pop Y + ret + +(code 'newline) + ld B 10 + jmp (EnvPutB) + +(code 'space) + ld B 32 +(code 'envPutB) # DLL hook + jmp (EnvPutB) + +(code 'envGet_A) # DLL hook + jmp (EnvGet_A) + +# Output decimal number +(code 'outNumE) + shr E 4 # Normalize + if c # Sign + ld B (char "-") # Output sign + call (EnvPutB) + end + ld A E +(code 'outWordA) + cmp A 9 # Single digit? + if gt # No + ld C 0 # Divide by 10 + div 10 + push C # Save remainder + call outWordA # Recurse + pop A + end + add B (char "0") # Make ASCII digit + jmp (EnvPutB) + +(code 'prExtNmX) + call fileObjX_AC # Get file and object ID + null A # File? + if nz # Yes + call outAoA # Output file number + end + ld A C # Get object ID +# Output octal number +(code 'outOctA 0) + cmp A 7 # Single digit? + if gt # No + push A # Save + shr A 3 # Divide by 8 + call outOctA # Recurse + pop A + and B 7 # Get remainder + end + add B (char "0") # Make ASCII digit + jmp (EnvPutB) + +# Output A-O encoding +(code 'outAoA 0) + cmp A 15 # Single digit? + if gt # No + push A # Save + shr A 4 # Divide by 16 + call outAoA # Recurse + pop A + and B 15 # Get remainder + end + add B (char "@") # Make ASCII letter + jmp (EnvPutB) + +(code 'outStringS) # C + lea C (S I) # Buffer above return address +(code 'outStringC) + do + ld B (C) # Next char + add C 1 + or B B # Null? + while ne # No + call (EnvPutB) + loop + ret + +(code 'outNameE) + push X + ld X (E TAIL) + call nameX_X # Get name + call prNameX # Print it + pop X + ret + +(code 'prNameX) + ld C 0 + do + call symByteCX_FACX # Next byte + while nz + call (EnvPutB) # Output byte + loop + ret + +# Print one expression +(code 'printE_E) + push E # Save expression + call printE # Print it + pop E # Restore + ret + +(code 'printE 0) + nul (Signal) # Signal? + if nz # Yes + call sighandler0 + end + cnt E # Short number? + jnz outNumE # Yes + big E # Bignum? + if nz # Yes + ld A -1 # Scale + jmp fmtNum0AE_E # Print it + end + push X + sym E # Symbol? + if nz # Yes + ld X (E TAIL) + call nameX_X # Get name + zero X # Any? + if eq # No + ld B (char "$") # $xxxxxx + call (EnvPutB) + shr E 4 # Normalize symbol pointer + ld A E + call outOctA + pop X + ret + end + sym (E TAIL) # External symbol? + if nz # Yes + ld B (char "{") # {AB123} + call (EnvPutB) + call prExtNmX # Print it + ld B (char "}") + call (EnvPutB) + pop X + ret + end + push Y + ld Y Intern + call isInternEXY_F # Internal symbol? + if eq # Yes + ld C 0 + call symByteCX_FACX # Get first byte + do + memb Delim "(DelimEnd-Delim)" # Delimiter? + if eq # Yes + push A # Save char + ld B (char "\\") # Print backslash + call (EnvPutB) + pop A + else + cmp B (char ".") # Dot? + if eq # Yes + call symByteCX_FACX # Next byte? + if z # No + ld B (char "\\") # Print backslash + call (EnvPutB) + ld B (char ".") # Print dot + call (EnvPutB) + break T # Done + end + push A # Save char + ld B (char ".") # Print dot + call (EnvPutB) + pop A + end + end + call (EnvPutB) # Put byte + call symByteCX_FACX # Next byte + until z # Done + else # Else transient symbol + ld Y 0 # 'tsm' flag in Y + atom (Tsm) # Transient symbol markup? + if z # Yes + cmp (EnvPutB) putStdoutB # to stdout? + if eq # No + ld Y ((OutFile) II) # and 'tty'? -> Y + end + end + null Y # Transient symbol markup? + if z # No + ld B (char "\"") + call (EnvPutB) + else + ld E ((Tsm)) # Get CAR + call outNameE # Write transient symbol markup + end + ld C 0 + call symByteCX_FACX # Get first byte + do + cmp B (char "\\") # Backslash? + jz 20 + cmp B (char "\^") # Caret? + jz 20 + null Y # Transient symbol markup? + jnz 30 # Yes + cmp B (char "\"") # Double quote? + if eq # Yes +20 push A # Save char + ld B (char "\\") # Escape with backslash + call (EnvPutB) + pop A + else +30 cmp B 127 # DEL? + if eq # Yes + ld B (char "\^") # Print ^? + call (EnvPutB) + ld B (char "?") + else + cmp B 32 # White space? + if lt # Yes + push A # Save char + ld B (char "\^") # Escape with caret + call (EnvPutB) + pop A + or A 64 # Make printable + end + end + end + call (EnvPutB) # Put byte + call symByteCX_FACX # Next byte + until z # Done + null Y # Transient symbol markup? + if z # No + ld B (char "\"") # Final double quote + call (EnvPutB) + else + ld E ((Tsm) CDR) # Get CDR + call outNameE # Write transient symbol markup + end + end + pop Y + pop X + ret + end + # Print list + cmp (E) Quote # CAR 'quote'? + if eq # Yes + cmp E (E CDR) # Circular? + if ne # No + ld B (char "'") # Print single quote + call (EnvPutB) + ld E (E CDR) # And CDR + call printE + pop X + ret + end + end + ld X E # Keep list head + ld B (char "(") # Open paren + call (EnvPutB) + do + push (E CDR) # Save rest + ld E (E) # Print CAR + call printE + pop E + cmp E Nil # NIL-terminated? + while ne # No + cmp E X # Circular? + if eq # Yes + call space # Print " ." + ld B (char ".") + call (EnvPutB) + break T + end + atom E # Atomic tail? + if nz # Yes + call space # Print " . " + ld B (char ".") + call (EnvPutB) + call space + call printE # and the atom + break T + end + call space # Print space + loop + ld B (char ")") # Closing paren + call (EnvPutB) + pop X + ret + +# Print string representation +(code 'prinE_E 0) + push E # Save expression + call prinE # Print it + pop E # Restore + ret + +(code 'prinE 0) + nul (Signal) # Signal? + if nz # Yes + call sighandler0 + end + cmp E Nil # NIL? + if ne # No + cnt E # Short number? + jnz outNumE # Yes + big E # Bignum? + if nz # Yes + ld A -1 # Scale + jmp fmtNum0AE_E # Print it + end + push X + sym E # Symbol? + if nz # Yes + ld X (E TAIL) + call nameX_X # Get name + zero X # Any? + if ne # Yes + sym (E TAIL) # External symbol? + if z # No + call prNameX + else + ld B (char "{") # {AB123} + call (EnvPutB) + call prExtNmX # Print it + ld B (char "}") + call (EnvPutB) + end + end + else + ld X E # Get list in X + do + ld E (X) # Prin CAR + call prinE + ld X (X CDR) # Next + cmp X Nil # NIL-terminated? + while ne # No + atom X # Done? + if nz # Yes + ld E X # Print atomic rest + call prinE + break T + end + loop + end + pop X + end + ret + +# (prin 'any ..) -> any +(code 'doPrin 2) + push X + ld X (E CDR) # Get arguments + do + ld E (X) + eval # Eval next arg + call prinE_E # Print string representation + ld X (X CDR) # More arguments? + atom X + until nz # No + pop X + ret + +# (prinl 'any ..) -> any +(code 'doPrinl 2) + call doPrin # Print arguments + jmp newline + +(code 'doSpace 2) + push X + ld X E + ld E ((E CDR)) # Eval 'cnt' + eval + cmp E Nil # NIL? + if eq # Yes + call space # Output single space + ld E ONE # Return 1 + else + ld C E # Keep in E + call xCntCX_FC # Get cnt + do + sub C 1 # 'cnt' times + while ns + call space # Output spaces + loop + end + pop X + ret + +# (print 'any ..) -> any +(code 'doPrint 2) + push X + ld X (E CDR) # Get arguments + do + ld E (X) + eval # Eval next arg + call printE_E # Print it + ld X (X CDR) # More arguments? + atom X + while z # Yes + call space # Print space + loop + pop X + ret + +# (printsp 'any ..) -> any +(code 'doPrintsp 2) + push X + ld X (E CDR) # Get arguments + do + ld E (X) + eval # Eval next arg + call printE_E # Print it + call space # Print space + ld X (X CDR) # More arguments? + atom X + until nz # No + pop X + ret + +# (println 'any ..) -> any +(code 'doPrintln 2) + call doPrint # Print arguments + jmp newline + +# (flush) -> flg +(code 'doFlush 2) + ld A (OutFile) # Flush OutFile + call flushA_F # OK? + ld E TSym # Yes + ldnz E Nil + ret + +# (rewind) -> flg +(code 'doRewind 2) + ld E Nil # Preload return value + ld C (OutFile) # OutFile? + null C + if nz # Yes + ld (C I) 0 # Clear 'ix' + cc lseek((C) 0 SEEK_SET) # Seek to beginning of file + null A # OK? + if z # Yes + cc ftruncate((C) 0) # Truncate file + nul4 # OK? + ldz E TSym # Return T + end + end + ret + +# (ext 'cnt . prg) -> any +(code 'doExt 2) + push X + push Y + ld X E + ld Y (E CDR) # Y on args + call evCntXY_FE # Eval 'cnt' + push (ExtN) # Save external symbol offset + ld (ExtN) E # Set new + ld X (Y CDR) # Run 'prg' + prog X + pop (ExtN) # Restore external symbol offset + pop Y + pop X + ret + +# (rd ['sym]) -> any +# (rd 'cnt) -> num | NIL +(code 'doRd 2) + ld E ((E CDR)) # Get arg + eval # Eval it + cnt E # Read raw bytes? + if z # No + push Z + ld Z (InFile) # Current InFile + null Z # Any? + if nz # Yes + link + push E # <L I> EOF + link + ld (GetBinZ_FB) getBinaryZ_FB # Set binary read function + ld (Extn) (ExtN) # Set external symbol offset + call binReadZ_FE # Read item? + ldc E (L I) # No: Return EOF + drop + end + pop Z + ret + end + ld C (InFile) # Current InFile? + null C + jz retNil # No + push X + push Y + push Z + link + push ZERO # <L I> Result + link + shr E 4 # Normalize + jz 80 # Zero + if c # Little endian + sub S E # Buffer + ld Y S # Buffer pointer + ld Z 1 # Forward direction + else + ld Y S # Buffer pointer + ld Z -1 # Backward direction + add Y Z # Point to last byte + sub S E # Buffer + end + ld C (C) # Get 'fd' of InFile + ld X S # Buffer pointer + push E # <S> Count + call rdBytesCEX_F # OK? + if z # No +80 ld E Nil # Return NIL + jmp 90 + end + lea X (L I) # X on result + ld C 4 # Build unsigned number + do + ld B (Y) # Next byte from buffer + call byteNumBCX_CX + add Y Z # Add direction offset + sub (S) 1 # Decrement count + until z + ld E (L I) # Get result + big E # Bignum? + if nz # Yes + ld A E + call zapZeroA_A # Remove leading zeroes + ld E A + end +90 drop + pop Z + pop Y + pop X + ret + +# (pr 'any ..) -> any +(code 'doPr 2) + push X + ld X (E CDR) # Get arguments + do + ld E (X) + eval # Eval next arg + push E # Keep + ld (Extn) (ExtN) # Set external symbol offset + call prE # Print binary + pop E + ld X (X CDR) # More arguments? + atom X + until nz # No + pop X + ret + +# (wr 'cnt ..) -> cnt +(code 'doWr 2) + push X + ld X (E CDR) # Args + do + ld E (X) # Eval next + eval + ld A E # Get byte + shr A 4 # Normalize + call putStdoutB # Output + ld X (X CDR) # X on rest + atom X # Done? + until nz # Yes + pop X + ret + +# (rpc 'sym ['any ..]) -> flg +(code 'doRpc 2) + push X + ld X (E CDR) # Args + ld A BEG # Begin list + call putCharA + do + ld E (X) # Eval next arg + eval + ld (PutBinBZ) putCharA # Set binary print function + ld (Extn) (ExtN) # Set external symbol offset + call binPrintEZ + ld X (X CDR) # X on rest + atom X # Any + until nz # No + ld A END # End list + call putCharA + cc fflush((stdout)) # Flush + nul4 # OK? + ld E Nil + ldz E TSym # Yes + pop X + ret + +(code 'putCharA 0) + cc putchar_unlocked(A) + ret + +# vi:et:ts=3:sw=3 diff --git a/src64/lib/asm.l b/src64/lib/asm.l @@ -0,0 +1,546 @@ +# 08mar10abu +# (c) Software Lab. Alexander Burger + +# *LittleEndian *Registers optimize + +# *FPic *Section *Label *Tags *Program *Statement +# *Instructions *IfStack *DoStack +# "*Mode" "*Modes" + +(de *Transfers + call + jmp + jz jeq + jnz jne + js + jns + jsz + jnsz + jc jlt + jnc jge + jcz jle + jncz jgt ) + +(de *Conditions + (T jmp . jmp) + (z jz . jnz) + (nz jnz . jz) + (s js . jns) + (ns jns . js) + (sz jsz . jnsz) + (nsz jnsz . jsz) + (c jc . jnc) + (nc jnc . jc) + (cz jcz . jncz) + (ncz jncz . jcz) + (eq jz . jnz) + (ne jnz . jz) + (lt jc . jnc) + (le jcz . jncz) + (gt jncz . jcz) + (ge jnc . jc) ) + +(de build ("File" "Tags" . "Prg") + (off *Section *Tags *IfStack *DoStack) + (out "File" + (prinl "/* " (datSym (date)) " */") + (run "Prg") ) + (when "Tags" + (out "Tags" + (for Sym (idx '*Tags) + (and + (sym? (val Sym)) + (; Sym 0 src) + (prinl Sym " (" (cdr @) " . \"@src64/" (car @) "\")") ) ) ) ) ) + +(de asm Args + (put (car Args) 'asm (cdr Args)) ) + +(de fpic () + (on *FPic) ) + +# Sections +(de section (Fun @Sym) + (def Fun + (curry (@Sym) (Lbl Align) + (put Lbl 'src (cdr (file))) + (unless (== *Section '@Sym) + (prinl) + (prinl " ." '@Sym) + (setq *Section '@Sym) ) + (prinl) + (when Align + (prinl " .balign 16") + (do Align + ((get 'nop 'asm)) ) ) + (when (reg Lbl) + (quit "Register" Lbl) ) + (when Lbl + (label (setq *Label Lbl)) ) + (setq *Program + (make + (while (and (skip "#") (<> "(" (peek))) + (let Atom (read) + (cond + ((== ': Atom) + (link (cons ': (read))) ) + ((num? Atom) + (link (cons ': (pack *Label "_" Atom))) ) + ((lup *FlowControl Atom) + ((get Atom 'asm) (eval (cadr @))) ) + ((lup *Instructions Atom) + (link (cons Atom (mapcar eval (cdr @)))) ) + (T (quit "Bad instruction" Atom)) ) ) ) ) ) + (when (or *IfStack *DoStack) + (quit "Unbalanced flow") ) + (cleanUp) + (setq *Program + (make + (for (L *Program L) + (ifn (optimize L) + (link (pop 'L)) + (setq L (nth L (inc (car @)))) + (chain (cdr @)) ) ) ) ) + (for *Statement *Program + (if (== ': (car *Statement)) + (prinl (cdr *Statement) ':) + (apply (get (car *Statement) 'asm) (cdr *Statement)) ) ) ) ) ) + +(section 'data 'data) +(section 'code 'text) + +(de cleanUp () + (use (L1 L2) + (while # Remove duplicate labels + (seek + '((L) + (and + (== ': (caar L)) + (== ': (caadr L)) + (cond + ((= `(char ".") (char (setq L1 (cdar L)))) + (setq L2 (cdadr L)) ) + ((= `(char ".") (char (setq L1 (cdadr L)))) + (setq L2 (cdar L)) ) ) ) ) + *Program ) + (setq *Program + (mapcan + '((L) + (cond + ((<> L1 ((if (atom (cdr L)) cdr cadr) L)) + (cons L) ) + ((memq (car L) *Transfers) + (cons (list (car L) L2)) ) ) ) + *Program ) ) ) + (while # Remove jmp-only labels + (seek + '((L) + (and + (== ': (car (setq L1 (car L)))) + (= `(char ".") (char (cdr L1))) + (== 'jmp (car (setq L2 (cadr L)))) ) ) + *Program ) + (setq *Program + (mapcan + '((L) + (unless (== L L1) + (cons + (if + (and + (memq (car L) *Transfers) + (= (cdr L1) (cadr L)) ) + (list (car L) (cadr L2)) + L ) ) ) ) + *Program ) ) ) ) + (setq *Program # Remove unreachable statements + (make + (while *Program + (when (memq (car (link (pop '*Program))) '(jmp ret eval/ret)) + (while (and *Program (n== ': (caar *Program))) + (pop '*Program) ) ) ) ) ) + (setq *Program # Remove zero jumps + (make + (while *Program + (let P (pop '*Program) + (unless + (and + (memq (car P) (cdr *Transfers)) + (== ': (caar *Program)) + (= (cadr P) (cdar *Program)) ) + (link P) ) ) ) ) ) + (setq *Program # Toggle inverted jumps + (make + (while *Program + (let P (pop '*Program) + (ifn + (and + (memq (car P) (cddr *Transfers)) + (== 'jmp (caar *Program)) + (== ': (caadr *Program)) + (= (cadr P) (cadr (cadr *Program))) ) + (link P) + (link + (list + (cddr + (find + '((C) (== (car P) (cadr C))) + (cdr *Conditions) ) ) + (cadr (pop '*Program)) ) ) ) ) ) ) ) ) + + +# Print instruction +(de prinst (Name . @) + (if (rest) + (tab (3 -9 0) NIL Name (glue ", " @)) + (tab (3 -9) NIL Name) ) ) + +# Registers +(de reg (X) + (cdr (asoq X *Registers)) ) + +# Operand evaluation +(de operand (X) + (cond + ((num? X) X) + ((sym? X) + (cond + ((asoq X *Registers) X) + ((get X 'equ) @) + (T X) ) ) + ((asoq (car X) *Registers) + (cons (car X) (operand (cadr X))) ) + ((memq (car X) '(+ - * */ / % >> & | short char hex oct)) + (apply (car X) (mapcar operand (cdr X))) ) + (T (cons (car X) (operand (cadr X)))) ) ) + +# Constants +(de short (N) + (| 2 (>> -4 N)) ) + +(de equ Args + (def (car Args) + (put (car Args) 'equ (run (cdr Args) 1)) ) ) + + +# Source/Destination addressing mode: +# 0 -> Immediate +# NIL -> Register +# T -> Direct +(de "source" (X F) + (setq X (operand X)) + (cond + ((num? X) # Immediate + (zero "*Mode") + (pack '$ (and F "~") X) ) + ((reg X) (off "*Mode") @) # Register + ((atom X) (on "*Mode") X) # Direct + ((or (num? (cdr X)) (get (cdr X) 'equ)) + (prog1 (cons ("source" (car X) F) @) + (setq "*Mode" (cons "*Mode" 0)) ) ) + ((cdr X) + (and (reg (cdr X)) (quit "Bad source" X)) + (prog1 (cons ("source" (car X) F) @) + (setq "*Mode" (cons "*Mode" T)) ) ) + (T + (prog1 (cons ("source" (car X) F)) + (setq "*Mode" (cons "*Mode")) ) ) ) ) + +(de source (F) + ("source" (read) F) ) + +(de sources () + (off "*Modes") + (let Arg (read) + (if (lst? Arg) + (mapcar + '((X) + (prog1 ("source" X) + (queue '"*Modes" "*Mode") ) ) + Arg ) + ("source" Arg) ) ) ) + +(de "destination" (X F) + (setq X (operand X)) + (cond + ((num? X) (quit "Bad destination" X)) # Immediate + ((reg X) (off "*Mode") @) # Register + ((atom X) # Direct + (or F (quit "Bad destination" X)) + (on "*Mode") + X ) + ((or (num? (cdr X)) (get (cdr X) 'equ)) + (prog1 (cons ("destination" (car X) T) @) + (setq "*Mode" (cons "*Mode" 0)) ) ) + ((cdr X) + (and (reg (cdr X)) (quit "Bad destination" X)) + (prog1 (cons ("destination" (car X) T) (cdr X)) + (setq "*Mode" (cons "*Mode" T)) ) ) + (T + (prog1 (cons ("destination" (car X) T)) + (setq "*Mode" (cons "*Mode")) ) ) ) ) + +(de destination () + ("destination" (read)) ) + +(de destinations () + (off "*Modes") + (mapcar + '((X) + (prog1 ("destination" X) + (queue '"*Modes" "*Mode") ) ) + (read) ) ) + + +# Target addressing mode: +# NIL -> Absolute +# 0 -> Indexed +# T -> Indirect +(de address () + (let X (read) + (off "*Mode") + (cond + ((num? X) (pack *Label "_" X)) # Label + ((reg X) (quit "Bad address" X)) # Register + ((atom X) X) # Absolute + ((cdr X) (quit "Bad address" X)) + ((reg (car X)) (zero "*Mode") @) # Register indirect + (T (on "*Mode") (car X)) ) ) ) # Indirect + + +# Flow control +(balance '*FlowControl + (quote + (break (read)) + (continue (read)) + (do) + (else) + (end) + (if (read)) + (loop) + (until (read)) + (while (read)) ) ) + +(de flowCondition (Sym Lbl Neg) + (if ((if Neg cddr cadr) (asoq Sym *Conditions)) + (link (list @ Lbl)) + (quit "Bad condition" Sym) ) ) + +(de flowLabel () + (pack "." (inc (0))) ) + +(asm if (Sym) + (flowCondition Sym (push '*IfStack (flowLabel)) T) ) + +(asm else () + (let Lbl (car *IfStack) + (link + (list 'jmp (set *IfStack (flowLabel))) + (cons ': Lbl) ) ) ) + +(asm end () + (link (cons ': (pop '*IfStack))) ) + +(asm do () + (link (cons ': (push '*DoStack (flowLabel)))) ) + +(asm while (Sym) + (flowCondition Sym + (if (pair (car *DoStack)) + (car @) + (push *DoStack (flowLabel)) ) + T ) ) + +(asm until (Sym) + (let X (pop '*DoStack) + (flowCondition Sym (fin X) T) + (and (pair X) (link (cons ': (car X)))) ) ) + +(asm break (Sym) + (flowCondition Sym + (if (pair (car *DoStack)) + (car @) + (push *DoStack (flowLabel)) ) ) ) + +(asm continue (Sym) + (flowCondition Sym (fin (car *DoStack))) ) + +(asm loop () + (let X (pop '*DoStack) + (link (list 'jmp (fin X))) + (and (pair X) (link (cons ': (car X)))) ) ) + + +# Instruction set +(balance '*Instructions + (quote + (add (destination) "*Mode" (source) "*Mode") + (addc (destination) "*Mode" (source) "*Mode") + (align (operand (read))) + (and (destination) "*Mode" (source) "*Mode") + (ascii (operand (read))) + (asciz (operand (read))) + (atom (source) "*Mode") + (begin (operand (read))) + (big (source) "*Mode") + (byte (operand (read))) + (bytes (mapcar operand (read))) + (cc (address) "*Mode" (sources) "*Modes") + (call (address) "*Mode") + (clrc) + (clrz) + (cmp (destination) "*Mode" (source) "*Mode") + (cmp4 (source) "*Mode") + (cmpm (destination) "*Mode" (source) "*Mode" (source) "*Mode") + (cmpn (destination) "*Mode" (source) "*Mode" (source) "*Mode") + (cnt (source) "*Mode") + (dbg) + (div (source) "*Mode") + (drop) + (eval) + (eval+) + (eval/ret) + (exec (reg (read))) + (hx2 (read)) + (init) + (initSym (read) (read) (operand (read))) + (int) + (jc (address) "*Mode") + (jcz (address) "*Mode") + (jeq (address) "*Mode") + (jge (address) "*Mode") + (jgt (address) "*Mode") + (jle (address) "*Mode") + (jlt (address) "*Mode") + (jmp (address) "*Mode") + (jnc (address) "*Mode") + (jncz (address) "*Mode") + (jne (address) "*Mode") + (jns (address) "*Mode") + (jnsz (address) "*Mode") + (jnz (address) "*Mode") + (js (address) "*Mode") + (jsz (address) "*Mode") + (jz (address) "*Mode") + (:: (read)) + (ld (destination) "*Mode" (source) "*Mode") + (ld2 (source) "*Mode") + (ld4 (source) "*Mode") + (ldc (destination) "*Mode" (source) "*Mode") + (ldnc (destination) "*Mode" (source) "*Mode") + (ldnz (destination) "*Mode" (source) "*Mode") + (ldz (destination) "*Mode" (source) "*Mode") + (lea (destination) "*Mode" (source) "*Mode") + (link) + (memb (source) "*Mode" (source) "*Mode") + (movm (destination) "*Mode" (source) "*Mode" (source) "*Mode") + (movn (destination) "*Mode" (source) "*Mode" (source) "*Mode") + (mset (destination) "*Mode" (source) "*Mode") + (mul (source) "*Mode") + (neg (destination) "*Mode") + (nop) + (not (destination) "*Mode") + (nul (source) "*Mode") + (nul4) + (null (source) "*Mode") + (num (source) "*Mode") + (off (destination) "*Mode" (source T) "*Mode") + (or (destination) "*Mode" (source) "*Mode") + (pop (destination) "*Mode") + (prog (reg (read))) + (push (source) "*Mode") + (rcl (destination) "*Mode" (source) "*Mode") + (rcr (destination) "*Mode" (source) "*Mode") + (ret) + (return (operand (read))) + (rol (destination) "*Mode" (source) "*Mode") + (ror (destination) "*Mode" (source) "*Mode") + (set (destination) "*Mode" (source) "*Mode") + (setc) + (setz) + (shl (destination) "*Mode" (source) "*Mode") + (shr (destination) "*Mode" (source) "*Mode") + (skip (operand (read))) + (slen (destination) "*Mode" (source) "*Mode") + (st2 (destination) "*Mode") + (st4 (destination) "*Mode") + (sub (destination) "*Mode" (source) "*Mode") + (subc (destination) "*Mode" (source) "*Mode") + (sxt) + (sym (source) "*Mode") + (test (destination) "*Mode" (source) "*Mode") + (tuck (source) "*Mode") + (word (operand (read))) + (xchg (destination) "*Mode" (destination) "*Mode") + (xor (destination) "*Mode" (source) "*Mode") + (zero (source) "*Mode") + (zxt) ) ) + + +# Directives +(de label (Lbl) + (prinl " .globl " Lbl) + (prinl Lbl ':) ) + +(asm :: (Lbl) + (label Lbl) ) + +(asm align (N) + (prinst ".balign" N) ) + +(asm word (N) + (prinst ".quad" N) ) + +(asm byte (N) + (prinst ".byte" N) ) + +(asm bytes (Lst) + (prinst ".byte" (glue ", " Lst)) ) + +(asm hx2 (Lst) + (prinst ".short" (glue ", " (mapcar hex Lst))) ) + +(asm ascii (Str) + (prinst ".ascii " (pack "\"" Str "\"")) ) + +(asm asciz (Str) + (prinst ".asciz " (pack "\"" Str "\"")) ) + +(asm skip (N) + (prinst ".space" N) ) + +(asm initSym (Lbl Name Val) + (idx '*Tags (def Name Val) T) + (setq Name + (let (N 2 Lst (chop Name) C) + (make + (while (nth Lst 8) + (let L (mapcar char (cut 8 'Lst)) + (unless *LittleEndian + (setq L (flip L)) ) + (chain L) ) ) + (let L + (make + (do 7 + (setq C (char (pop 'Lst))) + (link (| N (>> -4 (& 15 C)))) + (setq N (& 15 (>> 4 C))) ) + (link N) ) + (unless *LittleEndian + (setq L (flip L)) ) + (chain L) ) ) ) ) + (if (nth Name 9) + (prinst ".quad" ".+20") + (prinl " .byte " (glue ", " Name)) + (off Name) ) + (when Lbl + (label Lbl) ) + (prinst ".quad" Val) + (while Name + (prinl " .byte " (glue ", " (cut 8 'Name))) ) ) + +(de warn (Msg) + (out 2 + (printsp *Label *Statement) + (prinl Msg) ) ) + +# vi:et:ts=3:sw=3 diff --git a/src64/main.l b/src64/main.l @@ -0,0 +1,2605 @@ +# 17mar10abu +# (c) Software Lab. Alexander Burger + +### Global return labels ### +(code 'Ret 0) + ret +(code 'Retc 0) + setc + ret +(code 'Retnc 0) + clrc + ret +(code 'Retz 0) + setz + ret +(code 'Retnz 0) + clrz + ret +(code 'RetNil 0) + ld E Nil + ret +(code 'RetT 0) + ld E TSym + ret +(code 'RetE_E 0) + ld E (E) # Get value or CAR + ret + +### Main entry point ### +(code 'main) + init + # Locate home directory + ld X (AV) # Command line vector + do + ld Y (X) # Next command + null Y # Any? + while nz # Yes + ld B (Y) # First byte + cmp B (char "-") # Dash? + if ne # No + ld Z Y # Keep in Y + ld B (char "/") # Contains a slash? + slen C Y # String length in C + memb Z C + if eq # Yes + do + memb Z C # Find last one + until ne + ld A Z + sub A 2 # "./lib.l"? + cmp A Y # Last slash is second byte? + jne 10 # No + ld B (Y) # First byte is "."? + cmp B (char ".") + if ne # No +10 sub Z Y # Length + ld C Z # Keep in Z + add C 1 # Space for null byte + cc malloc(C) + ld (Home) A # Set 'Home' + movn (A) (Y) Z # Copy path including "/" + add Z (Home) # Pointer to null byte + set (Z) 0 # Clear it + end + end + break T + end + add X I + loop + # Initialize globals + cc getpid() # PID in A + shl A 4 # Make short number + or A CNT + ld (Pid) A + ld (Stack0) S # Save top level stack pointer + ld L 0 # Init link register + call heapAlloc # Allocate initial heap + ld E Nil # Init internal symbols + lea Z (E IV) # Skip padding + do + ld X (E TAIL) # Get name + ld Y Intern + call internEXY_FE # Store to internals + ld E Z + cnt (Z TAIL) # Short name? + if nz # Yes + add Z II # Next symbol + else + add Z IV + end + cmp E SymTabEnd + until gt + ld (EnvGet_A) getStdin_A + ld A 0 # Standard input + call initInFileA_A # Create input file + ld (InFile) A # Set to default InFile + ld (EnvPutB) putStdoutB + ld A 2 # Standard error + call initOutFileA_A # Create output file + ld A 1 # Standard output + call initOutFileA_A # Create output file + ld (OutFile) A # Set to default OutFile + cc tcgetattr(0 OrgTermio) # Save terminal I/O + not B + ld (Tio) B # and flag + sub S SIGSET_T # Create signal mask structure + cc sigfillset(S) # Set all signals to unblocked + cc sigprocmask(SIG_UNBLOCK S 0) + add S SIGSET_T # Drop mask structure + ld E sig # Install standard signal handler + ld C SIGHUP + call iSignalCE # for SIGHUP + ld C SIGUSR1 + call iSignalCE # for SIGUSR1 + ld C SIGUSR2 + call iSignalCE # for SIGUSR2 + ld C SIGALRM + call iSignalCE # for SIGALRM + ld C SIGTERM + call iSignalCE # for SIGTERM + ld E sigTerm # Install terminating signal handler for SIGINT + ld C SIGINT + call iSignalCE + ld E sigChld # Install child signal handler for SIGCHLD + ld C SIGCHLD + call iSignalCE + cc signal(SIGCHLD sigChld) + cc signal(SIGPIPE SIG_IGN) # Ignore signals + cc signal(SIGTTIN SIG_IGN) + cc signal(SIGTTOU SIG_IGN) + cc gettimeofday(Buf 0) # Get time + ld A (Buf) # tv_sec + mul 1000000 # Convert to microseconds + add A (Buf I) # tv_usec + ld (USec) A # Store + ld X 0 # Runtime expression + call loadAllX_E # Load arguments + ld E sig # Install standard signal handler for SIGINT + ld C SIGINT + set (Repl) 1 # Set REPL flag + call iSignalCE +(code 'restart) + ld B (char ":") # Prompt + ld E Nil # REPL + ld X 0 # Runtime expression + call loadBEX_E + ld E 0 +# Exit +(code 'byeE) + nul (InBye) # Re-entered? + if z # No + set (InBye) 1 + push E # Save exit code + ld C 0 # Top frame + call unwindC_Z # Unwind + ld E (Bye) # Run exit expression(s) + call execE + pop E # Restore exit code + end + call flushAll # Flush all output channels +(code 'finishE) + call setCooked # Set terminal to cooked mode + cc exit(E) + +# Load all remaining arguments +(code 'loadAllX_E) + do + ld E ((AV)) # Command line vector + null E # Next string pointer? + jz retNil # No + ld B (E) # Single-dash argument? + cmp B (char "-") + if eq + nul (E 1) + jz retNil # Yes + end + add (AV) I # Increment vector pointer + call mkStrE_E # Make transient symbol + ld B 0 # Prompt + call loadBEX_E + loop + +# Give up +(code 'giveupX) + ld A (Pid) # Get PID + shr A 4 + cc fprintf((stderr) Giveup A X) + ld E 1 + jmp finishE +: Giveup asciz "%d %s\\n" + +(code 'execErrS) + cc fprintf((stderr) ExecErr (S)) + ld E 127 + jmp finishE +: ExecErr asciz "%s: can't exec\\n" + +# Install interrupting signal +(code 'iSignalCE) + sub S (* 2 SIGACTION) # 'sigaction' and 'oldact' + ld (S SA_HANDLER) E # Function pointer + cc sigemptyset(&(S SA_MASK)) + ld (S SA_FLAGS) 0 + cc sigaction(C S &(S SIGACTION)) # Install handler + add S (* 2 SIGACTION) + ret + +# Allocate memory +(code 'allocAE_A 0) + cc realloc(A E) # Reallocate pointer in A to size E + null A # OK? + jnz Ret # Return + ld X Alloc # Else no memory + jmp giveupX +: Alloc asciz "No memory" + + +# Allocate cell heap +(code 'heapAlloc 0) # AEX + ld A 0 # NULL pointer + ld E (+ HEAP I) # Heap allocation size + call allocAE_A + ld E A # Heap pointer + ld (A HEAP) (Heaps) # Set heap link + ld (Heaps) A + add A (- HEAP 16) # A on last cell in chunk + ld X (Avail) # Initialize free list + do + ld (A) X # Link avail + ld X A + sub A 16 + cmp A E # Done? + until lt # Yes + ld (Avail) X # Set new Avail + ret + +# Signal handler +(code 'sighandler0) + push E + ld E 0 + call sighandlerE + pop E + ret + +(code 'sighandlerX) + push E + ld E X + call sighandlerE + pop E + ret + +(code 'sighandlerE) + null (EnvProtect) # Protected? + if z # No + ld (EnvProtect) 1 + push A + push C + ld B (Signal) # Which signal? + cmp B SIGHUP + if eq + set (Signal) 0 # Clear signal + ld E (Hup) # Run 'Hup' + call execE + else + cmp B SIGINT + if eq + set (Signal) 0 # Clear signal + nul (PRepl) # Child of REPL process? + if z # No + null E # Runtime expression? + ldz E Nil # No: Default to NIL + call brkLoadE_E # Enter debug breakpoint + end + else + cmp B SIGUSR1 + if eq + set (Signal) 0 # Clear signal + ld E (Sig1) # Run 'Sig1' + call execE + else + cmp B SIGUSR2 + if eq + set (Signal) 0 # Clear signal + ld E (Sig2) # Run 'Sig2' + call execE + else + cmp B SIGALRM + if eq + set (Signal) 0 # Clear signal + ld E (Alarm) # Run 'Alarm' + call execE + else + cmp B SIGTERM + if eq + push X + ld X (Child) # Iterate children + ld C (Children) # Count + ld E 0 # Flag + do + sub C VI # More? + while ge # Yes + null (X) # 'pid'? + if nz # Yes + cc kill((X) SIGTERM) # Try to terminate + nul4 # OK? + ldz E 1 # Yes: Set flag + end + add X VI # Increment by sizeof(child) + loop + pop X + null E # Still terminated any child? + if z # No + set (Signal) 0 + ld E 0 # Exit OK + jmp byeE + end + end + end + end + end + end + end + pop C + pop A + ld (EnvProtect) 0 + end + ret + +(code 'sig) + begin 1 # Signal number in A + null (TtyPid) # Kill terminal process? + if nz # Yes + cc kill((TtyPid) A) + else + ld (Signal) B + end + return 1 + +(code 'sigTerm) + begin 0 # Ignore signal number + null (TtyPid) # Kill terminal process? + if nz # Yes + cc kill((TtyPid) SIGTERM) + else + set (Signal) SIGTERM + end + return 0 + +(code 'sigChld) + begin 0 # Ignore signal number + call errno_A # Save 'errno' + push A + sub S I # 'stat' + do + cc waitpid(0 S WNOHANG) # Wait for child + nul4 # Pid greater zero? + while nsz # Yes + ld C A # Keep Pid + call wifsignaledS_F # WIFSIGNALED(S)? + if nz # Yes + call wtermsigS_A # Get signal number WTERMSIG(S) + cc fprintf((stderr) PidSigMsg C A) + end + loop + add S I # Drop 'stat' + pop C # Restore 'errno' + call errnoC + return 0 +: PidSigMsg asciz "%d SIG-%d\\n" + +(code 'tcSetC) + null (Termio) # In raw mode? + if nz # Yes + do + cc tcsetattr(0 TCSADRAIN C) # Set terminal I/O + nul4 # OK? + while nz # No + call errno_A + cmp A EINTR # Interrupted? + until ne # No + end + ret + +(code 'sigTermStop) + begin 0 # Ignore signal number + ld C OrgTermio # Set original terminal I/O + call tcSetC + sub S SIGSET_T # Create mask structure + cc sigemptyset(S) # Init to empty signal set + cc sigaddset(S SIGTSTP) # Add stop signal + cc sigprocmask(SIG_UNBLOCK S 0) # Remove blocked signals + add S SIGSET_T # Drop mask structure + cc signal(SIGTSTP SIG_DFL) + cc raise(SIGTSTP) + cc signal(SIGTSTP sigTermStop) + ld C (Termio) + call tcSetC + return 0 + +(code 'setRaw 0) + nul (Tio) # Terminal I/O? + if nz # Yes + null (Termio) # Already in raw mode? + if z # No + cc malloc(TERMIOS) # Allocate space for termio structure + ld (Termio) A # Save it + ld C A # Pointer in C + movn (C) (OrgTermio) TERMIOS # Copy original termio structure + ld A 0 # Clear c_iflag + st4 (C C_IFLAG) + ld A ISIG # ISIG in c_lflag + st4 (C C_LFLAG) + set (C (+ C_CC VMIN)) 1 + set (C (+ C_CC VTIME)) 0 + call tcSetC # Set terminal I/O + cc signal(SIGTSTP SIG_IGN) # Ignore stop signals + cmp A SIG_DFL # Not set yet? + if eq # Yes + cc signal(SIGTSTP sigTermStop) # Handle stop signals + end + end + end + ret + +(code 'setCooked 0) + ld C OrgTermio # Set original terminal I/O + call tcSetC + cc free((Termio)) # Clear Termio + ld (Termio) 0 + ret + +# (raw ['flg]) -> flg +(code 'doRaw 2) + ld E (E CDR) # Arg? + atom E + if nz # No + null (Termio) # Return termio flag + jnz retT + ld E Nil + ret + end + ld E (E) # Evaluate arg + eval + cmp E Nil # NIL? + if eq # Yes + call setCooked # Set terminal to cooked mode + ld E Nil + ret + end + call setRaw # Set terminal to raw mode + ld E TSym + ret + +# (alarm 'cnt . prg) -> cnt +(code 'doAlarm 2) + push X + push Y + ld X E + ld Y (E CDR) # Y on args + call evCntXY_FE # Get 'cnt' + cc alarm(E) # Set alarm + ld (Alarm) (Y CDR) + ld E A # Get old alarm + shl E 4 # Make short number + or E CNT + pop Y + pop X + ret + +# (protect . prg) -> any +(code 'doProtect 2) + push X + ld X (E CDR) # Get 'prg' + add (EnvProtect) 1 + prog X # Run 'prg' + sub (EnvProtect) 1 + pop X + ret + +# (heap 'flg) -> cnt +(code 'doHeap 2) + ld E ((E CDR)) # Get arg + eval # Eval it + cmp E Nil # NIL? + if eq # Yes + ld E ZERO # Init count + ld A (Heaps) # Get heap list + do + add E (hex "10") # Increment count + ld A (A HEAP) # Get link + null A # Done? + until z # Yes + ret + end + ld A 0 # Init count + ld C (Avail) # Get avail list + do + null C # Any? + while nz # Yes + add A 1 # Increment count + ld C (C) # Follow link + loop + div CELLS # (C is zero) + ld E A + shl E 4 # Make short number + or E CNT + ret + +# (env ['lst] | ['sym 'val] ..) -> lst +(code 'doEnv 2) + push X + ld X (E CDR) + link + push Nil # <L II> Safe + push Nil # <L I> Result + link + atom X # Args? + if nz # No + push Y + ld Y (EnvBind) # Bindings + do + null Y # Bindings? + while nz # Yes + ld C (Y) # End of bindings + null (Y -I) # Env swap zero? + if z # Yes + add Y I # Y on bindings + do + ld E (Y) # Next symbol + ld X (L I) # Get result + do + atom X # More result items? + if nz # No + call cons_A # Cons symbol and its value + ld (A) E + ld (A CDR) (E) + call consA_X # Cons to result + ld (X) A + ld (X CDR) (L I) + ld (L I) X + break T + end + cmp E ((X)) # Symbol already in result? + while ne # No + ld X (X CDR) # Next result item + loop + add Y II # Skip value + cmp Y C # More? + until eq # No + end + ld Y (C I) # Bind link + loop + pop Y + else + do + ld E (X) # Eval 'lst' or 'sym' + eval + ld (L II) E # Save + atom E # 'lst'? + if z # Yes + do + call cons_A # Cons symbol and its value + ld (A) (E) + ld (A CDR) ((E)) + call consA_C # Cons to result + ld (C) A + ld (C CDR) (L I) + ld (L I) C + ld E (E CDR) # Next item in 'lst' + atom E # Any? + until nz # No + else + cmp E Nil # NIL? + if ne # No + ld X (X CDR) # Next arg + ld E (X) # Eval + eval + call consE_A # Cons symbol and value + ld (A) (L II) # Safe + ld (A CDR) E + call consA_C # Cons to result + ld (C) A + ld (C CDR) (L I) + ld (L I) C + end + end + ld X (X CDR) # More args? + atom X + until nz # No + end + ld E (L I) # Get result + drop + pop X + ret + +# (up [cnt] sym ['val]) -> any +(code 'doUp 2) + push X + push Y + push Z + ld C 1 # Count + ld E (E CDR) # First arg + ld X (E) # Get 'sym' + cnt X # 'cnt'? + if nz # Yes + ld C X # Count + shr C 4 # Normalize + ld E (E CDR) # Skip arg + ld X (E) # 'sym' + end + ld E (E CDR) # Last arg + ld Y (EnvBind) # Bindings + ld Z X # Value pointer + do + null Y # Bindings? + while nz # Yes + ld A (Y) # End of bindings in A + add Y I + do + cmp X (Y) # Found symbol? + if eq # Yes + lea Z (Y I) # Point to saved value + sub C 1 # Decrement count + jz 10 # Done + end + add Y II + cmp Y A # More? + until eq # No + ld Y (A I) # Bind link + loop +10 atom E # 'val' arg? + if nz # No + ld E (Z) # Get value + else + ld E (E) # Eval last arg + eval + ld (Z) E # Store value + end + pop Z + pop Y + pop X + ret + +### Comparisons ### +(code 'equalAE_F 0) + cmp A E # Pointer-equal? + jz ret # Yes: 'eq' + cnt A # A short? + jnz ret # Yes: 'ne' + big A # A big? + if nz # Yes + big E # E also big? + jz Retnz # No: 'ne' + test A SIGN # A negative? + if nz # Yes + test E SIGN # E also negative? + jz Retnz # No: 'ne' + off A SIGN # Make both positive + off E SIGN + end + do + cmp (A DIG) (E DIG) # Digits equal? + while eq # Yes + ld A (A BIG) # Else next digits + ld E (E BIG) + cmp A E # Pointer-equal? + while ne # No + cnt A # A short? + while z # No + cnt E # E short? + until nz # Yes + ret + end + sym A # A symbolic? + if nz # Yes + num E # E also symbolic? + jnz Retnz + sym E + jz Retnz # No: 'ne' + ld A (A TAIL) + call nameA_A # Get name of A + zero A # Any? + jeq retnz # No: 'ne' + ld E (E TAIL) + call nameE_E # Get name of E + zero E # Any? + jeq retnz # No: 'ne' + jmp equalAE_F + end + atom E # E atomic? + jnz ret # Yes: 'ne' + do + cmp (A) Quote # A quoted? + while eq # Yes + cmp (E) Quote # E also quoted? + jnz ret # No: 'ne' + cmp A (A CDR) # A circular? + if eq # Yes + cmp E (E CDR) # Check if E also circular + ret + end + cmp E (E CDR) # E circular? + jz retnz # Yes: 'ne' + ld A (A CDR) # Next cells + ld E (E CDR) + atom A # Any? + jnz equalAE_F # No: Compare with E's CDR + atom E + jnz ret # No: 'ne' + loop + push A # Save list heads + push E + do + push (A CDR) # Save CDRs + push (E CDR) + ld A (A) # Recurse on CARs + ld E (E) + call equalAE_F # Equal? + pop E # Retrieve CDRs + pop A + break ne # No: 'ne' + atom A # A's CDR atomic? + if nz # Yes + call equalAE_F # Compare with E's CDR + break T + end + atom E # E's CDR atomic? + break nz # Yes: 'ne' + cmp A (S I) # A circular? + break eq # Yes: 'eq' + cmp E (S) # E circular? + break eq # Yes: 'eq' + loop + pop A # Drop list heads + pop A + ret + +(code 'compareAE_F 0) # C + cmp A E # Pointer-equal? + jz ret # Yes + cmp A Nil + if eq # [NIL E] +10 or B B # nz +20 setc # lt + ret + end + cmp A TSym + if eq # [T E] +30 or B B # nz +40 clrc # gt + ret + end + num A # Number? + if nz # Yes + num E # Both? + jnz cmpNumAE_F # [<num> <num>] + cmp E Nil + jz 30 # [<num> NIL] + setc # lt + ret + end + sym A + if nz # [<sym> ..] + num E + jnz 40 # [<sym> <num>] + cmp E Nil + jz 30 # [<sym> NIL] + atom E + jz 10 # [<sym> <cell>] + cmp E TSym + jz 10 # [<sym> T] + push X # [<sym> <sym>] + ld X (A TAIL) + call nameX_X # Get A's name in X + zero X # Any? + if eq # No + ld E (E TAIL) + call nameE_E # Second name in E + zero E # Any? + if eq # No + rol B 4 # Random bit from A (...x1000) into carry (non-zero) + else + setc # lt + end + pop X + ret + end + ld E (E TAIL) + call nameE_E # Get E's name in E + zero E # Any? + if eq # No +50 or B B # nz +60 clrc # gt +70 pop X + ret + end + do + cnt X # Get next digit from X into A + if nz + ld A X # Short + shr A 4 # Normalize + ld X 0 + else + ld A (X DIG) # Get next digit + ld X (X BIG) + end + cnt E # Get next digit from E into C + if nz + ld C E # Short + shr C 4 # Normalize + ld E 0 + else + ld C (E DIG) # Get next digit + ld E (E BIG) + end + do + cmp B C # Bytes equal? + jnz 70 # No: lt or gt + shr A 8 # Next byte in A? + if z # No + shr C 8 # Next byte in C? + if nz # Yes + setc # lt + pop X + ret + end + null X # X done? + if z # Yes + null E # E also done? + jz 70 # Yes: eq + setc # lt + pop X + ret + end + null E # E done? + jz 50 # Yes: gt + break T + end + shr C 8 # Next byte in C? + jz 50 # No: gt + loop + loop + end + atom E + if nz # [<cell> <sym>] + cmp E TSym + if eq # [<cell> T] + or B B # nz + setc # lt + ret + end + clrc # gt + ret + end + push X # [<cell> <cell>] + push Y + ld X A # Keep originals + ld Y E + do + push A # Recurse on CAR + push E + ld A (A) + ld E (E) + call compareAE_F # Same? + pop E + pop A + while eq # Yes + ld A (A CDR) # Next elements + ld E (E CDR) + atom A # End of A? + if nz # Yes + call compareAE_F # Compare CDRs + break T + end + atom E # End of E? + if nz # Yes + cmp E TSym + if ne + clrc # gt [<cell> <atom>] + break T + end + or B B # nz [<cell> T] + setc # lt + break T + end + cmp A X # Circular list? + if eq + cmp E Y + break eq # Yes + end + loop + pop Y + pop X + ret # F + +(code 'memberXY_FY 0) + ld C Y # Keep head in C + do + atom Y # List? + while z # Yes + ld A X + ld E (Y) + call equalAE_F # Member? + jeq ret # Return list + ld Y (Y CDR) # Next item + cmp C Y # Hit head? + jeq retnz # Yes + loop + ld A X + ld E Y + jmp equalAE_F # Same atoms? + +# (quit ['any ['any]]) +(code 'doQuit 2) + ld X (E CDR) # Args + call evSymX_E # Evaluate to a symbol + call bufStringE_SZ # Write to stack buffer + ld X (X CDR) # Next arg? + atom X + ldnz E 0 # No + if z # Yes + ld E (X) + eval # Eval + end + ld X 0 # No context + ld Y QuitMsg # Format string + ld Z S # Buffer pointer + jmp errEXYZ # Jump to error handler +: QuitMsg asciz "%s" + +### Evaluation ### +# Apply EXPR in C to CDR of E +(code 'evExprCE_E 0) + push X + push Y + push Z + ld X (E CDR) # Get CDR + ld Y (C) # Parameter list in Y + ld Z (C CDR) # Body in Z + push (EnvBind) # Build bind frame + link + push (At) # Bind At + push At + do + atom Y # More evaluating parameters? + while z # Yes + ld E (X) # Get next argument + ld X (X CDR) + eval+ # Evaluate and save + push E + push (Y) # Save symbol + ld Y (Y CDR) + loop + cmp Y Nil # NIL-terminated parameter list? + if eq # Yes: Bind parameter symbols + ld Y S # Y on bindings + do + ld X (Y) # Symbol in X + add Y I + ld A (X) # Old value in A + ld (X) (Y) # Set new value + ld (Y) A # Save old value + add Y I + cmp Y L # End? + until eq # Yes + link + ld (EnvBind) L # Close bind frame + push 0 # Init env swap + prog Z # Run body + pop A # Drop env swap + pop L # Get link + do # Unbind symbols + pop X # Next symbol + pop (X) # Restore value + cmp S L # More? + until eq # No + pop L # Restore link + pop (EnvBind) # Restore bind link + pop Z + pop Y + pop X + ret + end + # Non-NIL parameter + cmp Y At # '@'? + if ne # No + push (Y) # Save last parameter's old value + push Y # and the last parameter + ld (Y) X # Set to unevaluated argument list + lea Y (S II) # Y on evaluated bindings + do + ld X (Y) # Symbol in X + add Y I + ld A (X) # Old value in A + ld (X) (Y) # Set new value + ld (Y) A # Save old value + add Y I + cmp Y L # End? + until eq # Yes + link + ld (EnvBind) L # Close bind frame + push 0 # Init env swap + prog Z # Run body + pop A # Drop env swap + pop L # Get link + do # Unbind symbols + pop X # Next symbol + pop (X) # Restore value + cmp S L # More? + until eq # No + pop L # Restore link + pop (EnvBind) # Restore bind link + pop Z + pop Y + pop X + ret + end + # Evaluated argument list + link # Close bind frame + ld Y L # Y on frame + push 0 # Init env swap + push (EnvNext) # Save current 'next' + push (EnvArgs) # and varArgs base + atom X # Any args? + if nz # No + ld (EnvArgs) 0 + ld (EnvNext) 0 + else + link # Build varArgs frame + do + ld E (X) # Get next argument + eval+ # Evaluate and save + push E + ld X (X CDR) + atom X # More args? + until nz # No + ld (EnvArgs) S # Set new varArgs base + ld (EnvNext) L # Set new 'next' + link # Close varArgs frame + end + ld (EnvBind) Y # Close bind frame + ld C (Y) # End of bindings in C + add Y I + do + ld X (Y) # Symbol in X + add Y I + ld A (X) # Old value in A + ld (X) (Y) # Set new value + ld (Y) A # Save old value + add Y I + cmp Y C # End? + until eq # Yes + prog Z # Run body + null (EnvNext) # VarArgs? + if nz # Yes + drop # Drop varArgs + end + pop (EnvArgs) # Restore varArgs base + pop (EnvNext) # and 'next' + pop A # Drop env swap + pop L # Get link + do # Unbind symbols + pop X # Next symbol + pop (X) # Restore value + cmp S L # More? + until eq # No + pop L # Restore link + pop (EnvBind) # Restore bind link + pop Z + pop Y + pop X + ret + +# Evaluate a list +(code 'evListE_E 0) + ld C (E) # Get CAR in C + num C # Number? + jnz ret # Yes: Return list + sym C # Symbol? + if nz # Yes +10 do # C is a symbol + nul (Signal) # Signal? + if nz # Yes + push E + call sighandlerE + pop E + end + ld A (C) # Get VAL + cnt A # Short number? + jnz (A) # Yes: Eval SUBR + big A # Undefined if bignum + jnz undefinedCE + cmp A (A) # Auto-symbol? + if ne # No + ld C A + atom C # Symbol? + jz evExprCE_E # No: Apply EXPR + else + call sharedLibC_FA # Try dynamic load + jnz (A) # Eval SUBR + jmp undefinedCE + end + loop + end + push E + ld E C + call evListE_E + ld C E + pop E + cnt C # Short number? + jnz (C) # Yes: Eval SUBR + big C # Undefined if bignum + jnz undefinedCE + link + push C # Save function + link + atom C # Symbol? + if z + call evExprCE_E # No: Apply EXPR + else + call 10 + end + drop + ret + +(code 'sharedLibC_FA) + push C + push E + push Y + push Z + ld E C # Get symbol in E + call bufStringE_SZ # Write to stack buffer + ld C 0 + ld Y S # Search for colon and slash + do + ld B (Y) # Next byte + or B B # End of string? + jz 90 # Yes + cmp B (char ":") # Colon? + while ne # No + cmp B (char "/") # Slash? + if eq # Yes + ld C Y # Keep pointer to slash + end + add Y 1 # Increment buffer pointer + loop + cmp Y Z # At start of buffer? + jz 90 # Yes + nul (Y 1) # At end of buffer? + jz 90 # Yes + set (Y) 0 # Replace colon with null byte + add Y 1 # Point to token + null C # Contained '/'? + ld C S # Pointer to lib name + if z # No + sub S 8 # Extend buffer + sub C 4 # Prepend "lib/" + set (C 3) (char "/") + set (C 2) (char "b") + set (C 1) (char "i") + set (C) (char "l") + ld A (Home) # Home directory? + null A + if nz # Yes + do + add A 1 # Find end + nul (A) + until z + sub A (Home) # Calculate length + sub C A # Adjust buffer + ld S C + off S 7 + movn (C) ((Home)) A # Insert home path + end + end + cc dlopen(C (| RTLD_LAZY RTLD_GLOBAL)) # Open dynamic library + null A # OK? + if nz # Yes + cc dlsym(A Y) # Find dynamic symbol + null A # OK? + if nz # Yes + ld (E) A # 'nz' - Set function definition + end + end +90 ld S Z # Drop buffer + pop Z + pop Y + pop E + pop C + ret + +# (errno) -> cnt +(code 'doErrno 2) + call errno_A # Get 'errno' + ld E A + shl E 4 # Make short number + or E CNT + ret + +# (native 'cnt1|sym1 'cnt2|sym2 'sym|lst 'any ..) -> any +(code 'doNative 2) + push X + push Y + push Z + ld X E + ld Y (E CDR) # Y on args + ld E (Y) # Eval library 'cnt1|sym1' + eval + cnt E # Library handle? + if nz # Yes + shr E 4 # Normalize + push E # <S> Library handle + else + big E # Library handle? + if nz # Yes + push (E DIG) # <S> Library handle + else + call needSymEX # Check symbol + call bufStringE_SZ # Write to stack buffer + ld C S # Preload name pointer + ld B (S) # Check for main program library + cmp B (char "@") # "@"? + if eq + nul (S 1) + ldz C 0 # Yes: Use NULL pointer + end + cc dlopen(C (| RTLD_LAZY RTLD_GLOBAL)) # Open dynamic library + null A # OK? + jz dlErrX # No + ld S Z # Drop buffer + push A # <S> Library handle + test A (hex "F000000000000000") # Fit in short number? + if z # Yes + shl A 4 # Make short number + or A CNT + else + call boxNumA_A # Make bignum + end + ld (E) A # Set value of 'sym1' + end + end + ld Y (Y CDR) # Second arg + ld E (Y) # Eval function 'cnt2|sym2' + eval + ld Z S # Stack marker in Z + cnt E # Function pointer? + if nz # Yes + shr E 4 # Normalize + ld (S) E # <Z> Function pointer + else + big E # Function pointer?? + if nz # Yes + ld (S) (E DIG) # <Z> Function pointer + else + call needSymEX # Check symbol + call bufStringE_SZ # Write to stack buffer + cc dlsym((Z) S) # Find dynamic symbol + null A # OK? + jz dlErrX # No + ld S Z # Drop buffer + ld (S) A # <Z> Function pointer + test A (hex "F000000000000000") # Fit in short number? + if z # Yes + shl A 4 # Make short number + or A CNT + else + call boxNumA_A # Make bignum + end + ld (E) A # Set value + end + end + ld Y (Y CDR) # Third arg + ld E (Y) # Eval result specification + eval + link + push E # <Z -II> Result specification + do + ld Y (Y CDR) # Arguments? + atom Y + while z # Yes + ld E (Y) # Eval argument specification + eval+ + push E + loop + ld X S # X on last argument + link + lea Y (Z -II) # Limit + do + cmp X Y # More args? + while ne # Yes + ld E (X) # Argument specification + num E # Number? + if nz # Yes + cnt E # Short? + if nz # Yes + shr E 4 # Normalize + if c # Sign? + neg E # Yes + end + else + test E SIGN # Get sign + push F # Save + off E (| SIGN BIG) # Get cell pointer + ld A (E CDR) # High word + ld E (E) # Low word + shr A 5 # Get highest four bits + rcr E 1 + shr A 1 + rcr E 1 + shr A 1 + rcr E 1 + shr A 1 + rcr E 1 + pop F # Negative + if nz # Yes + neg E # Negate + end + end + else + push Z + sym E # String? + if nz # Yes + call bufStringE_SZ # Write to stack buffer + cc strdup(S) # Make new string + ld E A # Get string pointer + ld S Z # Drop buffer + else + ld E (E CDR) # Ignore variable + ld C ((E)) # Get buffer size + shr C 4 # Normalize + cc malloc(C) # Allocate buffer + push A # Save it + ld Z A # Buffer pointer in Z + do + ld E (E CDR) + cnt E # Fill rest? + if nz # Yes + ld A E # Byte value + shr A 4 # in B + do + sub C 1 # Done? + while ns # No + ld (Z) B # Store byte in buffer + add Z 1 # Increment buffer pointer + loop + break T + end + atom E # Fill bytes? + while z # Yes + ld A (E) # Next byte value + shr A 4 # in B + ld (Z) B # Store in buffer + add Z 1 # Increment buffer pointer + sub C 1 # Buffer full? + until z # Yes + pop E # Get allocated memory + end + pop Z + end + push E # Push argument + add X I # Next arg + loop + ld X S # Start of args + ld C L # Top of args + sub C X # Bytes + sub S C # Duplicate + movn (S) (X) C + ld Y (Z) # Get function pointer + cc (Y) X # Call C-function + ld E (Z -II) # Get result specification + ld C 0 # No pointer yet + call natRetACE_CE # Extract return value + ld (Z -II) E # Save result + lea Y (Z -III) # Clean up allocated C args + do + cmp Y L # Args? + while ne # Yes + pop X # Next C arg + ld E (Y) # Next Lisp arg + num E # Number? + if z # No + sym E # String? + if z # No + cmp (E) Nil # Variable? + if ne # Yes + ld C X # Structure pointer + ld E (((E CDR)) CDR) # Result specification + call natRetACE_CE # Extract value + ld (((Y))) E # Store in variable + end + end + cc free(X) # Free string or buffer + end + sub Y I + loop + ld E (Z -II) # Get result + drop + pop A # Drop library handle + pop Z + pop Y + pop X + ret + +(code 'natRetACE_CE 0) + cmp E Nil # NIL? + if ne + cmp E ISym # 'I'? + if eq # Yes + null C # Pointer? + if nz # Yes + ld4 (C) + add C 4 # Size of int + end + int # Integer + ld E A + null E # Negative? + if ns # No + shl E 4 # Make short number + or E CNT + else + neg E # Negate + shl E 4 # Make negative short number + or E (| SIGN CNT) + end + else + cmp E NSym # 'N'? + if eq # Yes + null C # Pointer? + if nz # Yes + ld A (C) + add C 8 # Size of long/pointer + end + ld E A # Number + null E # Negative? + if ns # No + test E (hex "F000000000000000") # Fit in short? + if z # Yes + shl E 4 # Make short number + or E CNT + else + call boxNumE_E # Make bignum + end + else + neg E # Negate + test E (hex "F000000000000000") # Fit in short? + if z # Yes + shl E 4 # Make negative short number + or E (| SIGN CNT) + else + call boxNumE_E # Make bignum + or E SIGN # Set negative + end + end + else + cmp E SSym # 'S'? + if eq # Yes + null C # Pointer? + if nz # Yes + ld A (C) + add C 8 # Size of pointer + end + ld E A # Make transient symbol + call mkStrE_E + else + cmp E CSym # 'C'? + if eq # Yes + null C # Pointer? + if nz # Yes + call fetchCharC_AC # Fetch char + end + ld E Nil # Preload + null A # Char? + if nz # Yes + call mkCharA_A # Make char + ld E A + end + else + cmp E BSym # 'B'? + if eq # Yes + null C # Pointer? + if nz # Yes + ld B (C) + add C 1 # Size of byte + end + zxt # Byte + ld E A + shl E 4 # Make short number + or E CNT + else + atom E # Atomic? + if z # No: Arrary or structure + null C # Pointer? + ldz C A # Yes: Load into C + push X + push Y + push Z + ld X E # Get specification in X + ld E (X) + call natRetACE_CE # First item + call cons_Y # Make cell + ld (Y) E + ld (Y CDR) Nil + link + push Y # <L I> Result + link + do + ld Z (X CDR) + cnt Z # (sym . cnt) + if nz + shr Z 4 # Normalize + do + sub Z 1 # Decrement count + while nz + ld E (X) # Repeat last type + call natRetACE_CE # Next item + call cons_A # Cons into cell + ld (A) E + ld (A CDR) Nil + ld (Y CDR) A # Append to result + ld Y A + loop + break T + end + atom Z # End of specification? + while z # No + ld X Z + ld E (X) # Next type + call natRetACE_CE # Next item + call cons_A # Cons into cell + ld (A) E + ld (A CDR) Nil + ld (Y CDR) A # Append to result + ld Y A + loop + ld E (L I) # Get result + drop + pop Z + pop Y + pop X + end + end + end + end + end + end + end + ret + +(code 'fetchCharC_AC 0) + ld B (C) # Fetch first byte + zxt + or B B # Any? + if nz # Yes + add C 1 + cmp B 128 # Single byte? + if ge # No + test B (hex "20") # Two bytes? + if z # Yes + and B (hex "1F") # First byte 110xxxxx + shl A 6 # xxxxx000000 + push A + else # Three bytes + and B (hex "F") # First byte 1110xxxx + shl A 6 # xxxx000000 + push A + ld B (C) # Fetch second byte + zxt + add C 1 + and B (hex "3F") # 10xxxxxx + or A (S) # Combine + shl A 6 # xxxxxxxxxx000000 + ld (S) A + end + ld B (C) # Fetch last byte + zxt + add C 1 + and B (hex "3F") # 10xxxxxx + or (S) A # Combine + pop A # Get result + end + end + ret + +(code 'lisp 0) + begin 6 # Function name in A, arguments in C, E, X, Y and Z + link # Apply args + push ZERO # Space for 'fun' + xchg C E # First arg + call boxCntE_E # Make number + push E + ld E C # Second arg + call boxCntE_E # Make number + push E + ld E X # Third arg + call boxCntE_E # Make number + push E + ld E Y # Fourth arg + call boxCntE_E # Make number + push E + ld E Z # Fifth arg + call boxCntE_E # Make number + push E + ld Z S # Z on last argument + link # Close frame + ld C 4 # Build name + ld E A # Function name argument + lea X (S VI) # Pointer to 'fun' entry + do + ld B (E) + call byteSymBCX_CX # Pack byte + add E 1 # Next byte + nul (E) # Any? + until z + ld X (S VI) # Get name + call findSymX_E # Find or create symbol + lea Y (S VI) # Pointer to 'fun' in Y + ld (Y) E # Store 'fun' + call applyXYZ_E # Apply + ld A E # Return value + shr A 4 # Normalize + if c # Sign? + neg A # Yes + end + drop + return 6 + +(code 'execE 0) + push X + ld X E + link + push (At) # <L I> Preserve '@' + link + exec X # Execute body + ld (At) (L I) + drop + pop X + ret + +(code 'runE_E 0) + push X + ld X E + link + push (At) # <L I> Preserve '@' + link + prog X # Run body + ld (At) (L I) + drop + pop X + ret + +(code 'funqE_FE 0) + cnt E # Short number? + jnz retz # Yes + big E # Big number? + jnz ret # No + sym E # Symbol? + jnz ret # Yes + ld C (E CDR) # Check function body + do + atom C # More? + while z # Yes + cmp C E # Circular? + jeq retnz # Yes + ld A (C) # Next item + atom A # Cell? + if z # Yes + num (A) # CAR a number? + if nz # Yes + atom (C CDR) # Must be the last + jz retnz + else + cmp (A) Nil # CAR is NIL? + jeq retnz # Yes + cmp (A) TSym # CAR is T? + jeq retnz # Yes + end + else + cmp (C CDR) Nil # Atomic item must be the last + jne ret + end + ld C (C CDR) + loop + cmp C Nil # Must be NIL-terminated + jne ret + ld E (E) # Get parameter(s) + cmp E Nil # Any? + ldz E TSym # No: Return T + if ne # Yes + ld C E + do + atom C # Atomic parameter? + while z # No + ld A (C) # Next parameter + num A # Number? + jnz ret # Yes + atom A # List? + jz retnz # Yes + cmp A Nil # NIL? + jeq retnz # Yes + cmp A TSym # T? + jeq retnz # Yes + ld C (C CDR) # Rest + cmp C E # Circular? + jeq retnz # Yes + loop + cmp C TSym # T? + jeq retnz # Yes + num C # Number? + jnz ret # Yes + end + ret + +(code 'evSymX_E 0) + ld E (X) # Get CAR + jmp evSymE_E +(code 'evSymY_E 0) + ld E (Y) # Get CAR +(code 'evSymE_E) + eval # Evaluate +(code 'xSymE_E) + num E # Number? + if z # No + sym E # Symbol? + jnz ret # Yes + end + push X + link + push E # Save 'any' + push ZERO # <L II> Number safe + push ZERO # <L I> Result + ld C 4 # Build name + ld X S + link + call packECX_CX + ld X (L I) # Get result + call consSymX_E # Make transient symbol + drop + pop X + ret + +(code 'evCntXY_FE 0) + ld E (Y) # Get CAR +(code 'evCntEX_FE) + eval # Evaluate +(code 'xCntEX_FE 0) + cnt E # # Short number? + jz cntErrEX # No + shr E 4 # Normalize + if c # Sign? + neg E # Yes + end + ret # 'z' if null, 's' if negative + +(code 'xCntCX_FC 0) + cnt C # # Short number? + jz cntErrCX # No + shr C 4 # Normalize + if c # Sign? + neg C # Yes + end + ret # 'z' if null, 's' if negative + +(code 'xCntAX_FA 0) + cnt A # # Short number? + jz cntErrAX # No + shr A 4 # Normalize + if c # Sign? + neg A # Yes + end + ret # 'z' if null, 's' if negative + +(code 'boxCntE_E 0) + null E # Positive? + if ns # Yes + shl E 4 # Make short number + or E CNT + ret + end + neg E # Else negate + shl E 4 # Make short number + or E 10 # with SIGN + ret + +(code 'putStringB 0) + push X + push C + ld X (StrX) # Get string status + ld C (StrC) + call byteSymBCX_CX # Add byte to result + ld (StrC) C # Save string status + ld (StrX) X + pop C + pop X + ret + +(code 'begString 0) + pop A # Get return address + link + push ZERO # <L I> Result + ld (StrC) 4 # Build name + ld (StrX) S + link + push (EnvPutB) # Save 'put' + ld (EnvPutB) putStringB # Set new + jmp (A) # Return + +(code 'endString_E 0) + pop A # Get return address + pop (EnvPutB) # Restore 'put' + ld E Nil # Preload NIL + cmp (L I) ZERO # Name? + if ne # Yes + call cons_E # Cons symbol + ld (E) (L I) # Set name + or E SYM # Make symbol + ld (E) E # Set value to itself + end + drop + jmp (A) # Return + +(code 'msec_A) + push C + cc gettimeofday(Buf 0) # Get time + ld A (Buf) # tv_sec + mul 1000 # Convert to milliseconds + ld (Buf) A # Save + ld A (Buf I) # tv_usec + div 1000 # Convert to milliseconds (C is zero) + add A (Buf) + pop C + ret + +# (args) -> flg +(code 'doArgs 2) + cmp (EnvNext) (EnvArgs) # VarArgs? + ld E Nil + ldnz E TSym # Yes + ret + +# (next) -> any +(code 'doNext 2) + ld C (EnvNext) # VarArgs + cmp C (EnvArgs) # Any? + if ne # Yes + sub C I # Get next + ld E (C) + ld (EnvNext) C + ret + end + ld E Nil # No (more) arguments + null C # Any previous arg? + if nz # Yes + ld (C) E # Set to NIL + end + ret + +# (arg ['cnt]) -> any +(code 'doArg 2) + null (EnvArgs) # Any args? + jz retNil # No + ld E (E CDR) # 'cnt' arg? + atom E + if nz # No + ld E ((EnvNext)) # Return arg from last call to 'next' + ret + end + ld E (E) + eval # Eval 'cnt' + test E SIGN # Negative? + if z # No + shr E 1 # Normalize to word index + off E 1 # Clear 'cnt' tag + if nz # Greater zero + ld C (EnvNext) # VarArgs + sub C E # Subtract from VarArgs pointer + cmp C (EnvArgs) # Out of range? + if ge # No + ld E (C) # Get value + ret + end + end + end + ld E Nil + ret + +# (rest) -> lst +(code 'doRest 2) + ld E Nil # Return value + ld C (EnvArgs) # VarArgs + do + cmp C (EnvNext) # Any? + while ne # Yes + call consE_A # New cell + ld (A) (C) + ld (A CDR) E + ld E A + add C I # Next + loop + ret + +(code 'tmDateC_E 0) + ld4 (C TM_MDAY) # Get day + ld X A + ld4 (C TM_MON) # month + add A 1 + ld Y A + ld4 (C TM_YEAR) # and year + add A 1900 + ld Z A +# Date function +(code 'dateXYZ_E 0) + cmp Y 0 # Month <= 0? + jle retNil + cmp Y 12 # Month > 12? + jgt retNil + cmp X 0 # Day <= 0? + jle retNil + ld B (Y Month) # Max monthly days + cmp X B # Day > max? + if gt # Yes + cmp Y 2 # February? + jne retNil + cmp X 29 # 29th? + jne retNil + test Z 3 # year a multiple of 4? + jnz retNil + ld A Z # Year + ld C 0 + div 100 + null C # Multiple of 100? + if z # Yes + ld A Z # Year + div 400 + null C # Multiple of 400? + jnz retNil + end + end + ld A Z # Get year + mul 12 # times 12 + add A Y # plus month + sub A 3 # minus 3 + ld C 0 + div 12 # divide by 12 + ld E A # n = (12 * year + month - 3) / 12 + ld C 0 + div 100 # divide by 100 + ld C E + shr E 2 # n/4 + add C C # n*2 + sub E C # n/4 - n*2 + sub E A # n/4 - n*2 - n/100 + shr A 2 # n/400 + add E A # E = n/4 - n*2 - n/100 + n/400 + ld A Z # Year + mul 4404 # times 4404 + ld Z A + ld A Y # Month + mul 367 # times 367 + add A Z # plus year*4404 + sub A 1094 # minus 1094 + div 12 # A = (4404*year + 367*month - 1094) / 12 + add E A # Add up + add E X # plus days + shl E 4 # Make short number + or E CNT + ret +: Month bytes (31 31 28 31 30 31 30 31 31 30 31 30 31) + +# (date ['T]) -> dat +# (date 'dat) -> (y m d) +# (date 'y 'm 'd) -> dat | NIL +# (date '(y m d)) -> dat | NIL +(code 'doDate 2) + push X + push Y + push Z + ld X E + ld Y (E CDR) # Y on args + atom Y # Any? + if nz # No + cc time(Buf) # Get current time + cc localtime(Buf) # Convert to local time + ld (Time) A # Keep in 'Time' + ld C A + call tmDateC_E # Extract date + else + ld E (Y) # Eval first + eval + cmp E TSym # T? + if eq # Yes + cc time(Buf) # Get current time + cc gmtime(Buf) # Convert to Greenwich Mean Time + ld (Time) A # Keep in 'Time' + ld C A + call tmDateC_E # Extract date + else + cmp E Nil # NIL? + if ne # No + atom E # List? + if z # Yes + ld C (E) # Extract year + call xCntCX_FC + ld Z C + ld E (E CDR) + ld C (E) # month + call xCntCX_FC + ld Y C + ld C ((E CDR)) # and day + call xCntCX_FC + ld X C + call dateXYZ_E + else + ld Y (Y CDR) # More args? + atom Y + if nz # No + call xCntEX_FE # Get date + ld A E # 100 * n + mul 100 + sub A 20 # minus 20 + ld C 0 # divide by 3652425 + div 3652425 + ld Z A # year = (100*n - 20) / 3652425 + add E A # n += (year - year/4) + shr A 2 + sub E A + ld A E # n + mul 100 # 100 * n + sub A 20 # minus 20 + div 36525 # divide by 36525 + ld Z A # year = (100*n - 20) / 36525 + mul 36525 # times 36525 + div 100 # divide by 100 + sub E A # n -= 36525*y / 100 + ld A E # n + mul 10 # times 10 + sub A 5 # minus 5 + div 306 # divide by 306 + ld Y A # month = (10*n - 5) / 306 + mul 306 # times 306 + ld X A + ld A E # n + mul 10 # times 10 + sub A X # minus 306*month + add A 5 # push 5 + div 10 # divide by 10 + ld X A # day = (10*n - 306*month + 5) / 10 + cmp Y 10 # month < 10? + if lt # Yes + add Y 3 # month += 3 + else + add Z 1 # Increment year + sub Y 9 # month -= 9 + end + shl X 4 # Make short day + or X CNT + call cons_E # into cell + ld (E) X + ld (E CDR) Nil + shl Y 4 # Make short month + or Y CNT + call consE_C # Cons + ld (C) Y + ld (C CDR) E + shl Z 4 # Make short year + or Z CNT + call consC_E # Cons + ld (E) Z + ld (E CDR) C + else + call xCntEX_FE # Extract year + ld Z E # into Z + call evCntXY_FE # Eval month + push E # Save + ld Y (Y CDR) # Eval day + call evCntXY_FE + ld X E # Get day + pop Y # and month + call dateXYZ_E + end + end + end + end + end + pop Z + pop Y + pop X + ret + +(code 'tmTimeY_E 0) + ld4 (Y TM_HOUR) # Get hour + mul 3600 + ld E A + ld4 (Y TM_MIN) # Get minute + mul 60 + add E A + ld4 (Y TM_SEC) # Get second + add E A + shl E 4 # Make short number + or E CNT + ret + +# (time ['T]) -> tim +# (time 'tim) -> (h m s) +# (time 'h 'm ['s]) -> tim | NIL +# (time '(h m [s])) -> tim | NIL +(code 'doTime 2) + push X + push Y + ld Y (E CDR) # Y on args + atom Y # Any? + if nz # No + cc time(Buf) # Get current time + cc localtime(Buf) # Convert to local time + ld Y A + call tmTimeY_E # Extract time + else + ld E (Y) # Eval first + eval + cmp E TSym # T? + if eq # Yes + ld Y (Time) # Get time from last call to 'date' + null Y # Any? + if nz # Yes + call tmTimeY_E # Extract time + else + ld E Nil + end + else + cmp E Nil # NIL? + if ne # No + atom E # List? + if z # Yes + ld A (E) # Extract hour + call xCntAX_FA + mul 3600 + ld Y A + ld E (E CDR) + ld A (E) # minute + call xCntAX_FA + mul 60 + add Y A + ld E (E CDR) # and second + atom E # Any? + ldnz E Y # No + if z # Yes + ld E (E) + call xCntEX_FE + add E Y # add minutes and hours + end + shl E 4 # Make short number + or E CNT + else + ld Y (Y CDR) # More args? + atom Y + if nz # No + call xCntEX_FE # Get time in total seconds + ld A E + ld C 0 + div 60 # Seconds in C + shl C 4 # Make short number + or C CNT + call cons_Y # into cell + ld (Y) C + ld (Y CDR) Nil + ld A E + ld C 0 + div 60 # Total minutes in A + ld C 0 + div 60 # Minutes in C + shl C 4 # Make short number + or C CNT + call consY_X + ld (X) C + ld (X CDR) Y + xchg A E # Get total seconds again + ld C 0 + div 3600 # Hours in A + shl A 4 # Make short number + or A CNT + call consX_E + ld (E) A + ld (E CDR) X + else + call xCntEX_FE # Extract hour + ld A E + mul 3600 + push A # Save hour + call evCntXY_FE # Eval minute + ld A E + mul 60 + add (S) A # Add to hour + ld Y (Y CDR) # Eval second + atom Y # Any? + if z # Yes + call evCntXY_FE + add (S) E + end + pop E # Get result + shl E 4 # Make short number + or E CNT + end + end + end + end + end + pop Y + pop X + ret + +# (usec) -> num +(code 'doUsec 2) + cc gettimeofday(Buf 0) # Get time + ld A (Buf) # tv_sec + mul 1000000 # Convert to microseconds + add A (Buf I) # tv_usec + sub A (USec) # Diff to startup time + ld E A + shl E 4 # Make short number + or E CNT + ret + +# (pwd) -> sym +(code 'doPwd 2) + cc getcwd(0 0) # Get current working directory + null A # OK? + jz retNil # No + push A # Save buffer pointer + ld E A # Make transient symbol + call mkStrE_E + cc free(pop) # Free buffer + ret + +# (cd 'any) -> sym +(code 'doCd 2) + push Z + ld E ((E CDR)) # Get arg + call evSymE_E # Evaluate to a symbol + call pathStringE_SZ # Write to stack buffer + ld E Nil # Preload return value + cc getcwd(0 0) # Get current working directory + null A # OK? + if nz # Yes + push A # Save buffer pointer + nul (S I) # CWD empty? + jz 10 # Yes + cc chdir(&(S I)) # Stack buffer + nul4 # OK? + if z # Yes +10 ld E (S) # Make transient symbol + call mkStrE_E + end + cc free(pop) # Free buffer + end + ld S Z # Drop buffer + pop Z + ret + +# (ctty 'sym|pid) -> flg +(code 'doCtty 2) + push X + ld X E + ld E ((E CDR)) # E on arg + eval # Eval it + cnt E # 'pid'? + if nz # Yes + shr E 4 # Normalize + ld (TtyPid) E # Keep in global + ld E TSym # Return T + else + sym E # Need symbol + jz argErrEX + push Z + call bufStringE_SZ # Write to stack buffer + ld E Nil # Preload return value + cc freopen(S _r_ (stdin)) # Re-open standard input + null A # OK? + if nz # Yes + cc freopen(S _w_ (stdout)) # Re-open standard output + null A # OK? + if nz # Yes + cc freopen(S _w_ (stderr)) # Re-open standard error + null A # OK? + if nz # Yes + ld (((OutFiles) I) II) 1 # (stdout) OutFiles[1]->tty + ld E TSym # Return T + end + end + end + ld S Z # Drop buffer + pop Z + end + pop X + ret + +# (info 'any) -> (cnt|T dat . tim) +(code 'doInfo 2) + push X + push Y + push Z + ld E ((E CDR)) # Get arg + call evSymE_E # Evaluate to a symbol + call pathStringE_SZ # Write to stack buffer + ld E S # path name pointer + sub S STAT # 'stat' structure + cc stat(E S) # Get status + ld E Nil # Preload return value + nul4 # 'stat' OK? + if ns + cc gmtime(&(S ST_MTIME)) # Get modification time + ld Y A # Keep time pointer in Y + call tmTimeY_E # Extract time + push E # Save time + push Z + ld C Y # Extract date + call tmDateC_E + pop Z + call cons_X # New cell + ld (X) E # Set date + pop (X CDR) # and time + call consX_E # New cell + call s_isdirS_F # Directory? + if eq # Yes + ld (E) TSym # CAR is T + else + ld A (S ST_SIZE) # Get size + shl A 4 # Make short number + or A CNT + ld (E) A + end + ld (E CDR) X + end + ld S Z # Drop buffers + pop Z + pop Y + pop X + ret + +# (file) -> (sym1 sym2 . num) | NIL +(code 'doFile 2) + ld C (InFile) # Current InFile? + null C + jz retNil # No + ld E (C VI) # Filename? + null E + jz retNil # No + ld B (char "/") # Contains a slash? + slen C E # String length in C + memb E C + if eq # Yes + do + memb E C # Find last one + until ne + push Z + ld Z E # Pointer to rest + sub Z 1 # without slash in Z + call mkStrE_E # Make string + call consE_C # Cons + ld (C) E + ld A ((InFile) V) # with 'src' + shl A 4 # Make short number + or A CNT + ld (C CDR) A + link + push C # Save + link + ld E ((InFile) VI) # Filename again + call mkStrEZ_A # Make string up to Z + call consA_E # Cons into list + ld (E) A + ld (E CDR) (L I) + drop + pop Z + else + call mkStrE_E # Make string + call consE_C # Cons + ld (C) E + ld A ((InFile) V) # with 'src' + shl A 4 # Make short number + or A CNT + ld (C CDR) A + call consC_A # Cons symbol + ld (A) (hex "2F2E2") # "./" + or A SYM # Make symbol + ld (A) A # Set value to itself + call consAC_E # Cons into list + ld (E) A + ld (E CDR) C + end + ret + +# (dir ['any]) -> lst +(code 'doDir 2) + push Z + ld E ((E CDR)) # Get arg + call evSymE_E # Evaluate to a symbol + cmp E Nil # NIL? + if eq # Yes + cc opendir(_dot_) # Open "." directory + else + call pathStringE_SZ # Write to stack buffer + cc opendir(S) # Open directory + ld S Z # Drop buffer + end + null A # OK? + jz 10 # No + ld Z A # Get directory pointer + do + cc readdir(Z) # Find first directory entry + null A # OK? + if z # No +10 ld E Nil # Return NIL + pop Z + ret + end + lea E (A D_NAME) # Pointer to name entry + ld B (E) # First char + cmp B (char ".") # Skip dot names + until ne + call mkStrE_E # Make transient symbol + call consE_C # Cons first cell + ld (C) E + ld (C CDR) Nil + link + push C # <L I> Result + link + do + cc readdir(Z) # Read next directory entry + null A # OK? + while nz # Yes + lea E (A D_NAME) # Pointer to name entry + ld B (E) # First char + cmp B (char ".") # Ignore dot names + if ne + call mkStrE_E # Make transient symbol + call consE_A # Cons next cell + ld (A) E + ld (A CDR) Nil + ld (C CDR) A # Concat to result + ld C A + end + loop + ld E (L I) # Get result + drop + cc closedir(Z) # Close directory + pop Z + ret + +# (cmd ['any]) -> sym +(code 'doCmd 2) + ld E ((E CDR)) # Get arg + call evSymE_E # Evaluate to a symbol + cmp E Nil # NIL? + if eq + ld E (AV0) # Return invocation command + jmp mkStrE_E # Return transient symbol + end + push Z + call bufStringE_SZ # Write to stack buffer + slen C S # String length in C + add C 1 # plus null byte + movn ((AV0)) (S) C # Copy to system buffer + ld S Z # Drop buffer + pop Z + ret + +# (argv [var ..] [. sym]) -> lst|sym +(code 'doArgv 2) + push X + push Y + push Z + ld X E + ld Y (E CDR) # Y on args + ld Z (AV) # Command line vector + ld E (Z) + null E # Empty? + if nz # No + ld B (E) # Single-dash argument? + cmp B (char "-") + if eq + nul (E 1) + if z # Yes + add Z I # Skip "-" + end + end + end + cmp Y Nil # Any args? + if eq # No + ld E Nil # Preload return value + null (Z) # More command line arguments? + if nz # Yes + ld E (Z) # Next + call mkStrE_E # Make transient symbol + call consE_C # First result cell + ld (C) E + ld (C CDR) Nil + link + push C # <L I> Result + link + do + add Z I # Next command line argument + null (Z) # Any? + while nz # Yes + ld E (Z) # Get it + call mkStrE_E # Make transient symbol + call consE_A # Next result cell + ld (A) E + ld (A CDR) Nil + ld (C CDR) A # Concat to result + ld C A + loop + ld E (L I) # Get result + drop + end + else + do + atom Y # Atomic tail? + while z # No + ld E (Y) # Next 'var' + call needVarEX + ld E (Z) # Next command line argument + null E # Any? + if nz # No + add Z I # Increment command line index + end + call mkStrE_E # Make transient symbol + ld ((Y)) E # Set value + ld Y (Y CDR) # Next arg + cmp Y Nil # End of list? + jeq 90 # Yes + loop + num Y # Need symbol + jnz symErrYX + call checkVarYX # Check variable + ld E (Z) # Next command line argument + null E # Any? + if z # No + ld E Nil # Set and return NIL + ld (Y) E + else + call mkStrE_E # Make transient symbol + call consE_C # First result cell + ld (C) E + ld (C CDR) Nil + link + push C # <L I> Result + link + do + add Z I # Next command line argument + null (Z) # Any? + while nz # Yes + ld E (Z) # Get it + call mkStrE_E # Make transient symbol + call consE_A # Next result cell + ld (A) E + ld (A CDR) Nil + ld (C CDR) A # Concat to result + ld C A + loop + ld E (L I) # Get and set result + ld (Y) E + drop + end + end +90 pop Z + pop Y + pop X + ret + +# (opt) -> sym +(code 'doOpt 2) + ld E ((AV)) # Command line vector + null E # Next string pointer? + jz retNil # No + ld B (E) # Single-dash argument? + cmp B (char "-") + if eq + nul (E 1) + jz retNil # Yes + end + add (AV) I # Increment vector pointer + jmp mkStrE_E # Return transient symbol + +# (version ['flg]) -> lst +(code 'doVersion 2) + ld E ((E CDR)) # Eval flg + eval + cmp E Nil # Suppress output? + if eq # No + ld E Version # Print version + do + ld A (E) # Next number + shr A 4 # Normalize + call outWordA # Print it + ld E (E CDR) # More numbers? + atom E + while z # Yes + ld B `(char ".") # Output dot + call (EnvPutB) + loop + call newline + end + ld E Version # Return version + ret + +# vi:et:ts=3:sw=3 diff --git a/src64/mkAsm b/src64/mkAsm @@ -0,0 +1,14 @@ +#!../bin/picolisp ../lib.l +# 16feb10abu + +(load "@lib/misc.l") +(setq *Architecture (opt) *System (opt) *TargetOS (opt) *Module (opt)) + +(load "lib/asm.l" (pack "arch/" *Architecture ".l")) + +(build (pack *Architecture "." *System "." *Module ".s") (opt) + (load "defs.l" (pack "sys/" *System ".defs.l") T) ) + +(bye) + +# vi:et:ts=3:sw=3 diff --git a/src64/net.l b/src64/net.l @@ -0,0 +1,336 @@ +# 30sep09abu +# (c) Software Lab. Alexander Burger + +# (port ['T] 'cnt|(cnt . cnt) ['var]) -> cnt +(code 'doPort 2) + push X + push Y + push Z + ld X E + ld Y (E CDR) # Y on args + ld Z SOCK_STREAM # Type defaults to TCP + ld E (Y) # Eval first arg + eval + cmp E TSym # 'T'? + if eq # Yes + ld Z SOCK_DGRAM # Type UDP + ld Y (Y CDR) # Eval next arg + ld E (Y) + eval + end + cc socket(AF_INET Z 0) # Create socket + nul4 # OK? + js ipSocketErrX # No + ld C A # Keep socket in C + call closeOnExecAX + ld B 0 # Clear socket structure + mset (Addr) SOCKADDR_IN + ld A AF_INET + st2 (Addr SIN_FAMILY) + cc htonl(INADDR_ANY) + st4 (Addr SIN_ADDR.S_ADDR) + cnt E # Single port-argument? + if nz # Yes + shr E 4 # Port zero? + if nz # No + ld A 1 # Socket option value + st4 (Buf) # Store into 'optval' + cc setsockopt(C SOL_SOCKET SO_REUSEADDR Buf 4) # "Reuse socket" option + nul4 # OK? + js ipSetsockoptErrX # No + end + push 0 # <S> No range limit + else + atom E # Port range? + jnz argErrEX # No + ld A (E CDR) # Get second port + ld E (E) # First port + shr E 4 # Range start + shr A 4 # Normalize second port + push A # <S> Range limit + end + do + cc htons(E) # Convert port to network order + st2 (Addr SIN_PORT) # Store as port + cc bind(C Addr SOCKADDR_IN) # Try to bind socket + nul4 # OK? + while s # No + add E 1 # Next port in range + cmp E (S) # Exceeded limit? + if gt # Yes + cc close(C) # Close socket + jmp ipBindErrX + end + loop + pop A # Drop range limit + cmp Z SOCK_STREAM # TCP socket? + if eq # Yes + cc listen(C 5) # Mark as server socket + nul4 # OK? + if s # No + cc close(C) # Close socket + jmp ipListenErrX + end + end + ld Z C # Keep socket in Z + ld Y (Y CDR) # Eval 'var' + ld E (Y) + eval + cmp E Nil # Any? + if ne # Yes + ld A SOCKADDR_IN # Structure size + st4 (Buf) # Store into 'namelen' + cc getsockname(Z Addr Buf) # Get socket name + nul4 # OK? + if s # No + cc close(Z) # Close socket + jmp ipGetsocknameErrX + end + call needVarEX # Need variable + ld2 (Addr SIN_PORT) # Get port + and A (hex "FFFF") # Unsigned + cc ntohs(A) # Convert to host byte order + shl A 4 # Make short number + or A CNT + ld (E) A # Store in variable + end + ld E Z # Get socket + shl E 4 # Make short number + or E CNT + pop Z + pop Y + pop X + ret + +(code 'tcpAcceptA_FE) + ld E A # Save socket in E + call nonblockingA_A # Set socket to non-blocking + push A # Save old socket status flags + ld A SOCKADDR_IN # Structure size + st4 (Buf) # Store into 'addrlen' + ld C 200 # Maximally 20 seconds + do + cc accept(E Addr Buf) # Accept connection + nul4 # OK? + if nz # Yes + xchg A (S) # Save new socket, retrieve flags + cc fcntl(E F_SETFL A) # Restore socket status flags + ld4 (Addr SIN_ADDR.S_ADDR) # Get address + cc inet_ntoa(A) # Convert to IPv4 dotted-decimal string + ld E A + call mkStrE_E # Make transient symbol + ld (Adr) E # Store in '*Adr' + ld A (S) # Get socket + call initInFileA_A # Init input file + ld A (S) + call initOutFileA_A # and output file + pop E # Get new socket + shl E 4 # Make short number + or E CNT # Return 'nz' + ret + end + cc usleep(100000) # Sleep 100 milliseconds + sub C 1 # Done? + until z # Yes + cc fcntl(E F_SETFL pop) # Restore socket status flags + setz # Return 'z' + ret + +# (accept 'cnt) -> cnt | NIL +(code 'doAccept 2) + push X + ld X E + ld E ((E CDR)) # Eval socket descriptor + call evCntEX_FE + ld A E # Accept connection + call tcpAcceptA_FE # OK? + ldz E Nil # No + pop X + ret + +# (listen 'cnt1 ['cnt2]) -> cnt | NIL +(code 'doListen 2) + push X + push Y + push Z + ld X E + ld Y (E CDR) # Y on args + call evCntXY_FE # Eval 'cnt1' + ld Z E # Keep socket descriptor in Z + ld Y (Y CDR) # Next arg + ld E (Y) + eval # Eval 'cnt2' + cmp E Nil # Given? + ldz Y -1 # No timeout + if ne # Yes + call xCntEX_FE # Milliseconds + ld Y E + end + do + ld C Z # Socket descriptor + ld E Y # Milliseconds + call waitFdCEX_A # Wait for events + ld E Nil # Preload NIL + null A # Timeout? + while nz # No + ld A Z # Accept connection + call tcpAcceptA_FE # OK? + until nz # Yes + pop Z + pop Y + pop X + ret + +# (host 'any) -> sym +(code 'doHost 2) + push Z + ld E ((E CDR)) # Eval IP address + call evSymE_E + call bufStringE_SZ # Write to stack buffer + cc inet_aton(S Buf) # Convert to binary form + ld S Z # Drop buffer + pop Z + nul4 # Valid? + jz retNil # No + cc gethostbyaddr(Buf IN_ADDR AF_INET) # Get hostent + null A # Any? + jz retNil # No + ld E (A H_NAME) + jmp mkStrE_E # Make transient symbol + +# (connect 'any 'cnt) -> cnt | NIL +(code 'doConnect 2) + push X + push Y + push Z + ld X E + ld Y (E CDR) # Y on args + call evSymY_E # Eval host + ld Y (Y CDR) # Next arg + call serverEY_F # Found server? + jz 80 # No: Return NIL + cc socket(AF_INET SOCK_STREAM 0) # Create socket + nul4 # OK? + js ipSocketErrX # No + ld Y A # Keep socket in Y + call closeOnExecAX + cc connect(Y Addr SOCKADDR_IN) # Try to connect + nul4 # OK? + if ns # Yes + ld A Y # Get socket + call initInFileA_A # Init input file + ld A Y + call initOutFileA_A # and output file + ld E Y # Return socket + shl E 4 # Make short number + or E CNT + else + cc close(Y) # Close socket +80 ld E Nil # Return NIL + end + pop Z + pop Y + pop X + ret + +(code 'serverEY_F) + link + push E # <L I> Host + link + ld B 0 # Clear socket structure + mset (Addr) SOCKADDR_IN + call evCntXY_FE # Eval port + cc htons(E) # Convert to network order + st2 (Addr SIN_PORT) # Store as port + ld A AF_INET + st2 (Addr SIN_FAMILY) + ld E (L I) # Get host + call bufStringE_SZ # Write host to stack buffer + cc inet_aton(S &(Addr SIN_ADDR)) # Convert numbers/dots to binary address + nul4 # Valid? + if z # No + cc gethostbyname(S) # Find hostent for given hostname + null A # Found? + jz 90 # No + ld E A # Keep hostent pointer in E + ld4 (E H_LENGTH) # Length of address? + nul4 + jz 90 # No + ld4 (((E H_ADDR_LIST))) # Take first address + st4 (Addr SIN_ADDR.S_ADDR) + end + clrz # Return 'nz' +90 ld S Z # Drop buffer + drop + ret + +# (udp 'any1 'cnt 'any2) -> any +# (udp 'cnt) -> any +(code 'doUdp 2) + push X + push Y + push Z + sub S UDPMAX # Allocate udp buffer + ld X E + ld Y (E CDR) # Y on args + ld E (Y) # Eval first + eval # 'any1' or 'cnt' + ld Y (Y CDR) # Next arg? + atom Y + if nz # No + call xCntEX_FE # 'cnt' + cc recv(E S UDPMAX 0) # Receive message + null A # OK? + js 10 # No + ld Z S # Buffer pointer + lea (BufEnd) (Z UDPMAX) # Calculate buffer end + ld (GetBinZ_FB) getUdpZ_FB # Set binary read function + ld (Extn) (ExtN) # Set external symbol offset + call binReadZ_FE # Read item? + if c # No +10 ld E Nil # Return NIL + end + else + call serverEY_F # Found server? + ldz E Nil # No + if nz # Yes + ld Y (Y CDR) # Next arg + ld E (Y) # Eval 'any2' + eval + ld Y E # Keep return value in Y + ld Z S # Buffer pointer + lea (BufEnd) (Z UDPMAX) # Calculate buffer end + ld (PutBinBZ) putUdpBZ # Set binary print function + ld (Extn) (ExtN) # Set external symbol offset + call binPrintEZ # Print item + cc socket(AF_INET SOCK_DGRAM 0) # Create socket + nul4 # OK? + js ipSocketErrX # No + ld C A # Keep socket in C + sub Z S # Data length + cc sendto(C S Z 0 Addr SOCKADDR_IN) # Transmit message + cc close(C) # Close socket + ld E Y # Get return value + end + end + add S UDPMAX # Drop buffer + pop Z + pop Y + pop X + ret + +(code 'getUdpZ_FB 0) + cmp Z (BufEnd) # End of buffer data? + jeq retc # Yes: Return 'c' + ld B (Z) # Next byte + add Z 1 # (nc) + ret + +(code 'putUdpBZ 0) + cmp Z (BufEnd) # End of buffer data? + jeq udpOvflErr # Yes + ld (Z) B # Store byte + add Z 1 # Increment pointer + ret + +# vi:et:ts=3:sw=3 diff --git a/src64/subr.l b/src64/subr.l @@ -0,0 +1,4013 @@ +# 15feb10abu +# (c) Software Lab. Alexander Burger + +# (car 'var) -> any +(code 'doCar 2) + push X + ld X E + ld E ((E CDR)) # Get arg + eval + num E # Need variable + jnz varErrEX + ld E (E) # Take CAR + pop X + ret + +# (cdr 'lst) -> any +(code 'doCdr 2) + push X + ld X E + ld E ((E CDR)) # Get arg + eval + cmp E Nil # Need list + if ne + atom E + jnz lstErrEX + end + ld E (E CDR) # Take CDR + pop X + ret + +(code 'doCaar 2) + push X + ld X E + ld E ((E CDR)) # Get arg + eval + num E # Need variable + jnz varErrEX + ld E (E) # Take CAR + num E # Need variable + jnz varErrEX + ld E (E) # Take CAR + pop X + ret + +(code 'doCadr 2) + push X + ld X E + ld E ((E CDR)) # Get arg + eval + cmp E Nil # Need list + if ne + atom E + jnz lstErrEX + end + ld E (E CDR) # Take CDR + num E # Need variable + jnz varErrEX + ld E (E) # Take CAR + pop X + ret + +(code 'doCdar 2) + push X + ld X E + ld E ((E CDR)) # Get arg + eval + num E # Need variable + jnz varErrEX + ld E (E) # Take CAR + cmp E Nil # Need list + if ne + atom E + jnz lstErrEX + end + ld E (E CDR) # Take CDR + pop X + ret + +(code 'doCddr 2) + push X + ld X E + ld E ((E CDR)) # Get arg + eval + cmp E Nil # Need list + if ne + atom E + jnz lstErrEX + end + ld E (E CDR) # Take CDR + cmp E Nil # Need list + if ne + atom E + jnz lstErrEX + end + ld E (E CDR) # Take CDR + pop X + ret + +(code 'doCaaar 2) + push X + ld X E + ld E ((E CDR)) # Get arg + eval + num E # Need variable + jnz varErrEX + ld E (E) # Take CAR + num E # Need variable + jnz varErrEX + ld E (E) # Take CAR + num E # Need variable + jnz varErrEX + ld E (E) # Take CAR + pop X + ret + +(code 'doCaadr 2) + push X + ld X E + ld E ((E CDR)) # Get arg + eval + cmp E Nil # Need list + if ne + atom E + jnz lstErrEX + end + ld E (E CDR) # Take CDR + num E # Need variable + jnz varErrEX + ld E (E) # Take CAR + num E # Need variable + jnz varErrEX + ld E (E) # Take CAR + pop X + ret + +(code 'doCadar 2) + push X + ld X E + ld E ((E CDR)) # Get arg + eval + num E # Need variable + jnz varErrEX + ld E (E) # Take CAR + cmp E Nil # Need list + if ne + atom E + jnz lstErrEX + end + ld E (E CDR) # Take CDR + num E # Need variable + jnz varErrEX + ld E (E) # Take CAR + pop X + ret + +(code 'doCaddr 2) + push X + ld X E + ld E ((E CDR)) # Get arg + eval + cmp E Nil # Need list + if ne + atom E + jnz lstErrEX + end + ld E (E CDR) # Take CDR + cmp E Nil # Need list + if ne + atom E + jnz lstErrEX + end + ld E (E CDR) # Take CDR + num E # Need variable + jnz varErrEX + ld E (E) # Take CAR + pop X + ret + +(code 'doCdaar 2) + push X + ld X E + ld E ((E CDR)) # Get arg + eval + num E # Need variable + jnz varErrEX + ld E (E) # Take CAR + num E # Need variable + jnz varErrEX + ld E (E) # Take CAR + cmp E Nil # Need list + if ne + atom E + jnz lstErrEX + end + ld E (E CDR) # Take CDR + pop X + ret + +(code 'doCdadr 2) + push X + ld X E + ld E ((E CDR)) # Get arg + eval + cmp E Nil # Need list + if ne + atom E + jnz lstErrEX + end + ld E (E CDR) # Take CDR + num E # Need variable + jnz varErrEX + ld E (E) # Take CAR + cmp E Nil # Need list + if ne + atom E + jnz lstErrEX + end + ld E (E CDR) # Take CDR + pop X + ret + +(code 'doCddar 2) + push X + ld X E + ld E ((E CDR)) # Get arg + eval + num E # Need variable + jnz varErrEX + ld E (E) # Take CAR + cmp E Nil # Need list + if ne + atom E + jnz lstErrEX + end + ld E (E CDR) # Take CDR + cmp E Nil # Need list + if ne + atom E + jnz lstErrEX + end + ld E (E CDR) # Take CDR + pop X + ret + +(code 'doCdddr 2) + push X + ld X E + ld E ((E CDR)) # Get arg + eval + cmp E Nil # Need list + if ne + atom E + jnz lstErrEX + end + ld E (E CDR) # Take CDR + cmp E Nil # Need list + if ne + atom E + jnz lstErrEX + end + ld E (E CDR) # Take CDR + cmp E Nil # Need list + if ne + atom E + jnz lstErrEX + end + ld E (E CDR) # Take CDR + pop X + ret + +(code 'doCaaaar 2) + push X + ld X E + ld E ((E CDR)) # Get arg + eval + num E # Need variable + jnz varErrEX + ld E (E) # Take CAR + num E # Need variable + jnz varErrEX + ld E (E) # Take CAR + num E # Need variable + jnz varErrEX + ld E (E) # Take CAR + pop X + ret + +(code 'doCaaadr 2) + push X + ld X E + ld E ((E CDR)) # Get arg + eval + cmp E Nil # Need list + if ne + atom E + jnz lstErrEX + end + ld E (E CDR) # Take CDR + num E # Need variable + jnz varErrEX + ld E (E) # Take CAR + num E # Need variable + jnz varErrEX + ld E (E) # Take CAR + num E # Need variable + jnz varErrEX + ld E (E) # Take CAR + pop X + ret + +(code 'doCaadar 2) + push X + ld X E + ld E ((E CDR)) # Get arg + eval + num E # Need variable + jnz varErrEX + ld E (E) # Take CAR + cmp E Nil # Need list + if ne + atom E + jnz lstErrEX + end + ld E (E CDR) # Take CDR + num E # Need variable + jnz varErrEX + ld E (E) # Take CAR + num E # Need variable + jnz varErrEX + ld E (E) # Take CAR + pop X + ret + +(code 'doCaaddr 2) + push X + ld X E + ld E ((E CDR)) # Get arg + eval + cmp E Nil # Need list + if ne + atom E + jnz lstErrEX + end + ld E (E CDR) # Take CDR + cmp E Nil # Need list + if ne + atom E + jnz lstErrEX + end + ld E (E CDR) # Take CDR + num E # Need variable + jnz varErrEX + ld E (E) # Take CAR + num E # Need variable + jnz varErrEX + ld E (E) # Take CAR + pop X + ret + +(code 'doCadaar 2) + push X + ld X E + ld E ((E CDR)) # Get arg + eval + num E # Need variable + jnz varErrEX + ld E (E) # Take CAR + num E # Need variable + jnz varErrEX + ld E (E) # Take CAR + cmp E Nil # Need list + if ne + atom E + jnz lstErrEX + end + ld E (E CDR) # Take CDR + num E # Need variable + jnz varErrEX + ld E (E) # Take CAR + pop X + ret + +(code 'doCadadr 2) + push X + ld X E + ld E ((E CDR)) # Get arg + eval + cmp E Nil # Need list + if ne + atom E + jnz lstErrEX + end + ld E (E CDR) # Take CDR + num E # Need variable + jnz varErrEX + ld E (E) # Take CAR + cmp E Nil # Need list + if ne + atom E + jnz lstErrEX + end + ld E (E CDR) # Take CDR + num E # Need variable + jnz varErrEX + ld E (E) # Take CAR + pop X + ret + +(code 'doCaddar 2) + push X + ld X E + ld E ((E CDR)) # Get arg + eval + num E # Need variable + jnz varErrEX + ld E (E) # Take CAR + cmp E Nil # Need list + if ne + atom E + jnz lstErrEX + end + ld E (E CDR) # Take CDR + cmp E Nil # Need list + if ne + atom E + jnz lstErrEX + end + ld E (E CDR) # Take CDR + num E # Need variable + jnz varErrEX + ld E (E) # Take CAR + pop X + ret + +(code 'doCadddr 2) + push X + ld X E + ld E ((E CDR)) # Get arg + eval + cmp E Nil # Need list + if ne + atom E + jnz lstErrEX + end + ld E (E CDR) # Take CDR + cmp E Nil # Need list + if ne + atom E + jnz lstErrEX + end + ld E (E CDR) # Take CDR + cmp E Nil # Need list + if ne + atom E + jnz lstErrEX + end + ld E (E CDR) # Take CDR + num E # Need variable + jnz varErrEX + ld E (E) # Take CAR + pop X + ret + +(code 'doCdaaar 2) + push X + ld X E + ld E ((E CDR)) # Get arg + eval + num E # Need variable + jnz varErrEX + ld E (E) # Take CAR + num E # Need variable + jnz varErrEX + ld E (E) # Take CAR + num E # Need variable + jnz varErrEX + ld E (E) # Take CAR + cmp E Nil # Need list + if ne + atom E + jnz lstErrEX + end + ld E (E CDR) # Take CDR + pop X + ret + +(code 'doCdaadr 2) + push X + ld X E + ld E ((E CDR)) # Get arg + eval + cmp E Nil # Need list + if ne + atom E + jnz lstErrEX + end + ld E (E CDR) # Take CDR + num E # Need variable + jnz varErrEX + ld E (E) # Take CAR + num E # Need variable + jnz varErrEX + ld E (E) # Take CAR + cmp E Nil # Need list + if ne + atom E + jnz lstErrEX + end + ld E (E CDR) # Take CDR + pop X + ret + +(code 'doCdadar 2) + push X + ld X E + ld E ((E CDR)) # Get arg + eval + num E # Need variable + jnz varErrEX + ld E (E) # Take CAR + cmp E Nil # Need list + if ne + atom E + jnz lstErrEX + end + ld E (E CDR) # Take CDR + num E # Need variable + jnz varErrEX + ld E (E) # Take CAR + cmp E Nil # Need list + if ne + atom E + jnz lstErrEX + end + ld E (E CDR) # Take CDR + pop X + ret + +(code 'doCdaddr 2) + push X + ld X E + ld E ((E CDR)) # Get arg + eval + cmp E Nil # Need list + if ne + atom E + jnz lstErrEX + end + ld E (E CDR) # Take CDR + cmp E Nil # Need list + if ne + atom E + jnz lstErrEX + end + ld E (E CDR) # Take CDR + num E # Need variable + jnz varErrEX + ld E (E) # Take CAR + cmp E Nil # Need list + if ne + atom E + jnz lstErrEX + end + ld E (E CDR) # Take CDR + pop X + ret + +(code 'doCddaar 2) + push X + ld X E + ld E ((E CDR)) # Get arg + eval + num E # Need variable + jnz varErrEX + ld E (E) # Take CAR + num E # Need variable + jnz varErrEX + ld E (E) # Take CAR + cmp E Nil # Need list + if ne + atom E + jnz lstErrEX + end + ld E (E CDR) # Take CDR + cmp E Nil # Need list + if ne + atom E + jnz lstErrEX + end + ld E (E CDR) # Take CDR + pop X + ret + +(code 'doCddadr 2) + push X + ld X E + ld E ((E CDR)) # Get arg + eval + cmp E Nil # Need list + if ne + atom E + jnz lstErrEX + end + ld E (E CDR) # Take CDR + num E # Need variable + jnz varErrEX + ld E (E) # Take CAR + cmp E Nil # Need list + if ne + atom E + jnz lstErrEX + end + ld E (E CDR) # Take CDR + cmp E Nil # Need list + if ne + atom E + jnz lstErrEX + end + ld E (E CDR) # Take CDR + pop X + ret + +(code 'doCdddar 2) + push X + ld X E + ld E ((E CDR)) # Get arg + eval + num E # Need variable + jnz varErrEX + ld E (E) # Take CAR + cmp E Nil # Need list + if ne + atom E + jnz lstErrEX + end + ld E (E CDR) # Take CDR + cmp E Nil # Need list + if ne + atom E + jnz lstErrEX + end + ld E (E CDR) # Take CDR + cmp E Nil # Need list + if ne + atom E + jnz lstErrEX + end + ld E (E CDR) # Take CDR + pop X + ret + +(code 'doCddddr 2) + push X + ld X E + ld E ((E CDR)) # Get arg + eval + cmp E Nil # Need list + if ne + atom E + jnz lstErrEX + end + ld E (E CDR) # Take CDR + cmp E Nil # Need list + if ne + atom E + jnz lstErrEX + end + ld E (E CDR) # Take CDR + cmp E Nil # Need list + if ne + atom E + jnz lstErrEX + end + ld E (E CDR) # Take CDR + cmp E Nil # Need list + if ne + atom E + jnz lstErrEX + end + ld E (E CDR) # Take CDR + pop X + ret + +# (nth 'lst 'cnt ..) -> lst +(code 'doNth 2) + push X + push Y + ld X E + ld Y (E CDR) # Y on args + ld E (Y) # Eval 'lst' + eval + link + push E # <L I> Safe + link + ld Y (Y CDR) + do + atom E # End of 'lst'? + while z # No + call evCntXY_FE # Next 'cnt' + ld C E # into C + sub C 1 # 'cnt' greater zero? + if ns # Yes + ld E (L I) # Get result + do + sub C 1 # Iterate + while ns + ld E (E CDR) + loop + else + ld E Nil # Return NIL + break T + end + ld Y (Y CDR) # Next arg? + atom Y + while z # Yes + ld E (E) # Take CAR + ld (L I) E # Save + loop + drop + pop Y + pop X + ret + +# (con 'lst 'any) -> any +(code 'doCon 2) + push X + push Y + ld X E + ld Y (E CDR) # Y on args + ld E (Y) # Eval 'lst' + eval + atom E # Need cell + jnz cellErrEX + link + push E # <L I> Safe + link + ld Y (Y CDR) # Next arg + ld E (Y) # Eval 'any' + eval + ld ((L I) CDR) E # Concatenate + drop + pop Y + pop X + ret + +# (cons 'any ['any ..]) -> lst +(code 'doCons 2) + push X + push Y + ld X (E CDR) # Args + ld E (X) # Eval first + eval + call consE_C # Cons with NIL + ld (C) E + ld (C CDR) Nil + link + push C # <L I> Safe + link + do + ld Y C # Y on last cell + ld X (X CDR) # Args + atom (X CDR) # more than one left? + while z # Yes + ld E (X) + eval # Eval next arg + call consE_C # Cons with NIL + ld (C) E + ld (C CDR) Nil + ld (Y CDR) C # Store in CDR of last cell + loop + ld E (X) # Last arg + eval # Eval it + ld (Y CDR) E # Store in CDR of last cell + ld E (L I) # Return pair(s) + drop + pop Y + pop X + ret + +# (conc 'lst ..) -> lst +(code 'doConc 2) + push X + push Y + ld X (E CDR) # Args + ld E (X) # Eval first + eval + link + push E # <L I> Safe + link + do + ld Y E # Keep in Y + ld X (X CDR) # Next arg? + atom X + while z # Yes + ld E (X) + eval # Eval next arg + atom Y # Result list? + if nz # No + ld (L I) E # Init result + else + do + atom (Y CDR) # Find end of result list + while z + ld Y (Y CDR) + loop + ld (Y CDR) E + end + loop + ld E (L I) # Return list + drop + pop Y + pop X + ret + +# (circ 'any ..) -> lst +(code 'doCirc 2) + push X + push Y + ld X (E CDR) # Args + ld E (X) # Eval first + eval + call consE_C # Cons with NIL + ld (C) E + ld (C CDR) Nil + link + push C # <L I> Safe + link + do + ld Y C # Keep in Y + ld X (X CDR) # Next arg? + atom X + while z # Yes + ld E (X) + eval # Eval next arg + call consE_C # Cons with NIL + ld (C) E + ld (C CDR) Nil + ld (Y CDR) C # Store in CDR of last cell + loop + ld E (L I) # Return list + ld (Y CDR) E # Make circular + drop + pop Y + pop X + ret + +# (rot 'lst ['cnt]) -> lst +(code 'doRot 2) + push X + push Y + ld X E + ld Y (E CDR) # Y on args + ld E (Y) # Eval 'lst' + eval + atom E # Cell? + if z # Yes + link + push E # <L I> Safe + link + ld Y (Y CDR) + atom Y # Second arg? + ldnz E 0 # Yes + if z # No + call evCntXY_FE # Eval 'cnt' + end + ld Y (L I) # Retrieve 'lst' + ld X (Y) # Keep CAR + do + sub E 1 # Decrement count + while nz + ld Y (Y CDR) # Next cell? + atom Y + while z # Yes + cmp Y (L I) # Circular? + while ne # No + xchg X (Y) # Swap + loop + ld ((L I)) X # Store new CAR + ld E (L I) + drop + end + pop Y + pop X + ret + +# (list 'any ['any ..]) -> lst +(code 'doList 2) + push X + push Y + ld X (E CDR) # Args + ld E (X) # Eval first + eval + call consE_C # Cons with NIL + ld (C) E + ld (C CDR) Nil + link + push C # <L I> Safe + link + do + ld Y C # Keep in Y + ld X (X CDR) # Next arg? + atom X + while z # Yes + ld E (X) + eval # Eval next arg + call consE_C # Cons with NIL + ld (C) E + ld (C CDR) Nil + ld (Y CDR) C # Store in CDR of last cell + loop + ld E (L I) # Return list + drop + pop Y + pop X + ret + +# (need 'cnt ['lst ['any]]) -> lst +(code 'doNeed 2) + push X + push Y + ld X E + ld Y (E CDR) # Y on args + call evCntXY_FE # Eval 'cnt' + ld X E # Keep in X + ld Y (Y CDR) + ld E (Y) # Eval next + eval + link + push E # <L II> 'lst' + ld Y (Y CDR) + ld E (Y) # Eval 'any' + eval+ + push E # <L I> 'any' + link + ld E (L II) # Get 'lst' + or X X # 'cnt'? + if nz # Yes + if ns # > 0 + ld Y E # 'lst' in Y + do + atom Y # Find end of 'lst' + while z + ld Y (Y CDR) + sub X 1 # Decrement 'cnt' + loop + do + sub X 1 # 'cnt' > 0? + while ns # Yes + ld C E + call consC_E # Cons 'any' with 'lst' + ld (E) (L I) + ld (E CDR) C + loop + else + atom E # 'lst' atomic? + if nz + call cons_E # Cons 'any' with NIL + ld (E) (L I) + ld (E CDR) Nil + ld (L II) E # Save + else + do + ld Y (E CDR) # Find last cell + atom Y + while z + add X 1 # Increment 'cnt' + ld E Y + loop + end + do + add X 1 # Increment 'cnt' + while s + call cons_A # Cons 'any' with NIL + ld (A) (L I) + ld (A CDR) Nil + ld (E CDR) A # Append + ld E (E CDR) + loop + ld E (L II) # Get result + end + end + drop + pop Y + pop X + ret + +# (range 'num1 'num2 ['num3]) -> lst +(code 'doRange 2) + push X + push Y + ld X E + ld Y (E CDR) # Y on args + ld E (Y) # Eval 'num1' + eval + num E # Number? + jz numErrEX # No + link + push E # <L IV> Start value + ld Y (Y CDR) + ld E (Y) # Eval 'num2' + eval+ + num E # Number? + jz numErrEX # No + push E # <L III> End value + push ONE # <L II> Increment + ld E ((Y CDR)) # Eval 'num3' + eval+ + cmp E Nil # NIL? + if ne # No + num E # Number? + jz numErrEX # No + zero E # Zero? + jeq argErrEX # Yes + test E SIGN # Negative? + jnz argErrEX # Yes + ld (S) E # Else set increment + end + link + call cons_X # Build first cell + tuck X # <L I> Result + link + ld (X) (L IV) # Start value + ld (X CDR) Nil + ld A (L IV) # Get start value + ld E (L III) # and end value + call cmpNumAE_F # Start <= end? + ld A (L IV) # Get start value again + if le # Yes + do + ld E (L II) # Increment start value + call addAE_A + push A + ld E (L III) # Start <= end? + call cmpNumAE_F + while le # Yes + pop A + call consA_Y # Append to result + ld (Y) A + ld (Y CDR) Nil + ld (X CDR) Y + ld X Y + loop + else + do + ld E (L II) # Decrement start value + call subAE_A + push A + ld E (L III) # Start >= end? + call cmpNumAE_F + while ge # Yes + pop A + call consA_Y # Append to result + ld (Y) A + ld (Y CDR) Nil + ld (X CDR) Y + ld X Y + loop + end + ld E (L I) + drop + pop Y + pop X + ret + +# (full 'any) -> bool +(code 'doFull 2) + ld E (E CDR) # Get arg + ld E (E) # Eval it + eval + do + atom E # Cell? + jnz retT # Yes + cmp (E) Nil # Found NIL? + jz retNil # Yes + ld E (E CDR) + loop + +# (make .. [(made 'lst ..)] .. [(link 'any ..)] ..) -> any +(code 'doMake 2) + push X + ld X (E CDR) # Body + push (EnvMake) # Save current 'make' env + push (EnvYoke) + link + push Nil # <L I> Result + ld (EnvMake) S # Tail address + ld (EnvYoke) S # Head address + link + exec X + ld E (L I) # Get result + drop + pop (EnvYoke) # Restore 'make' env + pop (EnvMake) + pop X + ret + +# (made ['lst1 ['lst2]]) -> lst +(code 'doMade 2) + push X + ld X E + null (EnvMake) # In 'make'? + jz makeErrEX # No + push Y + ld Y (E CDR) # Y on args + atom Y # Any? + if z # Yes + ld E (Y) # Eval 'lst1' + eval + ld ((EnvYoke)) E # Set new list + ld Y (Y CDR) + ld E (Y) # Eval 'lst2' + eval + atom E # Cell? + if nz # No + ld E ((EnvYoke)) # Retrieve new 'lst1' + do + ld A (E CDR) # Find last cell + atom A + while z + ld E A + loop + end + lea E (E CDR) # Set new tail address + ld (EnvMake) E + end + ld E ((EnvYoke)) # Return list + pop Y + pop X + ret + +# (chain 'lst ..) -> lst +(code 'doChain 2) + push X + ld X E + null (EnvMake) # In 'make'? + jz makeErrEX # No + push Y + ld Y (E CDR) # Y on args + do + ld E (Y) # Eval arg + eval + ld ((EnvMake)) E # Store new list + atom E # Got a list? + if z # Yes + ld C E + do + ld A (C CDR) # Find last cell + atom A + while z + ld C A + loop + lea C (C CDR) # Set new tail address + ld (EnvMake) C + end + ld Y (Y CDR) # More args? + atom Y + until nz + pop Y + pop X + ret + +# (link 'any ..) -> any +(code 'doLink 2) + push X + ld X E + null (EnvMake) # In 'make'? + jz makeErrEX # No + push Y + ld Y (E CDR) # Y on args + do + ld E (Y) # Eval arg + eval + call consE_C # Make new cell + ld (C) E + ld (C CDR) Nil + ld ((EnvMake)) C # Store new tail + lea C (C CDR) # Set new tail address + ld (EnvMake) C + ld Y (Y CDR) # More args? + atom Y + until nz + pop Y + pop X + ret + +# (yoke 'any ..) -> any +(code 'doYoke 2) + push X + ld X E + null (EnvMake) # In 'make'? + jz makeErrEX # No + push Y + ld Y (E CDR) # Y on args + do + ld E (Y) # Eval arg + eval + call consE_A # Make new cell + ld (A) E + ld (A CDR) ((EnvYoke)) # Set head + ld ((EnvYoke)) A + ld Y (Y CDR) # More args? + atom Y + until nz + do + ld C ((EnvMake)) # Adjust tail address? + atom C + while z # Yes + lea C (C CDR) # Set new tail address + ld (EnvMake) C + loop + pop Y + pop X + ret + +# (copy 'any) -> any +(code 'doCopy 2) + ld E ((E CDR)) # Eval arg + eval + atom E # List? + if z # Yes + push Z + ld Z E # Keep head in Z + call consE_C # Copy first cell + ld (C) (E) + ld (C CDR) (E CDR) + link + push C # <L I> Result + link + do + ld E (E CDR) + atom E # More cells? + while z # Yes + cmp E Z # Circular? + if eq # Yes + ld (C CDR) (L I) # Concat head + break T + end + call consE_A # Copy next cell + ld (A) (E) + ld (A CDR) (E CDR) + ld (C CDR) A # Concat to result + ld C A + loop + ld E (L I) # Get result + drop + pop Z + end + ret + +# (mix 'lst cnt|'any ..) -> lst +(code 'doMix 2) + push X + ld X (E CDR) # X on args + ld E (X) # Eval first + eval + cmp E Nil # Empty list? + jz 10 # Yes + atom E # Atomic? + if z # No +10 push Y + ld X (X CDR) # Next arg? + atom X + if z # Yes + link + push E # <L II> List + link + ld C (X) + cnt C # Literal second arg? + if z # No + ld E C # Eval second arg + eval + else + shr C 4 # Normalize + if le # Negative + ld E Nil + else + do + sub C 1 # nth + while nz + ld E (E CDR) + loop + ld E (E) + end + end + call consE_C # Cons first result cell + ld (C) E + ld (C CDR) Nil + tuck C # <L I> Result + link + do + ld Y C # Keep in Y + ld X (X CDR) # Next arg? + atom X + while z # Yes + ld E (X) + cnt E # Literal next arg? + if z # No + eval # Eval next arg + else + shr E 4 # Normalize + if le # Negative + ld E Nil + else + ld C (L II) # Get list + do + sub E 1 # nth + while nz + ld C (C CDR) + loop + ld E (C) + end + end + call consE_C # Cons first result cell + ld (C) E + ld (C CDR) Nil + ld (Y CDR) C # Store in CDR of last cell + loop + ld E (L I) # Get result + drop + else + ld E Nil # Return NIL + end + pop Y + end + pop X + ret + +# (append 'lst ..) -> lst +(code 'doAppend 2) + push X + ld X (E CDR) # Args + do + atom (X CDR) # More than one left? + while z # Yes + ld E (X) # Eval first + eval + atom E # Found a list? + if z # Yes + ld A E + call consE_E # Copy first cell + ld (E) (A) + ld C (A CDR) + ld (E CDR) C + link + push E # <L I> Result + link + do + atom C # More cells? + while z # Yes + call consC_A # Copy next cell + ld (A) (C) + ld C (C CDR) + ld (A CDR) C + ld (E CDR) A # Concat to result + ld E A + loop + push E # Save last cell + do + ld X (X CDR) # More than one left? + atom (X CDR) + while z # Yes + ld E (X) # Eval next argument + eval + do + atom E # Found a list? + while z # Yes + call consE_A # Copy cells + ld (A) (E) + ld E (E CDR) + ld (A CDR) E + ld ((S) CDR) A # Concat with last cell + ld (S) A # New last cell + loop + loop + ld E (X) # Eval last argument + eval + pop A # Get last cell + ld (A CDR) E # Concat last list + ld E (L I) # Get result + drop + pop X + ret + end + ld X (X CDR) # Next arg + loop + ld E (X) # Eval last arg + eval + pop X + ret + +# (delete 'any 'lst) -> lst +(code 'doDelete 2) + push X + ld X (E CDR) # Args + ld E (X) # Eval 'any' + eval + link + push E # <L II/III> 'any' + ld E ((X CDR)) # Eval 'lst' + eval+ + push E # <L I/II> 'lst' + link + atom E # Atomic? + if z # No + ld X E # Keep in X + ld A (L II) # 'any' + ld E (X) # Equal to CAR? + call equalAE_F + if eq # Yes + ld E (X CDR) # Return CDR + else + call cons_C # Cons first item into C + ld (C) (X) + ld (C CDR) Nil + tuck C # <L I> Result + link + do + ld X (X CDR) # Next item + atom X # More cells? + while z # Yes + ld A (L III) # 'any' + ld E (X) # Equal to CAR? + call equalAE_F + if eq # Yes + ld X (X CDR) # Skip this item + break T + end + call cons_A # Cons next item + ld (A) (X) + ld (A CDR) Nil + ld (C CDR) A # Append + ld C A + loop + ld (C CDR) X # Set tail + ld E (L I) # Get result + end + end + drop + pop X + ret + +# (delq 'any 'lst) -> lst +(code 'doDelq 2) + push X + ld X (E CDR) # Args + ld E (X) # Eval 'any' + eval + link + push E # <L II/III> 'any' + ld E ((X CDR)) # Eval 'lst' + eval+ + push E # <L I/II> 'lst' + link + atom E # Atomic? + if z # No + ld X (L II) # 'any' + cmp X (E) # Equal to CAR? + if eq # Yes + ld E (E CDR) # Return CDR + else + call cons_C # Cons first item into C + ld (C) (E) + ld (C CDR) Nil + tuck C # <L I> Result + link + do + ld E (E CDR) # Next item + atom E # More cells? + while z # Yes + cmp X (E) # 'any' equal to CAR? + if eq # Yes + ld E (E CDR) # Skip this item + break T + end + call cons_A # Cons next item + ld (A) (E) + ld (A CDR) Nil + ld (C CDR) A # Append + ld C A + loop + ld (C CDR) E # Set tail + ld E (L I) # Get result + end + end + drop + pop X + ret + +# (replace 'lst 'any1 'any2 ..) -> lst +(code 'doReplace 2) + push X + ld X (E CDR) # X on args + ld E (X) # Eval 'lst' + eval + atom E # Atomic? + if z # No + push Y + push Z + link + push E # Save 'lst' + ld Y E # Keep in Y + do + ld X (X CDR) # 'anyN' args? + atom X + while z # Yes + ld E (X) # Eval next arg + eval+ + push E # and save it + loop + ld X L # X above 'any1' + lea C (S -I) # C on end of 'any' items + link + call cons_Z # Build first result cell + do + sub X II # Try next 'any' pair + cmp X C # Reached last 'any' item? + while ne # No + ld A (X) # Next item + ld E (Y) # Equal to CAR of 'lst'? + call equalAE_F + if eq # Yes + ld (Z) (X -I) # First result item is 'any2' + jmp 10 + end + loop + ld (Z) (Y) # First result item is CAR of 'lst' +10 ld (Z CDR) Nil + tuck Z # <L I> Result + link + do + ld Y (Y CDR) # More in 'lst'? + atom Y + while z # Yes + ld X (L) # X above 'any1' + do + sub X II # Try next 'any' pair + cmp X C # Reached top? + while ne # No + ld A (X) # Next item + ld E (Y) # Equal to next item in 'lst'? + call equalAE_F + if eq # Yes + call cons_E # Build next result cell + ld (E) (X -I) # Next result item + jmp 20 + end + loop + call cons_E # Build next result cell + ld (E) (Y) # Next result item from 'lst' +20 ld (E CDR) Nil + ld (Z CDR) E # Concat to result + ld Z E + loop + ld E (L I) # Get result + drop + pop Z + pop Y + end + pop X + ret + +# (strip 'any) -> any +(code 'doStrip 2) + ld E ((E CDR)) # Get arg + eval # Eval it + do + atom E # List? + while z # Yes + cmp (E) Quote # CAR is 'quote'? + while eq # Yes + ld A (E CDR) # Get CDR + cmp A E # Circular? + while ne # No + ld E A # Go to CDR + loop + ret + +# (split 'lst 'any ..) -> lst +(code 'doSplit 2) + push X + ld X (E CDR) # Args + ld E (X) # Eval 'lst' + eval + atom E # List? + if z # Yes + push Y + push Z + link + push E # Save 'lst' + do + ld X (X CDR) # Next 'any' arg? + atom X + while z # Yes + ld E (X) # Eval next arg + eval+ + push E # and save it + loop # <L III/..> 'any' items + lea C (L -I) # C is top of 'any' items, and adr of 'lst' + ld Y Nil + push Y # <L II> Result in Y + ld Z Y + push Z # <L I> Sublist in Z + link + do + lea X (L III) # X on 'any' items + do + cmp X C # Reached top? + while ne # No + ld A (X) # Next item + ld E ((C)) # Equal to CAR of 'lst'? + call equalAE_F + if eq # Yes + atom Y # Result? + if nz # No + call cons_Y # Initial result cell + ld (Y) (L I) # with sublist + ld (Y CDR) Nil + ld (L II) Y # Store in result + else + call cons_A # New cell + ld (A) (L I) # with sublist + ld (A CDR) Nil + ld (Y CDR) A # Concat to result + ld Y A + end + ld Z Nil # Clear sublist + ld (L I) Z + jmp 10 + end + add X I # Next 'any' item + loop + atom Z # Sublist? + if nz # No + call cons_Z # Initial sublist cell + ld (Z) ((C)) + ld (Z CDR) Nil + ld (L I) Z # Store in sublist + else + call cons_A # New cell + ld (A) ((C)) + ld (A CDR) Nil + ld (Z CDR) A # Concat to sublist + ld Z A + end +10 ld A ((C) CDR) # Next element of 'lst' + ld (C) A + atom A # Any? + until nz # No + call cons_E # Cons final sublist + ld (E) (L I) + ld (E CDR) Nil + atom Y # Result so far? + if z # Yes + ld (Y CDR) E # Concat final sublist + ld E (L II) # Get result + end + drop + pop Z + pop Y + end + pop X + ret + +# (reverse 'lst) -> lst +(code 'doReverse 2) + ld E ((E CDR)) # Get arg + eval # Eval it + link + push E # <L II> Safe + link + ld A Nil # Result + do + atom E # Cells? + while z # Yes + call consA_C # Cons next CAR + ld (C) (E) + ld (C CDR) A + ld A C + ld E (E CDR) + loop + ld E A # Return list + drop + ret + +# (flip 'lst ['cnt]) -> lst +(code 'doFlip 2) + push X + push Y + ld X E + ld Y (E CDR) # Y on args + ld E (Y) # Eval 'lst' + eval + atom E # Cell? + if z # Yes + ld Y (Y CDR) + atom Y # Second arg? + if nz # No + ld C (E CDR) # More than one element? + atom C + if z # Yes + ld (E CDR) Nil # Make it the last cell + do + ld A (C CDR) # Get next cell + ld (C CDR) E # Concat previous + ld E C # Set to first + atom A # Done? + while z # No + ld C A + loop + end + else + link + push E # <L I> 'lst' + link + call evCntXY_FE # Eval 'cnt' + ld C (L I) # Retrieve 'lst' + drop + ld X (C CDR) # More than one element? + atom X + if z # Yes + sub E 1 # 'cnt' > 1? + if nsz # Yes + ld (C CDR) (X CDR) # Swap first two cells + ld (X CDR) C + do + sub E 1 # Done? + while nz # No + ld A (C CDR) # More cells? + atom A + while z # Yes + ld (C CDR) (A CDR) # Swap next two cells + ld (A CDR) X + ld X A + loop + ld C X # Return 'lst' + end + end + ld E C # Return 'lst' + end + end + pop Y + pop X + ret + +# (trim 'lst) -> lst +(code 'doTrim 2) + ld E ((E CDR)) # Get arg + eval # Eval it + link + push E # Save + link + call trimE_E # Trim + drop + ret + +(code 'trimE_E 0) + atom E # List? + if z # Yes + push (E) # Save CAR + ld E (E CDR) # Trim CDR + call trimE_E + cmp E Nil # All trimmed? + if eq # Yes + ld E (S) # Get CAR + call isBlankE_F # Blank? + if eq # Yes + pop A # Drop CAR + ld E Nil # Return NIL + ret + end + call cons_E # New tail cell + pop (E) # Copy CAR + ld (E CDR) Nil + ret + end + ld A E + call consE_E # New cell + pop (E) # Copy CAR + ld (E CDR) A + end + ret + +# (clip 'lst) -> lst +(code 'doClip 2) + ld E ((E CDR)) # Get arg + eval # Eval it + do + atom E # List? + jnz ret # No + push E + ld E (E) # CAR blank? + call isBlankE_F + pop E + while z # Yes + ld E (E CDR) # Try next + loop + link + push E # Save + link + call trimE_E # Trim + drop + ret + +# (head 'cnt|lst 'lst) -> lst +(code 'doHead 2) + push X + push Y + ld X E + ld Y (E CDR) # Y on args + ld E (Y) # Eval first + ld Y (Y CDR) # Y on rest + eval + cmp E Nil # NIL? + if ne # No + atom E # 'lst' arg? + if z # Yes + link + push E # <L I> First 'lst' + link + ld E (Y) # Eval second + eval + atom E # 'lst'? + if z # Yes + ld X E # 'lst' + ld Y (L I) # Head list + do + ld A (X) + ld E (Y) # Compare elements + call equalAE_F # Equal? + while eq # Yes + ld Y (Y CDR) # Head done? + atom Y + if nz # Yes + ld E (L I) # Return head + drop + pop Y + pop X + ret + end + ld X (X CDR) + loop + end + drop + jmp 10 + end + call xCntEX_FE # 'cnt' zero? + if nz # No + ld X E # 'cnt' in X + ld E (Y) # Eval second + eval + atom E # List? + if z # Yes + null X # 'cnt' negative? + if s # Yes + ld Y E + do + add X 1 # Increment 'cnt' by length + ld Y (Y CDR) + atom Y + until nz + null X # 'cnt' still negative or zero? + jsz 10 # Yes + end + link + push E # Save 'lst' + link + call cons_Y # Build first cell + ld (Y) (E) # From CAR of 'lst' + ld (Y CDR) Nil + tuck Y # <L I> Result + link + do + sub X 1 # Counted down? + while nz # No + ld E (E CDR) # List done? + atom E + while z # No + call cons_A # Build next cell + ld (A) (E) # From next list item + ld (A CDR) Nil + ld (Y CDR) A # Concat to result + ld Y A + loop + ld E (L I) # Get result + drop + end + else +10 ld E Nil # Return NIL + end + end + pop Y + pop X + ret + +# (tail 'cnt|lst 'lst) -> lst +(code 'doTail 2) + push X + push Y + ld X E + ld Y (E CDR) # Y on args + ld E (Y) # Eval first + ld Y (Y CDR) # Y on rest + eval + cmp E Nil # NIL? + if ne # No + atom E # 'lst' arg? + if z # Yes + link + push E # <L I> First 'lst' + link + ld E (Y) # Eval second + eval + atom E # 'lst'? + if z # Yes + ld X E # 'lst' + ld Y (L I) # Tail list + do + ld A X + ld E Y # Compare lists + call equalAE_F # Equal? + if eq # Yes + ld E (L I) # Return tail + drop + pop Y + pop X + ret + end + ld X (X CDR) # List done? + atom X + until nz # Yes + end + drop + jmp 10 + end + call xCntEX_FE # 'cnt' zero? + if nz # No + ld X E # 'cnt' in X + ld E (Y) # Eval second + eval + atom E # List? + if z # Yes + null X # 'cnt' negative? + if s # Yes + do + ld E (E CDR) + add X 1 # Take -nth + until z + else + ld Y (E CDR) # Traverse CDR + do + sub X 1 # Decrement 'cnt' + while nz + atom Y # End of list? + while z # No + ld Y (Y CDR) + loop + do + atom Y # Traverse rest + while z + ld E (E CDR) # Step result + ld Y (Y CDR) # and rest + loop + end + end + else +10 ld E Nil # Return NIL + end + end + pop Y + pop X + ret + +# (stem 'lst 'any ..) -> lst +(code 'doStem 2) + push X + push Y + ld X (E CDR) # Args + ld E (X) # Eval 'lst' + eval + link + push E # Save 'lst' + do + ld X (X CDR) # Next 'any' arg? + atom X + while z # Yes + ld E (X) # Eval next arg + eval+ + push E # and save it + loop # <L I/..> 'any' items + lea C (L -I) # C is top of 'any' items, and adr of 'lst' + link + ld Y (C) # Get 'lst' + do + atom Y # End of 'lst'? + while z # No + lea X (L I) # X on 'any' items + do + cmp X C # Reached top? + while ne # No + ld A (X) # Next item + ld E (Y) # Found in 'lst'? + call equalAE_F + if eq # Yes + ld (C) (Y CDR) # Set result + break T + end + add X I # Next 'any' item + loop + ld Y (Y CDR) # Next in 'lst' + loop + ld E (C) # Get Result + drop + pop Y + pop X + ret + +# (fin 'any) -> num|sym +(code 'doFin 2) + ld E ((E CDR)) # Get arg + eval # Eval it + do + atom E # Final atom? + while z # No + ld E (E CDR) # Try next + loop + ret + +# (last 'lst) -> any +(code 'doLast 2) + ld E ((E CDR)) # Get arg + eval # Eval it + atom E # List? + if z # Yes + do + atom (E CDR) # Last cell? + while z # No + ld E (E CDR) # Try next + loop + ld E (E) # Get CAR + end + ret + +# (== 'any ..) -> flg +(code 'doEq 2) + push X + ld X (E CDR) # X on args + ld E (X) + eval # Eval first arg + link + push E # <L I> Safe + link + do + ld X (X CDR) # More args? + atom X + while z # Yes + ld E (X) + eval # Eval next arg + cmp E (L I) # Eq to first arg? + if ne # No + drop + ld E Nil # Return NIL + pop X + ret + end + loop + drop + ld E TSym # Return T + pop X + ret + +# (n== 'any ..) -> flg +(code 'doNEq 2) + push X + ld X (E CDR) # X on args + ld E (X) + eval # Eval first arg + link + push E # <L I> Safe + link + do + ld X (X CDR) # More args? + atom X + while z # Yes + ld E (X) + eval # Eval next arg + cmp E (L I) # Eq to first arg? + if ne # No + drop + ld E TSym # Return T + pop X + ret + end + loop + drop + ld E Nil # Return NIL + pop X + ret + +# (= 'any ..) -> flg +(code 'doEqual 2) + push X + ld X (E CDR) # X on args + ld E (X) + eval # Eval first arg + link + push E # <L I> Safe + link + do + ld X (X CDR) # More args? + atom X + while z # Yes + ld E (X) + eval # Eval next arg + ld A (L I) # Get first arg + call equalAE_F # Equal to previous? + if ne # No + drop + ld E Nil # Return NIL + pop X + ret + end + loop + drop + ld E TSym # Return T + pop X + ret + +# (<> 'any ..) -> flg +(code 'doNEqual 2) + push X + ld X (E CDR) # X on args + ld E (X) + eval # Eval first arg + link + push E # <L I> Safe + link + do + ld X (X CDR) # More args? + atom X + while z # Yes + ld E (X) + eval # Eval next arg + ld A (L I) # Get first arg + call equalAE_F # Equal to previous? + if ne # No + drop + ld E TSym # Return T + pop X + ret + end + loop + drop + ld E Nil # Return NIL + pop X + ret + +# (=0 'any) -> 0 | NIL +(code 'doEq0 2) + ld E ((E CDR)) # Get arg + eval # Eval it + cmp E ZERO # Zero? + jne retNil # No + ret + +# (=T 'any) -> flg +(code 'doEqT 2) + ld E ((E CDR)) # Get arg + eval # Eval it + cmp E TSym # T? + jne retNil # No + ret + +# (n0 'any) -> flg +(code 'doNEq0 2) + ld E ((E CDR)) # Get arg + eval # Eval it + cmp E ZERO # Zero? + jne retT # No + ld E Nil + ret + +# (nT 'any) -> flg +(code 'doNEqT 2) + ld E ((E CDR)) # Get arg + eval # Eval it + cmp E TSym # T? + jne retT # No + ld E Nil + ret + +# (< 'any ..) -> flg +(code 'doLt 2) + push X + ld X (E CDR) # X on args + ld E (X) + eval # Eval first arg + link + push E # <L I> Safe + link + do + ld X (X CDR) # More args? + atom X + while z # Yes + ld E (X) + eval # Eval next arg + ld A (L I) # Get previous arg + ld (L I) E # Store current + call compareAE_F # Compare current with previous + if ge # Not greater or equal + drop + ld E Nil # Return NIL + pop X + ret + end + loop + drop + ld E TSym # Return T + pop X + ret + +# (<= 'any ..) -> flg +(code 'doLe 2) + push X + ld X (E CDR) # X on args + ld E (X) + eval # Eval first arg + link + push E # <L I> Safe + link + do + ld X (X CDR) # More args? + atom X + while z # Yes + ld E (X) + eval # Eval next arg + ld A (L I) # Get previous arg + ld (L I) E # Store current + call compareAE_F # Compare current with previous + if gt # Not greater or equal + drop + ld E Nil # Return NIL + pop X + ret + end + loop + drop + ld E TSym # Return T + pop X + ret + +# (> 'any ..) -> flg +(code 'doGt 2) + push X + ld X (E CDR) # X on args + ld E (X) + eval # Eval first arg + link + push E # <L I> Safe + link + do + ld X (X CDR) # More args? + atom X + while z # Yes + ld E (X) + eval # Eval next arg + ld A (L I) # Get previous arg + ld (L I) E # Store current + call compareAE_F # Compare current with previous + if le # Not greater or equal + drop + ld E Nil # Return NIL + pop X + ret + end + loop + drop + ld E TSym # Return T + pop X + ret + +# (>= 'any ..) -> flg +(code 'doGe 2) + push X + ld X (E CDR) # X on args + ld E (X) + eval # Eval first arg + link + push E # <L I> Safe + link + do + ld X (X CDR) # More args? + atom X + while z # Yes + ld E (X) + eval # Eval next arg + ld A (L I) # Get previous arg + ld (L I) E # Store current + call compareAE_F # Compare current with previous + if lt # Not greater or equal + drop + ld E Nil # Return NIL + pop X + ret + end + loop + drop + ld E TSym # Return T + pop X + ret + +# (max 'any ..) -> any +(code 'doMax 2) + push X + push Y + ld X (E CDR) # X on args + ld E (X) + eval # Eval first arg + link + push E # <L I> Result + link + do + ld X (X CDR) # More args? + atom X + while z # Yes + ld E (X) + eval # Eval next arg + ld A (L I) # Get result + ld Y E # Save next arg + call compareAE_F # Compare arg with result + if lt # Result is less than + ld (L I) Y # Set new result + end + loop + ld E (L I) # Result + drop + pop Y + pop X + ret + +# (min 'any ..) -> any +(code 'doMin 2) + push X + push Y + ld X (E CDR) # X on args + ld E (X) + eval # Eval first arg + link + push E # <L I> Result + link + do + ld X (X CDR) # More args? + atom X + while z # Yes + ld E (X) + eval # Eval next arg + ld A (L I) # Get result + ld Y E # Save next arg + call compareAE_F # Compare arg with result + if gt # Result is greater + ld (L I) Y # Set new result + end + loop + ld E (L I) # Result + drop + pop Y + pop X + ret + +# (atom 'any) -> flg +(code 'doAtom 2) + ld E ((E CDR)) # Get arg + eval # Eval it + atom E # Atom? + jnz retT # Yes + ld E Nil + ret + +# (pair 'any) -> any +(code 'doPair 2) + ld E ((E CDR)) # Get arg + eval # Eval it + atom E # Atom? + jnz retNil # Yes + ret + +# (lst? 'any) -> flg +(code 'doLstQ 2) + ld E ((E CDR)) # Get arg + eval # Eval it + atom E # Pair? + jz retT # Yes + cmp E Nil # NIL? + jeq retT # Yes + ld E Nil + ret + +# (num? 'any) -> num | NIL +(code 'doNumQ 2) + ld E ((E CDR)) # Get arg + eval # Eval it + num E # Number? + jz retNil # No + ret + +# (sym? 'any) -> flg +(code 'doSymQ 2) + ld E ((E CDR)) # Get arg + eval # Eval it + num E # Number? + jnz retNil # Yes + sym E # Symbol? + jnz retT # Yes + ld E Nil + ret + +# (flg? 'any) -> flg +(code 'doFlgQ 2) + ld E ((E CDR)) # Get arg + eval # Eval it + cmp E Nil # NIL? + jeq retT # Yes + cmp E TSym # T? + jne retNil # No + ret + +# (member 'any 'lst) -> any +(code 'doMember 2) + push X + push Y + ld X (E CDR) # Args + ld E (X) # Eval 'any' + eval + link + push E # <L I> 'any' + link + ld E ((X CDR)) # Eval 'lst' + eval + ld X (L I) # Retrieve 'any' + ld Y E # Get 'lst + call memberXY_FY # Member? + ld E Y + ldnz E Nil # No + drop + pop Y + pop X + ret + +# (memq 'any 'lst) -> any +(code 'doMemq 2) + push X + ld X (E CDR) # Args + ld E (X) # Eval 'any' + eval + link + push E # <L I> 'any' + link + ld E ((X CDR)) # Eval 'lst' + eval + ld A (L I) # Retrieve 'any' + drop # Clean up + pop X + ld C E # Keep head in C + do + atom E # List? + while z # Yes + cmp A (E) # Member? + jeq ret # Return list + ld E (E CDR) # Next item + cmp C E # Hit head? + jeq retNil # Yes + loop + cmp A E # Same atoms? + jne retNil # No + ret + +# (mmeq 'lst 'lst) -> any +(code 'doMmeq 2) + push X + ld X (E CDR) # Args + ld E (X) # Eval first + eval + link + push E # <L I> 'lst' + link + ld E ((X CDR)) # Eval second + eval + ld X (L I) # Retrieve first list + ld C E # Keep second in C + do + atom X # Done? + while z # No + ld A (X) # Next item from first + do + atom E # List? + while z # Yes + cmp A (E) # Member? + jeq 20 # Return list + ld E (E CDR) # Next item + cmp C E # Hit head? + jz 10 # Yes + loop + cmp A E # Same atoms? + jeq 20 # Yes + ld X (X CDR) # Get CDR of first + ld E C # Get second arg again + loop +10 ld E Nil # Return NIL +20 drop + pop X + ret + +# (sect 'lst 'lst) -> lst +(code 'doSect 2) + push X + push Y + push Z + ld X (E CDR) # Args + ld E (X) # Eval first + eval + link + push E # <L III> First 'lst' + ld E ((X CDR)) # Eval second arg + eval+ + push E # <L II> Second 'lst' + push Nil # <L I> Result + link + ld Z 0 # Empty result cell + ld X (L III) # Get first list + do + atom X # Done? + while z # No + ld X (X) # CAR of first + ld Y (L II) # Second + call memberXY_FY # Member? + if eq # Yes + null Z # Result still empty? + if z # Yes + call cons_Z # Build first cell + ld (Z) X + ld (Z CDR) Nil + ld (L I) Z # Store in result + else + call cons_A # Build next cell + ld (A) X + ld (A CDR) Nil + ld (Z CDR) A # Concat to result + ld Z A + end + end + ld X ((L III) CDR) # Next item in first + ld (L III) X + loop + ld E (L I) # Get result + drop + pop Z + pop Y + pop X + ret + +# (diff 'lst 'lst) -> lst +(code 'doDiff 2) + push X + push Y + push Z + ld X (E CDR) # Args + ld E (X) # Eval first + eval + link + push E # <L III> First 'lst' + ld E ((X CDR)) # Eval second arg + eval+ + push E # <L II> Second 'lst' + push Nil # <L I> Result + link + ld Z 0 # Empty result cell + ld X (L III) # Get first list + do + atom X # Done? + while z # No + ld X (X) # CAR of first + ld Y (L II) # Second + call memberXY_FY # Member? + if ne # No + null Z # Result still empty? + if z # Yes + call cons_Z # Build first cell + ld (Z) X + ld (Z CDR) Nil + ld (L I) Z # Store in result + else + call cons_A # Build next cell + ld (A) X + ld (A CDR) Nil + ld (Z CDR) A # Concat to result + ld Z A + end + end + ld X ((L III) CDR) # Next item in first + ld (L III) X + loop + ld E (L I) # Get result + drop + pop Z + pop Y + pop X + ret + +# (index 'any 'lst) -> cnt | NIL +(code 'doIndex 2) + push X + push Y + push Z + ld X (E CDR) # Args + ld E (X) # Eval first + eval + link + push E # <L I> 'any' + link + ld E ((X CDR)) # Eval second + eval + ld X (L I) # Get 'any' + ld Y E # and 'lst' + ld Z Y # Keep head in Z + ld C 1 # Count in C + do + atom Y # List? + while z # Yes + ld A X + ld E (Y) + call equalAE_F # Found item? + if eq # Yes + ld E C # Get result + shl E 4 # Make short number + or E CNT + jmp 90 # Found + end + add C 1 # Increment result + ld Y (Y CDR) # Next item + cmp Z Y # Hit head? + until eq # Yes + ld E Nil # Not found +90 drop + pop Z + pop Y + pop X + ret + +# (offset 'lst1 'lst2) -> cnt | NIL +(code 'doOffset 2) + push X + ld X (E CDR) # Args + ld E (X) # Eval first + eval + link + push E # <L I> 'any' + link + ld E ((X CDR)) # Eval second + eval + ld C 0 # Init result + ld X (L I) # Get 'lst1' + do + atom E # Any? + while z # Yes + add C 1 # Increment result + ld A X # Get 'lst1' + push E + call equalAE_F # Same rest? + if eq # Yes + ld E C # Get result + shl E 4 # Make short number + or E CNT + drop + pop X + ret + end + pop E + ld E (E CDR) + loop + ld E Nil + drop + pop X + ret + +# (length 'any) -> cnt | T +(code 'doLength 2) + ld E (E CDR) # Get arg + ld E (E) + eval # Eval it + num E # Number? + if nz # Yes + ld A -2 # Scale + jmp fmtNum0AE_E # Calculate length + end + sym E # Symbol? + if z # No (list) + push X + push Y + ld X E # List in X + ld E ONE # Counter + do + cmp X Quote + while eq + ld Y (X CDR) # Next cell + cmp Y X # Circular? + jz lengthT # Yes + ld X Y + atom X # Done? + jnz 10 # Yes + add E (hex "10") # Increment counter + loop + ld Y X # Keep list head + do + ld X (X CDR) # Next cell + atom X # Any? + while z # Yes + cmp X Y # Hit head? + jz lengthT # Yes + add E (hex "10") # Increment counter + loop +10 pop Y + pop X + ret + end + # Symbol + cmp E Nil # NIL? + if eq # Yes + ld E ZERO + ret + end + push X + ld X (E TAIL) + call nameX_X # Get name + ld C 0 + ld E ZERO # Counter + do + call symCharCX_FACX # Next char + while nz + add E (hex "10") # Increment counter + loop + pop X + ret + +: lengthT + ld E TSym # Return T + pop Y + pop X + ret + +# (size 'any) -> cnt +(code 'doSize 2) + push X + ld X E + ld E ((E CDR)) # E on arg + eval # Eval 'any' + num E # Number? + if nz # Yes + cnt E # Short number? + if nz # Yes + ld C ONE # Init counter + shr E 3 # Normalize short, keep sign bit + do + shr E 8 # More bytes? + while nz # Yes + add C (hex "10") # Increment count + loop + else # Big number + ld C (hex "82") # Count '8' significant bytes + do + ld A (E DIG) # Keep digit + ld E (E BIG) # More cells? + cnt E + while z # Yes + add C (hex "80") # Increment count by '8' + loop + shr E 4 # Normalize short + shl A 1 # Get most significant bit of last digit + addc E E # Any significant bits in short number? + if nz # Yes + do + add C (hex "10") # Increment count + shr E 8 # More bytes? + until z # No + end + end + else + sym E # List? + if z # Yes + ld C ZERO # Init count + call sizeCE_C # Count cell structures + else # Symbol + cmp E Nil # NIL? + if eq # Yes + ld C ZERO # Return zero + else + sym (E TAIL) # External symbol? + if nz # Yes + push Z + call dbFetchEX + ld X (E) # Get value + call dbSizeX_A # Calculate size + add A (+ BLK 1) # plus block overhead + ld Z A # Count in Z + ld E (E TAIL) # Get properties + off E SYM # Clear 'extern' tag + do + atom E # More properties? + while z # Yes + ld X (E) # Next property + ld E (E CDR) + atom X # Flag? + if nz # Yes + call dbSizeX_A # Flag's size + add Z A # Add to count + add Z 2 # Plus 2 + else + push (X) # Save value + ld X (X CDR) # Get key + call dbSizeX_A # Calculate size + add Z A # Add to count + pop X # Retrieve value + call dbSizeX_A # Calculate size + add Z A # Add to count + end + loop + ld C Z # Get count + shl C 4 # Make short number + or C CNT + pop Z + else + ld E (E TAIL) + call nameE_E # Get name + zero E # Any? + if eq # No + ld C ZERO # Return zero + else + cnt E # Short name? + if nz # Yes + ld C ONE # Init counter + shr E 4 # Normalize + do + shr E 8 # More bytes? + while nz # Yes + add C (hex "10") # Increment count + loop + else # Long name + ld C (hex "82") # Count '8' significant bytes + do + ld E (E BIG) # More cells? + cnt E + while z # Yes + add C (hex "80") # Increment count + loop + shr E 4 # Any significant bits in short name? + if nz # Yes + do + add C (hex "10") # Increment count + shr E 8 # More bytes? + until z # No + end + end + end + end + end + end + end + ld E C # Get count + pop X + ret + +(code 'sizeCE_C 0) + add C (hex "10") # Increment count + do + cmp (E) Quote # CAR is 'quote'? + while eq # Yes + cmp E (E CDR) # Circular? + jeq ret # Yes + ld E (E CDR) # More cells? + atom E + jnz ret # No + add C (hex "10") # Increment count + loop + push X + ld X E # Keep head in X + do + atom (E) # Is CAR a cell? + if z # Yes + push E + ld E (E) # Count CAR + call sizeCE_C + pop E + end + ld E (E CDR) # More cells? + atom E + while z # Yes + cmp E X # Circular? + while ne # No + add C (hex "10") # Increment count + loop + pop X + ret + +# (assoc 'any 'lst) -> lst +(code 'doAssoc 2) + push X + ld X (E CDR) # Args + ld E (X) # Eval 'any' + eval + link + push E # <L I> 'any' + link + ld E ((X CDR)) # Eval 'lst' + eval + ld X E # into X + do # assoc + atom X # Done? + if z # No + atom (X) # CAR atomic? + if z # No + ld A (L I) # Retrieve 'any' + ld E ((X)) # and CAAR + call equalAE_F # Found? + break eq # Yes + end + ld X (X CDR) # Next + else + ld E Nil # Return NIL + drop + pop X + ret + end + loop + ld E (X) # Return CAR + drop + pop X + ret + +# (asoq 'any 'lst) -> lst +(code 'doAsoq 2) + push X + ld X (E CDR) # Args + ld E (X) # Eval 'any' + eval + link + push E # <L I> 'any' + link + ld E ((X CDR)) # Eval 'lst' + eval + ld A (L I) # Retrieve 'any' + drop # Clean up + pop X + do # asoq + atom E # Done? + jnz retNil # Yes + ld C (E) # Get CAR + atom C # Atomic? + if z # No + cmp A (C) # Found? + break eq # Yes + end + ld E (E CDR) # Next + loop + ld E C # Return CAR + ret + +# (rank 'any 'lst ['flg]) -> lst +(code 'doRank 2) + push X + push Y + push Z + ld X (E CDR) # Args + ld E (X) # Eval first + eval + link + push E # <L II> 'any' + ld X (X CDR) + ld E (X) # Eval next + eval+ + push E # <L I> 'lst' + link + ld E ((X CDR)) # Eval 'flg' + eval + ld X (L I) # Get 'lst' in X + atom X # Empty? + if z # No + ld Z 0 # Calculate length in Z + ld Y X + do + add Z 1 # Increment length + ld Y (Y CDR) # Next cell? + atom Y + until nz # No + ld A ((X)) # First CAAR + cmp E Nil # 'flg'? + if eq # No + ld E (L II) # Compare CAAR with 'any' + call compareAE_F + jgt 10 # Return NIL if too big + do + ld C Z # Length + shr C 1 # One? + while nz # No + ld Y X # Offset Y + do + ld Y (Y CDR) + sub C 1 + until z + ld A ((Y)) # Compare CAAR + ld E (L II) # with 'any' + call compareAE_F # Greater? + if gt # Search left half + ld Y X # Move right pointer back + shr Z 1 # Half length + else # Search right half + ld X Y # Move left pointer to offset + ld C Z + shr C 1 # Set length to remainder + sub Z C + end + loop + else + ld E (L II) # Compare CAAR with 'any' + call compareAE_F + jlt 10 # Return NIL if too small + do + ld C Z # Length + shr C 1 # One? + while nz # No + ld Y X # Offset Y + do + ld Y (Y CDR) + sub C 1 + until z + ld A ((Y)) # Compare CAAR + ld E (L II) # with 'any' + call compareAE_F # Smaller? + if lt # Search left half + ld Y X # Move right pointer back + shr Z 1 # Half length + else # Search right half + ld X Y # Move left pointer to offset + ld C Z + shr C 1 # Set length to remainder + sub Z C + end + loop + end + ld E (X) # Return CAR + else +10 ld E Nil + end + drop + pop Z + pop Y + pop X + ret + +# (match 'lst1 'lst2) -> flg +(code 'doMatch 2) + push X + ld X (E CDR) # Args + ld E (X) # Eval 'lst1' + eval + link + push E # <L II> Pattern + ld E ((X CDR)) # Eval 'lst2' + eval+ + push E # <L I> Data + link + ld C (L II) # Pattern + call matchCE_F # Match with data? + ld E TSym # Yes + ldnz E Nil # No + drop + pop X + ret + +: matchCE_F + do + atom C # Pattern atomic? + if nz # Yes + num C # Symbol? + if z # Yes + ld A (C TAIL) + call firstByteA_B # starting with "@"? + cmp B (char "@") + if eq # Yes + ld (C) E # Set value to matched data + ret # Return 'z' + end + end + ld A C # Check if equal + jmp equalAE_F + end + ld X (C) # CAR of pattern + num X + if z + sym X # Symbolic? + if nz # Yes + ld A (X TAIL) + call firstByteA_B # starting with "@"? + cmp B (char "@") + if eq # Yes + atom E # Data atomic? + if nz # Yes + ld A (C CDR) # CDR of pattern equal to data? + call equalAE_F + jnz ret # No + ld (X) Nil # Else clear value + ret # Return 'z' + end + push C # Save pattern + push E # and Data + ld C (C CDR) # Get CDRs + ld E (E CDR) + call matchCE_F # Match? + pop E + pop C + if eq # Yes + call cons_A # Cons CAR of data with NIL + ld (A) (E) + ld (A CDR) Nil + ld ((C)) A # Set value + jmp retz + end + push C # Save pattern + push E # and Data + ld C (C CDR) # CDR of pattern + call matchCE_F # Match with data? + pop E + pop C + if eq # Yes + ld ((C)) Nil # Set value to NIL + ret # Return 'z' + end + push C # Save pattern + push E # and Data + ld E (E CDR) # CDR of data + call matchCE_F # Match with pattern? + pop E + pop C + if eq # Yes + ld X (C) # Pattern symbol + call cons_A # Cons CAR of data into value + ld (A) (E) + ld (A CDR) (X) + ld (X) A # Set value + jmp retz + end + end + end + end + atom E # Data atomic? + jnz ret # Yes + push (C CDR) # Save rests + push (E CDR) + ld C (C) # Get CARs + ld E (E) + call matchCE_F # Match? + pop E + pop C + jnz ret # No + loop + +# (fill 'any ['sym|lst]) -> any +(code 'doFill 2) + push X + ld X (E CDR) # Args + ld E (X) # Eval 'any' + eval + link + push E # <L II> Pattern + ld E ((X CDR)) # Eval 'sym|lst' + eval+ + push E # <L I> 'sym|lst' + link + ld X E # in X + ld E (L II) # Fill pattern + call fillE_FE + drop + pop X + ret + +: fillE_FE + num E # Data numeric? + jnz ret # Return 'nz' + sym E # Data symbolic? + if nz # Yes + cmp X Nil # 'sym|lst'? + if eq # No + cmp E At # '@'? + jeq retnz # Return 'nz' + ld A (E TAIL) + call firstByteA_B # starting with "@"? + cmp B (char "@") + if eq # Yes + ld E (E) # Return 'z' + end + ret # Else 'nz' + end + ld C X # 'memq' + do + atom C # List? + while z # Yes + cmp E (C) # Member? + if eq # Yes + ld E (E) # Return 'z' + ret + end + ld C (C CDR) # Next element + loop + cmp E C # Same? + if eq # Yes + ld E (E) # Return 'z' + end + ret # Else 'nz' + end + push E # <S> Save + ld E (E) # Recurse on CAR + call fillE_FE # Modified? + if z # Yes + pop C # Get pattern + link + push E # <L I> Modified CAR + link + ld E (C CDR) # Recurse on CDR + call fillE_FE + call consE_A # Cons result + ld (A) (L I) + ld (A CDR) E + ld E A + drop + setz # Modified + ret + end + ld E ((S) CDR) # Recurse on CDR + call fillE_FE # Modified? + if z # Yes + call consE_A # Cons result + pop C + ld (A) (C) # Unmodified CAR + ld (A CDR) E # Modified CDR + ld E A + setz # Modified + ret + end + pop E # Return 'nz' + ret + +### Declarative Programming ### +(code 'unifyCEYZ_F 0) +10 num Y # x1 symbolic? + if z + sym Y + if nz # Yes + ld A (Y TAIL) # x1 + call firstByteA_B # starting with "@"? + cmp B (char "@") + if eq # Yes + ld X ((Penv)) # Get pilog environment + do + ld A (X) # car(x) + atom A # List? + while z # Yes + ld A (A) # caar(x) + cmp C (A) # n1 == caaar(x)? + if eq # Yes + cmp Y (A CDR) # x1 == cdaar(x)? + if eq # Yes + ld A ((X) CDR) + ld C (A) # n1 = cadar(x) + ld Y (A CDR) # x1 = cddar(x) + jmp 10 + end + end + ld X (X CDR) + loop + end + end + end +20 num Z # x2 symbolic? + if z + sym Z + if nz # Yes + ld A (Z TAIL) # x2 + call firstByteA_B # starting with "@"? + cmp B (char "@") + if eq # Yes + ld X ((Penv)) # Get pilog environment + do + ld A (X) # car(x) + atom A # List? + while z # Yes + ld A (A) # caar(x) + cmp E (A) # n2 == caaar(x)? + if eq # Yes + cmp Z (A CDR) # x2 == cdaar(x)? + if eq # Yes + ld A ((X) CDR) + ld E (A) # n2 = cadar(x) + ld Z (A CDR) # x2 = cddar(x) + jmp 20 + end + end + ld X (X CDR) + loop + end + end + end + cmp C E # n1 == n2? + if eq # Yes + ld A Y # x1 + push E + ld E Z # x2 + call equalAE_F # Equal? + pop E + jeq ret # Yes + end + num Y # x1 symbolic? + if z + sym Y + if nz # Yes + ld A (Y TAIL) # x1 + call firstByteA_B # starting with "@"? + cmp B (char "@") + if eq # Yes + cmp Y At # x1 == @? + if ne # No + call cons_A # (n1 . x1) + ld (A) C + ld (A CDR) Y + call consA_C # (n2 . x2) + ld (C) E + ld (C CDR) Z + call consAC_E # ((n1 . x1) . (n2 . x2)) + ld (E) A + ld (E CDR) C + ld X (Penv) # Concat to pilog environment + call consE_A + ld (A) E + ld (A CDR) (X) + ld (X) A # Store in environment + end + setz + ret + end + end + end + num Z # x2 symbolic? + if z + sym Z + if nz # Yes + ld A (Z TAIL) # x2 + call firstByteA_B # starting with "@"? + cmp B (char "@") + if eq # Yes + cmp Z At # x2 == @? + if ne # No + call cons_A # (n1 . x1) + ld (A) C + ld (A CDR) Y + call consA_C # (n2 . x2) + ld (C) E + ld (C CDR) Z + call consAC_E # ((n2 . x2) . (n1 . x1)) + ld (E CDR) A + ld (E) C + ld X (Penv) # Concat to pilog environment + call consE_A + ld (A) E + ld (A CDR) (X) + ld (X) A # Store in environment + end + setz + ret + end + end + end + atom Y # x1 atomic? + if z # No + atom Z # x2 atomic? + if z # No + push ((Penv)) # Save pilog environment + push C # and parameters + push E + push Y + push Z + ld Y (Y) # car(x1) + ld Z (Z) # car(x2) + call unifyCEYZ_F # Match? + pop Z + pop Y + pop E + pop C + if eq # Yes + ld Y (Y CDR) # cdr(x1) + ld Z (Z CDR) # cdr(x2) + call unifyCEYZ_F # Match? + if eq # Yes + pop A # Drop pilog environment + ret # 'z' + end + end + pop ((Penv)) # Restore pilog environment + ret # nz + end + end + ld A Y # Compare x1 and x2 + ld E Z + jmp equalAE_F + +# (prove 'lst ['lst]) -> lst +(code 'doProve 2) + push X + ld X (E CDR) # Args + ld E (X) # Eval first + eval + atom E # Atomic? + if nz # Yes + pop X + ld E Nil # Return NIL + ret + end + push Y + push Z + push (Penv) # Save pilog environment pointers + push (Pnl) + link + push (At) # <L (+ IX I)> @ + push E # <L IX> q + ld Z E # Keep in Z + ld X (X CDR) # Second arg + ld E (X) # Eval debug list + eval+ + push E # <L VIII> dbg + ld Y ((Z)) # env = caar(q) + push Y # <L VII> env + ld (Penv) S # Set pilog environment pointer + ld (Z) ((Z) CDR) # car(q) = cdar(q) + push (Y) # <L VI> n + ld Y (Y CDR) + push (Y) # <L V> nl + ld (Pnl) S # Set pointer + ld Y (Y CDR) + push (Y) # <L IV> alt + ld Y (Y CDR) + push (Y) # <L III> tp1 + ld Y (Y CDR) + push (Y) # <L II> tp2 + ld Y (Y CDR) + push Nil # <L I> e + link + ld (L VII) Y # Set env + do + atom (L III) # tp1? + jz 10 # Yes + atom (L II) # or tp2? + while z # Yes +10 atom (L IV) # alt? + if z # Yes + ld (L I) (L VII) # e = env + ld C ((L V)) # car(nl) + ld Y (((L III)) CDR) # cdar(tp1) + ld E (L VI) # n + ld Z (((L IV))) # caar(alt) + call unifyCEYZ_F # Match? + if ne # No + ld X ((L IV) CDR) # alt = cdr(alt) + ld (L IV) X + atom X # Atomic? + if nz # Yes + ld X (((L IX))) # env = caar(q) + ld ((L IX)) (((L IX)) CDR) # car(q) = cdar(q) + ld (L VI) (X) # n = car(env) + ld X (X CDR) # env = cdr(env) + ld (L V) (X) # nl = car(env) + ld X (X CDR) # env = cdr(env) + ld (L IV) (X) # alt = car(env) + ld X (X CDR) # env = cdr(env) + ld (L III) (X) # tp1 = car(env) + ld X (X CDR) # env = cdr(env) + ld (L II) (X) # tp2 = car(env) + ld X (X CDR) # env = cdr(env) + ld (L VII) X # Set env + end + else + atom (L VIII) # dbg? + if z # Yes + ld A (((L III))) # memq(caar(tp1), dbg) + ld E (L VIII) + do + cmp A (E) # memq? + if eq # Yes + ld C TSym # get(caar(tp1), T) + ld E (((L III))) + call getEC_E + ld X E + ld C 0 # Index count + do + add C 1 # Increment + ld A ((L IV)) # Found car(alt)? + ld E (X) + ld X (X CDR) + call equalAE_F + until eq # Yes + ld A C + call outWordA # Print level number + call space + ld E ((L III)) # car(tp1) + call uniFillE_E # Fill with values + call printE # and print + call newline + break T + end + ld E (E CDR) # Next debug symbol + atom E # Any? + until nz # No + end + atom ((L IV) CDR) # cdr(alt)? + if z # Yes + call cons_A # cons(tp2, e) + ld (A) (L II) + ld (A CDR) (L I) + call consA_C # cons(tp1, @) + ld (C) (L III) + ld (C CDR) A + call consC_A # cons(cdr(alt), @) + ld (A) ((L IV) CDR) + ld (A CDR) C + call consA_C # cons(nl, @) + ld (C) (L V) + ld (C CDR) A + call consC_A # cons(n, @) + ld (A) (L VI) + ld (A CDR) C + call consA_C # cons(@, car(q)) + ld (C) A + ld (C CDR) ((L IX)) + ld ((L IX)) C # -> car(q) + end + ld C (L VI) # n + call cons_A # cons(n, nl) + ld (A) C + ld (A CDR) (L V) + ld (L V) A # -> nl + add C (hex "10") # Increment + ld (L VI) C # -> n + call cons_A # cons(cdr(tp1), tp2) + ld (A) ((L III) CDR) + ld (A CDR) (L II) + ld (L II) A # -> tp2 + ld (L III) (((L IV)) CDR) # cdar(alt) -> tp1 + ld (L IV) Nil # alt = NIL + end + continue T + end + ld X (L III) # tp1? + atom X + if nz # No + ld C (L II) # tp2 + ld (L III) (C) # tp1 = car(tp2) + ld (L II) (C CDR) # tp2 = cdr(tp2) + ld (L V) ((L V) CDR) # nl = cdr(nl) + continue T + end + cmp (X) TSym # car(tp1) == T? + if eq + do + ld C ((L IX)) # car(q) + atom C # Any? + while z # Yes + cmp ((C)) ((L V)) # caaar(q) >= car(nl)? + while ge # Yes + ld ((L IX)) (C CDR) # car(q) = cdar(q) + loop + ld (L III) (X CDR) # tp1 = cdr(tp1) + continue T + end + num ((X)) # caar(tp1) numeric? + if nz # Yes + ld E ((X) CDR) # Eval cdar(tp1) + eval + ld (L I) E # -> e + ld C ((X)) # Get count + shr C 4 # Normalize short + ld A (L V) # nl + do + sub C 1 # Decrement + while nsz + ld A (A CDR) # Skip + loop + call cons_C # cons(car(A), nl) + ld (C) (A) + ld (C CDR) (L V) + ld (L V) C # -> nl + call cons_C # cons(cdr(tp1), tp2) + ld (C) (X CDR) + ld (C CDR) (L II) + ld (L II) C # -> tp2 + ld (L III) (L I) # tp1 = e + continue T + end + ld E ((X)) # caar(tp1) + sym E # Symbolic? + if nz # Yes + ld A (E TAIL) + call firstByteA_B # starting with "@"? + cmp B (char "@") + if eq # Yes + ld E ((X) CDR) # Eval cdar(tp1) + eval + ld (L I) E # -> e + cmp E Nil # Any? + if ne # Yes + ld C ((L V)) # car(nl) + ld Y ((X)) # caar(tp1) + ld E C # car(nl) + ld Z (L I) # e + call unifyCEYZ_F # Match? + if eq # Yes + ld (L III) ((L III) CDR) # tp1 = cdr(tp1) + continue T + end + end + ld X (((L IX))) # env = caar(q) + ld ((L IX)) (((L IX)) CDR) # car(q) = cdar(q) + ld (L VI) (X) # n = car(env) + ld X (X CDR) # env = cdr(env) + ld (L V) (X) # nl = car(env) + ld X (X CDR) # env = cdr(env) + ld (L IV) (X) # alt = car(env) + ld X (X CDR) # env = cdr(env) + ld (L III) (X) # tp1 = car(env) + ld X (X CDR) # env = cdr(env) + ld (L II) (X) # tp2 = car(env) + ld X (X CDR) # env = cdr(env) + ld (L VII) X # Set env + continue T + end + end + ld C TSym # get(caar(tp1), T) + call getEC_E + ld (L IV) E # -> alt + atom E # Atomic? + if nz # Yes + ld X (((L IX))) # env = caar(q) + ld ((L IX)) (((L IX)) CDR) # car(q) = cdar(q) + ld (L VI) (X) # n = car(env) + ld X (X CDR) # env = cdr(env) + ld (L V) (X) # nl = car(env) + ld X (X CDR) # env = cdr(env) + ld (L IV) (X) # alt = car(env) + ld X (X CDR) # env = cdr(env) + ld (L III) (X) # tp1 = car(env) + ld X (X CDR) # env = cdr(env) + ld (L II) (X) # tp2 = car(env) + ld X (X CDR) # env = cdr(env) + ld (L VII) X # Set env + end + loop + ld (L I) Nil # e = NIL + ld X (L VII) # env + do + atom (X CDR) + while z + ld Y ((X)) # Next binding + cmp (Y) ZERO # Top? + if eq # Yes + ld C ZERO # Look up + ld E (Y CDR) + call lookupCE_E + call consE_A # Cons with variable + ld (A) (Y CDR) + ld (A CDR) E + call consA_E # and e + ld (E) A + ld (E CDR) (L I) + ld (L I) E # -> e + end + ld X (X CDR) + loop + ld (At) (L (+ IX I)) # Restore '@' + ld E (L I) # Get e + atom E # Atomic? + if nz # Yes + atom (L VII) # 'env' atomic? + ld E Nil + ldz E TSym # No + end + drop + pop (Pnl) # Restore pilog environment pointers + pop (Penv) + pop Z + pop Y + pop X + ret + +(code 'lupCE_E 0) # Z + num E # x symbolic? + if z + sym E + if nz # Yes + ld A (E TAIL) # x + call firstByteA_B # starting with "@"? + cmp B (char "@") + if eq # Yes + ld Z ((Penv)) # Get pilog environment + do + ld A (Z) # car(y) + atom A # List? + while z # Yes + ld A (A) # caar(y) + cmp C (A) # n == caaar(y)? + if eq # Yes + cmp E (A CDR) # x == cdaar(y)? + if eq # Yes + ld A ((Z) CDR) + ld C (A) # n = cadar(y) + ld E (A CDR) # x = cddar(y) + jmp lupCE_E + end + end + ld Z (Z CDR) + loop + end + end + end + atom E # Atomic? + if z # No + push C # Save parameters + push E + ld E (E) # lup(n, car(x)) + call lupCE_E + pop A + pop C + link + push E # Save + link + ld E (A CDR) # lup(n, cdr(x)) + call lupCE_E + call consE_A # Cons + ld (A) (L I) + ld (A CDR) E + ld E A + drop + end + ret + +(code 'lookupCE_E 0) # Z + call lupCE_E + num E # Symbolic? + if z + sym E + if nz # Yes + ld A (E TAIL) + call firstByteA_B # starting with "@"? + cmp B (char "@") + jeq retNil # Yes + end + end + ret + +(code 'uniFillE_E 0) + num E # Number? + if z # No + sym E # Symbol? + if nz # Yes + ld C (((Pnl))) # Get Env + jmp lupCE_E # Look up + end + push E # Save list + ld E (E) # Recurse on CAR + call uniFillE_E + pop A # Get list + link + push E # Save result + link + ld E (A CDR) # Recurse on CDR + call uniFillE_E + call consE_A # Return cell + ld (A) (L I) + ld (A CDR) E + ld E A + drop + end + ret + +# (-> sym [num]) -> any +(code 'doArrow 2) + push Z + ld E (E CDR) # E on args + ld C ((Pnl)) # Environments + ld A (E CDR) + num (A) # 'num' arg? + if nz # Yes + ld A (A) # Get count + shr A 4 # Normalize short + do + sub A 1 # Decrement + while nsz + ld C (C CDR) # Skip + loop + end + ld C (C) # Get env + ld E (E) # 'sym' + call lookupCE_E + pop Z + ret + +# (unify 'any) -> lst +(code 'doUnify 2) + push X + push Y + push Z + ld E ((E CDR)) # Get arg + eval # Eval it + link + push E # Save 'any' + link + ld A ((Pnl)) # Environments + ld C ((A CDR)) # Second environment + ld E (A) # First environment + ld Y (L I) # 'any' + ld Z Y # 'any' + call unifyCEYZ_F # Match? + ld E Nil + if eq # Yes + ld E ((Penv)) + end + drop + pop Z + pop Y + pop X + ret + +## List Merge Sort: Bill McDaniel, DDJ Jun99 ### +# (sort 'lst ['fun]) -> lst +(code 'doSort 2) + push X + push Y + ld X E + ld Y (E CDR) # Y on args + ld E (Y) # Eval 'lst' + eval + atom E # List? + if z # Yes + push Z + push (EnvSort) # Save sort function + link + push E # Save 'lst' + ld E ((Y CDR)) # Eval 'fun' + eval+ + ld A Nil # Init local elements + cmp E Nil # User function? + if eq # No + ld (EnvSort) cmpDfltA_F # Use default sort function + xchg E (S) # <L VII> out[1] + else + ld (EnvSort) cmpUserAX_F # Use user supplied sort function + xchg E (S) # 'fun' + push A + push A # <L VIII> Apply args + push A # <L VII> out[1] + end + push E # <L VI> out[0] 'lst' + push A # <L V> in[1] + push A # <L IV> in[0] + push A # <L III> last[1] + push A # <L II> last[0] + push A # <L I> p + link + push A # <L -I> tail[1] + push A # <L -II> tail[0] + do + ld (L IV) (L VI) # in[0] = out[0] + ld (L V) (L VII) # in[1] = out[1] + lea Y (L IV) # &in[0] + atom (L V) # in[1] list? + if z # Yes + ld A Y # in + call (EnvSort) # Less? + if ge # No + lea Y (L V) # &in[1] + end + end + ld A (Y) # p = in[i] + ld (L I) A + atom A # List? + if z # Yes + ld (Y) (A CDR) # in[i] = cdr(in[i]) + end + ld (L VI) A # out[0] = p + lea (L -II) (A CDR) # tail[0] = &cdr(p) + ld (L III) (L VI) # last[1] = out[0] + ld (A CDR) Nil # cdr(p) = Nil + ld (L VII) Nil # out[1] = Nil + lea (L -I) (L VII) # tail[1] = &out[1] + do + atom (L V) # in[1] atomic? + if nz # Yes + atom (L IV) # in[0] also atomic? + break nz # Yes + ld Y (L IV) # p = in[0] + ld (L I) Y + atom Y # List? + if z # Yes + ld (L IV) (Y CDR) # in[0] = cdr(in[0]) + end + ld (L II) Y # last[0] = p + lea A (L II) # last + call (EnvSort) # Less? + if lt # Yes + xchg (L -I) (L -II) # Exchange tail[0] and tail[1] + end + else + atom (L IV) # in[0] atomic? + if nz # Yes + atom (L V) # in[1] also atomic? + break nz # Yes + ld Y (L V) # p = in[1] + ld (L I) Y + ld (L II) Y # last[0] = p + ld (L V) (Y CDR) # in[1] = cdr(in[1]) + lea A (L II) # last + call (EnvSort) # Less? + if lt # Yes + xchg (L -I) (L -II) # Exchange tail[0] and tail[1] + end + else # Both in[0] and in[1] are lists + lea A (L II) # last + ld (A) (L IV) # last[0] = in[0] + call (EnvSort) # Less? + if lt # Yes + lea A (L II) # last + ld (A) (L V) # last[0] = in[1] + call (EnvSort) # Less? + if ge # No + ld Y (L V) # p = in[1] + ld (L I) Y + ld (L V) (Y CDR) # in[1] = cdr(in[1]) + else + lea A (L IV) # in + call (EnvSort) # Less? + if lt # Yes + ld Y (L IV) # p = in[0] + ld (L I) Y + ld (L IV) (Y CDR) # in[0] = cdr(in[0]) + else + ld Y (L V) # p = in[1] + ld (L I) Y + ld (L V) (Y CDR) # in[1] = cdr(in[1]) + end + xchg (L -I) (L -II) # Exchange tail[0] and tail[1] + end + else + lea A (L II) # last + ld (A) (L V) # last[0] = in[1] + call (EnvSort) # Less? + if lt # Yes + ld Y (L IV) # p = in[0] + ld (L I) Y + ld (L IV) (Y CDR) # in[0] = cdr(in[0]) + else + lea A (L IV) # in + call (EnvSort) # Less? + if lt # Yes + ld Y (L IV) # p = in[0] + ld (L I) Y + ld (L IV) (Y CDR) # in[0] = cdr(in[0]) + else + ld Y (L V) # p = in[1] + ld (L I) Y + ld (L V) (Y CDR) # in[1] = cdr(in[1]) + end + end + end + end + end + ld ((L -II)) Y # *tail[0] = p + lea (L -II) (Y CDR) # tail[0] = &cdr(p) + ld (Y CDR) Nil # cdr(p) = Nil + ld (L III) Y # last[1] = p + loop + atom (L VII) # out[1] + until nz + ld E (L VI) # Return out[0] + drop + pop (EnvSort) + pop Z + end + pop Y + pop X + ret + +(code 'cmpDfltA_F 0) + ld E ((A I)) # Get CAR of second item + ld A ((A)) # and CAR of first item + jmp compareAE_F # Build-in compare function + +(code 'cmpUserAX_F 0) + push Y + lea Z (L VIII) # Point Z to apply args + ld (Z) ((A I)) # Copy CAR of second item + ld (Z I) ((A)) # and CAR of first item + lea Y (Z II) # Point Y to 'fun' + call applyXYZ_E # Apply + cmp E Nil # Check result + if ne + setc # Set carry if "less" + end + pop Y + ret + +# vi:et:ts=3:sw=3 diff --git a/src64/sym.l b/src64/sym.l @@ -0,0 +1,3417 @@ +# 23feb10abu +# (c) Software Lab. Alexander Burger + +### Compare long names ### +(code 'cmpLongAX_F 0) + push X # Keep X + do + cmp (A DIG) (X DIG) # Equal? + if ne # No + pop X + ret + end + ld A (A BIG) + ld X (X BIG) + big A # A on last digit? + if z # Yes + big X # X also on last digit? + if nz # No + setc # A is smaller + pop X + ret + end + cmp A X # Equal? + pop X + ret + end + cnt X # A not on last digit. X on last digit? + until nz # Yes + clrc # A is greater + pop X + ret + +### Is symbol interned? ### +# E symbol +# X name +# Y tree +(code 'isInternEXY_F 0) + cnt X # Short name? + if nz # Yes + ld Y (Y) # Y on first tree + do + atom Y # Empty? + jnz ret # Return NO + ld A ((Y) TAIL) # Next symbol + call nameA_A # Get name + cmp A X # Equal? + while ne # No + ld Y (Y CDR) + ldc Y (Y CDR) # Symbol is smaller + ldnc Y (Y) # Symbol is greater + loop + cmp E (Y) # Same Symbol? + ret # Return YES or NO + end + # Long name + ld Y (Y CDR) # Y on second tree + do + atom Y # Empty? + jnz ret # Return NO + ld A ((Y) TAIL) # Next symbol + call nameA_A # Get name + call cmpLongAX_F # Equal? + while ne # No + ld Y (Y CDR) + ldc Y (Y CDR) # Symbol is smaller + ldnc Y (Y) # Symbol is greater + loop + cmp E (Y) # Same Symbol? + ret # Return YES or NO + +### Intern a symbol/name ### +# E symbol +# X name +# Y tree +(code 'internEXY_FE 0) + cnt X # Short name? + if nz # Yes + ld C (Y) # C on first tree + atom C # Empty? + if nz # Yes + null E # New symbol? + if z + call consSymX_E # Yes + end + call consE_X # Cons into a new node + ld (X) E + ld (X CDR) Nil + ld (Y) X # Store in first tree + setc # Return new symbol + ret + end + do + ld A ((C) TAIL) # Next symbol + call nameA_A # Get name + cmp A X # Equal? + if eq # Yes + ld E (C) # Found symbol + clrc + ret + end + if lt # Symbol is smaller + atom (C CDR) # Already has link? + if nz # No + null E # New symbol? + if z + call consSymX_E # Yes + end + call consE_A # Cons into a new node + ld (A) E + ld (A CDR) Nil + call consA_X # Cons into a new link + ld (X) Nil + ld (X CDR) A + ld (C CDR) X + setc # Return new symbol + ret + end + ld C (C CDR) + atom (C CDR) # CDR of link? + ldz C (C CDR) # Yes: Get CDR of link in C + if nz # No + null E # New symbol? + if z + call consSymX_E # Yes + end + call consE_A # Cons into a new node + ld (A) E + ld (A CDR) Nil + ld (C CDR) A # Store in CDR of link + setc # Return new symbol + ret + end + else # Symbol is greater + atom (C CDR) # Already has link? + if nz # No + null E # New symbol? + if z + call consSymX_E # Yes + end + call consE_A # Cons into a new node + ld (A) E + ld (A CDR) Nil + call consA_X # Cons into a new link + ld (X) A + ld (X CDR) Nil + ld (C CDR) X + setc # Return new symbol + ret + end + ld C (C CDR) + atom (C) # CAR of link? + ldz C (C) # Yes: Get CAR of link in C + if nz # No + null E # New symbol? + if z + call consSymX_E # Yes + end + call consE_A # Cons into a new node + ld (A) E + ld (A CDR) Nil + ld (C) A # Store in CAR of link + setc # Return new symbol + ret + end + end + loop + end + # Long name + ld C (Y CDR) # C on second tree + atom C # Empty? + if nz # Yes + null E # New symbol? + if z + call consSymX_E # Yes + end + call consE_X # Cons into a new node + ld (X) E + ld (X CDR) Nil + ld (Y CDR) X # Store in second tree + setc # Return new symbol + ret + end + do + ld A ((C) TAIL) # Next symbol + call nameA_A # Get name + call cmpLongAX_F # Equal? + if eq # Yes + ld E (C) # Found symbol + clrc + ret + end + if lt # Symbol is smaller + atom (C CDR) # Already has link? + if nz # No + null E # New symbol? + if z + call consSymX_E # Yes + end + call consE_A # Cons into a new node + ld (A) E + ld (A CDR) Nil + call consA_X # Cons into a new link + ld (X) Nil + ld (X CDR) A + ld (C CDR) X + setc # Return new symbol + ret + end + ld C (C CDR) + atom (C CDR) # CDR of link? + ldz C (C CDR) # Yes: Get CDR of link in C + if nz # No + null E # New symbol? + if z + call consSymX_E # Yes + end + call consE_A # Cons into a new node + ld (A) E + ld (A CDR) Nil + ld (C CDR) A # Store in CDR of link + setc # Return new symbol + ret + end + else # Symbol is greater + atom (C CDR) # Already has link? + if nz # No + null E # New symbol? + if z + call consSymX_E # Yes + end + call consE_A # Cons into a new node + ld (A) E + ld (A CDR) Nil + call consA_X # Cons into a new link + ld (X) A + ld (X CDR) Nil + ld (C CDR) X + setc # Return new symbol + ret + end + ld C (C CDR) + atom (C) # CAR of link? + ldz C (C) # Yes: Get CAR of link in C + if nz # No + null E # New symbol? + if z + call consSymX_E # Yes + end + call consE_A # Cons into a new node + ld (A) E + ld (A CDR) Nil + ld (C) A # Store in CAR of link + setc # Return new symbol + ret + end + end + loop + +(code 'findSymX_E 0) # Y + ld E 0 # No symbol yet + ld Y Intern + call internEXY_FE # New internal symbol? + jnc Ret # No + ld (E) Nil # Init to 'NIL' + ret + +# X name +(code 'externX_E 0) # C + ld C 3 # Reserve three cells + call needC + push X # <S> Save name + ld A 6364136223846793005 # Randomize + mul X + ld E A # Key in E + ld X Extern # X on external symbol tree root node + do + ld A ((X) TAIL) # Next symbol + call nameA_A # Get name + and A (hex "3FFFFFFFFFFFFFF7") # Mask status and extern bits + mul 6364136223846793005 # Randomize + cmp A E # Equal to key? + if eq # Yes + pop A # Drop name + ld E (X) # Found symbol + ret + end + if lt # Symbol is smaller + atom (X CDR) # Already has link? + if nz # No + call cons_E # New symbol + pop (E) # Retrieve name + or (E) SYM # Set 'extern' tag + or E SYM # Make symbol + ld (E) Nil # Init to 'NIL' + call consE_A # Cons into a new node + ld (A) E + ld (A CDR) Nil + call consA_C # Cons into a new link + ld (C) Nil + ld (C CDR) A + ld (X CDR) C + ret + end + ld X (X CDR) + atom (X CDR) # CDR of link? + ldz X (X CDR) # Yes: Get CDR of link in X + if nz # No + call cons_E # New symbol + pop (E) # Retrieve name + or (E) SYM # Set 'extern' tag + or E SYM # Make symbol + ld (E) Nil # Init to 'NIL' + call consE_A # Cons into a new node + ld (A) E + ld (A CDR) Nil + ld (X CDR) A # Store in CDR of link + ret + end + else # Symbol is greater + atom (X CDR) # Already has link? + if nz # No + call cons_E # New symbol + pop (E) # Retrieve name + or (E) SYM # Set 'extern' tag + or E SYM # Make symbol + ld (E) Nil # Init to 'NIL' + call consE_A # Cons into a new node + ld (A) E + ld (A CDR) Nil + call consA_C # Cons into a new link + ld (C) A + ld (C CDR) Nil + ld (X CDR) C + ret + end + ld X (X CDR) + atom (X) # CAR of link? + ldz X (X) # Yes: Get CAR of link in X + if nz # No + call cons_E # New symbol + pop (E) # Retrieve name + or (E) SYM # Set 'extern' tag + or E SYM # Make symbol + ld (E) Nil # Init to 'NIL' + call consE_A # Cons into a new node + ld (A) E + ld (A CDR) Nil + ld (X) A # Store in CAR of link + ret + end + end + loop + +### Unintern a symbol ### +# X name +# Y tree +(code 'uninternXY 0) + cmp X ZERO # Name? + jeq ret # No + cnt X # Short name? + if nz # Yes + do # Y on first tree + ld C (Y) # Next node + atom C # Empty? + jnz ret # Yes + ld A ((C) TAIL) # Next symbol + call nameA_A # Get name + cmp A X # Equal? + if eq # Yes + ld A (C CDR) # Get subtrees + atom (A) # Left branch? + if nz # No + ld (Y) (A CDR) # Use right branch + ret + end + atom (A CDR) # Right branch? + if nz # No + ld (Y) (A) # Use left branch + ret + end + ld A (A CDR) # A on right branch + ld Y (A CDR) # Y on sub-branches + atom (Y) # Left? + if nz # No + ld (C) (A) # Insert right sub-branch + ld ((C CDR) CDR) (Y CDR) + ret + end + ld Y (Y) # Left sub-branch + do + ld X (Y CDR) # More left branches? + atom (X) + while z # Yes + ld A Y # Go down left + ld Y (X) + loop + ld (C) (Y) # Insert left sub-branch + ld ((A CDR)) (X CDR) + ret + end + ld C (C CDR) + if lt # Symbol is smaller + atom C # Link? + jnz ret # No + lea Y (C CDR) # Go right + else # Symbol is greater + atom C # Link? + jnz ret # No + ld Y C # Go left + end + loop + end + # Long name + lea Y (Y CDR) + do # Y on second tree + ld C (Y) # Get next node + atom C # Empty? + jnz ret # Yes + ld A ((C) TAIL) # Next symbol + call nameA_A # Get name + call cmpLongAX_F # Equal? + if eq # Yes + ld A (C CDR) # Get subtrees + atom (A) # Left branch? + if nz # No + ld (Y) (A CDR) # Use right branch + ret + end + atom (A CDR) # Right branch? + if nz # No + ld (Y) (A) # Use left branch + ret + end + ld A (A CDR) # A on right branch + ld Y (A CDR) # Y on sub-branches + atom (Y) # Left? + if nz # No + ld (C) (A) # Insert right sub-branch + ld ((C CDR) CDR) (Y CDR) + ret + end + ld Y (Y) # Left sub-branch + do + ld X (Y CDR) # More left branches? + atom (X) + while nz # Yes + ld A Y # Go down left + ld Y (X) + loop + ld (C) (Y) # Insert left sub-branch + ld ((A CDR)) (X CDR) + ret + end + ld C (C CDR) + if lt # Symbol is smaller + atom C # Link? + jnz ret # No + lea Y (C CDR) # Go right + else # Symbol is greater + atom C # Link? + jnz ret # No + ld Y C # Go left + end + loop + +(code 'nameA_A 0) + off A SYM # Clear 'extern' tag + do + num A # Find name + jnz ret + ld A (A CDR) # Skip property + loop + +(code 'nameE_E 0) + off E SYM # Clear 'extern' tag + do + num E # Find name + jnz ret + ld E (E CDR) # Skip property + loop + +(code 'nameX_X 0) + off X SYM # Clear 'extern' tag + do + num X # Find name + jnz ret + ld X (X CDR) # Skip property + loop + +(code 'nameY_Y 0) + off Y SYM # Clear 'extern' tag + do + num Y # Find name + jnz ret + ld Y (Y CDR) # Skip property + loop + +# (name 'sym ['sym2]) -> sym +(code 'doName 2) + push X + push Y + ld X E + ld Y (E CDR) # Y on args + ld E (Y) # Eval 'sym' + eval + num E # Need symbol + jnz symErrEX + sym E + jz symErrEX + ld Y (Y CDR) # Second arg? + atom Y + if nz # No + cmp E Nil # NIL? + if ne # No + ld X (E TAIL) + sym X # External symbol? + if z # No + call nameX_X # Get name + call consSymX_E # Make new transient symbol + else + call nameX_X # Get name + call packExtNmX_E # Pack it + end + end + else + cmp E Nil # NIL? + jeq renErrEX # Yes + sym (E TAIL) # External symbol? + jnz renErrEX # Yes + push X # Save expression + push Y + ld X (E TAIL) + call nameX_X # Get name + ld Y Intern # Internal symbol? + call isInternEXY_F + pop Y + pop X + jz renErrEX # Yes + link + push E # <L I> First (transient) symbol + link + ld E (Y) + eval # Eval second arg + num E # Need symbol + jnz symErrEX + sym E + jz symErrEX + ld X (E TAIL) + call nameX_X # Get name + ld E (L I) # Get first symbol + lea Y (E TAIL) + do + num (Y) # Find name + while z + lea Y ((Y) CDR) + loop + ld (Y) X # Store name of second + drop + end + pop Y + pop X + ret + +# Make single-char symbol +(code 'mkCharA_A 0) + cmp A (hex "80") # ASCII? + if ge # No + cmp A (hex "800") # Double-byte? + if lt # Yes + ld (Buf) B # 110xxxxx 10xxxxxx + shr A 6 # Upper five bits + and B (hex "1F") + or B (hex "C0") + xchg B (Buf) # Save first byte + and A (hex "3F") # Lower 6 bits + or B (hex "80") + shl A 8 # into second byte + ld B (Buf) # Get first byte + else + cmp A TOP # Special "top" character? + if eq # Yes + ld B (hex "FF") # Above legal UTF-8 + zxt + else + push C + ld C A # 1110xxxx 10xxxxxx 10xxxxxx + shr A 12 # Hightest four bits + and B (hex "0F") + or B (hex "E0") + ld (Buf) B # Save first byte + ld A C + shr A 6 # Middle six bits + and A (hex "3F") + or B (hex "80") + shl A 8 # into second byte + xchg A C + and A (hex "3F") # Lowest 6 bits + or B (hex "80") # Add third byte + shl A 16 # into third byte + or A C # Combine with second byte + ld B (Buf) # and first byte + pop C + end + end + end + shl A 4 # Make short name + or A CNT + push A # Save character + call cons_A # New cell + pop (A) # Set name + or A SYM # Make symbol + ld (A) A # Set value to itself + ret + +(code 'mkStrE_E 0) + null E # NULL pointer? + jz retNil + nul (E) # Empty string? + jz retNil + push C + push X + link + push ZERO # <L I> Name + ld C 4 # Build name + ld X S + link + do + ld B (E) + call byteSymBCX_CX # Pack byte + add E 1 # Next byte + nul (E) # Any? + until z + call cons_E # Cons symbol + ld (E) (L I) # Set name + or E SYM # Make symbol + ld (E) E # Set value to itself + drop + pop X + pop C + ret + +(code 'mkStrEZ_A 0) + push X + link + push ZERO # <L I> Name + ld C 4 # Build name + ld X S + link + do + ld B (E) + call byteSymBCX_CX # Pack byte + cmp E Z # Reached Z? + while ne # No + add E 1 # Next byte + nul (E) # Any? + until z + call cons_A # Cons symbol + ld (A) (L I) # Set name + or A SYM # Make symbol + ld (A) A # Set value to itself + drop + pop X + ret + +(code 'firstByteA_B 0) + call nameA_A # Get name + cnt A # Short? + if nz # Yes + shr A 4 # Normalize + else + ld A (A DIG) # Get first digit + end + ret + +(code 'firstCharE_A 0) + ld A 0 + cmp E Nil # NIL? + if ne # No + push X + ld X (E TAIL) + call nameX_X # Get name + ld C 0 + call symCharCX_FACX # Get first character + pop X + end + ret + +(code 'isBlankE_F 0) + num E # Symbol? + jnz ret # No + sym E + jz retnz # No + cmp E Nil # NIL? + jz ret # Yes + sym (E TAIL) # External symbol? + jnz ret # Yes + push X + ld X (E TAIL) + call nameX_X # Get name + ld C 0 + do + call symByteCX_FACX # Next byte + while nz + cmp B 32 # Larger than blank? + break gt # Yes + loop + pop X + ret + +# (sp? 'any) -> flg +(code 'doSpQ 2) + ld E ((E CDR)) # Get arg + eval # Eval it + call isBlankE_F # Blank? + ld E TSym # Yes + ldnz E Nil + ret + +# (pat? 'any) -> sym | NIL +(code 'doPatQ 2) + ld E ((E CDR)) # Get arg + eval # Eval it + num E # Number? + jnz retNil # Yes + sym E # Symbol? + jz retNil # No + ld A (E TAIL) + call firstByteA_B # starting with "@"? + cmp B (char "@") + ldnz E Nil # No + ret + +# (fun? 'any) -> any +(code 'doFunQ 2) + ld E ((E CDR)) # Get arg + eval # Eval it + call funqE_FE # Function definition? + ldnz E Nil # No + ret + +# (getd 'any) -> fun | NIL +(code 'doGetd 2) + ld E ((E CDR)) # E on arg + eval # Eval it + num E # No number? + if z # Yes + sym E # Symbol? + if nz # Yes + push E + ld E (E) # Get value + call funqE_FE # Function definition? + pop E + if eq # Yes + ld E (E) # Return value + ret + end + cmp (E) Nil # Value NIL? + if eq # Yes + ld C E + call sharedLibC_FA # Dynamically loaded? + if nz # Yes + ld E A # Return function pointer + ret + end + end + end + end + ld E Nil + ret + +# (all ['NIL | 'T | '0 | '(NIL . flg) | '(T . flg) | '(0)]) -> lst +(code 'doAll 2) + push X + ld E ((E CDR)) # Eval arg + eval + atom E # Direct tree? + if z # Yes + cmp (E) Nil # Internal trees? + if eq # Yes + cmp (E CDR) Nil # Short names? + ldz E (Intern) # Yes + ldnz E (Intern I) + else + cmp (E) TSym # Transient trees? + ldnz E Extern # No: External symbols + if eq # Yes + cmp (E CDR) Nil # Short names? + ldz E (Transient) # Yes + ldnz E (Transient I) + end + end + else + cmp E Nil # Nil? + if eq # Yes + ld X (Intern I) # Internal symbols + call consTreeXE_E + ld X (Intern) + else + cmp E TSym # T? + if eq # Yes + ld E Nil + ld X (Transient I) # Transient symbols + call consTreeXE_E + ld X (Transient) + else + ld E Nil + ld X Extern # External symbols + end + end + call consTreeXE_E + end + pop X + ret + +(code 'consTreeXE_E 0) + atom X # Tree empty? + jnz ret # Yes + link + push X # <L II> Tree + push Nil # <L I> TOS + link + do + do + ld A (X CDR) # Get subtrees + atom (A CDR) # Right subtree? + while z # Yes + ld C X # Go right + ld X (A CDR) # Invert tree + ld (A CDR) (L I) # TOS + ld (L I) C + loop + ld (L II) X # Save tree + do + call consE_A # Cons value + ld (A) (X) + ld (A CDR) E + ld E A # into E + ld A (X CDR) # Left subtree? + atom (A) + if z # Yes + ld C X # Go left + ld X (A) # Invert tree + ld (A) (L I) # TOS + or C SYM # First visit + ld (L I) C + ld (L II) X # Save tree + break T + end + do + ld A (L I) # TOS + cmp A Nil # Empty? + jeq 90 # Done + sym A # Second visit? + if z # Yes + ld C (A CDR) # Nodes + ld (L I) (C CDR) # TOS on up link + ld (C CDR) X + ld X A + ld (L II) X # Save tree + break T + end + off A SYM # Set second visit + ld C (A CDR) # Nodes + ld (L I) (C) + ld (C) X + ld X A + ld (L II) X # Save tree + loop + loop + loop +90 drop # Return E + ret + +# (intern 'sym) -> sym +(code 'doIntern 2) + push X + ld X E + ld E ((E CDR)) # E on arg + eval # Eval it + num E # Need symbol + jnz symErrEX + sym E + jz symErrEX + ld X (E TAIL) + call nameX_X # Get name + zero X # Any? + if ne # Yes + push Y + ld Y Intern # Insert internal + call internEXY_FE + pop Y + pop X + ret + end + ld E Nil + pop X + ret + +# (extern 'sym) -> sym | NIL +(code 'doExtern 2) + push X + push Y + ld X E + ld E ((E CDR)) # E on arg + eval # Eval it + num E # Need symbol + jnz symErrEX + sym E + jz symErrEX + ld X (E TAIL) + call nameX_X # Get name + zero X # Any? + if ne # Yes + ld C 0 # Character index + call symCharCX_FACX # First char + cmp B (char "{") # Open brace? + if eq # Yes + call symCharCX_FACX # Skip it + end + ld E 0 # Init file number + do + cmp B (char "@") # File done? + while ge # No + cmp B (char "O") # In A-O range? + jgt 90 # Yes + sub B (char "@") + shl E 4 # Add to file number + add E A + call symCharCX_FACX # Next char? + jz 90 # No + loop + cmp B (char "0") # Octal digit? + jlt 90 + cmp B (char "7") + jgt 90 # No + sub B (char "0") + zxt + ld Y A # Init object ID + do + call symCharCX_FACX # Next char? + while nz # Yes + cmp B (char "}") # Closing brace? + while ne # No + cmp B (char "0") # Octal digit? + jlt 90 + cmp B (char "7") + jgt 90 # No + sub B (char "0") + shl Y 3 # Add to object ID + add Y A + loop + ld C Y # Object ID + call extNmCE_X # Build external symbol name + call externX_E # New external symbol + call isLifeE_F # Alive? + ldnz E Nil # No + pop Y + pop X + ret + end +90 ld E Nil + pop Y + pop X + ret + +# (==== ['sym ..]) -> NIL +(code 'doHide 2) + ld A Nil # Clear transient index trees + ld (Transient) A + ld (Transient I) A + push X + push Y + push Z + ld X E + ld Z (E CDR) # Args + do + atom Z # More? + while z # Yes + ld E (Z) # Eval next + eval + num E # Need symbol + jnz symErrEX + sym E + jz symErrEX + push X + ld X (E TAIL) + call nameX_X # Get name + ld Y Transient # Insert transient + call internEXY_FE + pop X + ld Z (Z CDR) # Z on rest + loop + pop Z + pop Y + pop X + ret + +# (box? 'any) -> sym | NIL +(code 'doBoxQ 2) + ld E ((E CDR)) # Get arg + eval # Eval it + num E # Number? + jnz retNil # Yes + sym E # Symbol? + jz retNil # No + ld A (E TAIL) + call nameA_A # Get name + cmp A ZERO # Any? + jne retNil + ret + +# (str? 'any) -> sym | NIL +(code 'doStrQ 2) + ld E ((E CDR)) # Get arg + eval # Eval it + num E # Number? + jnz retNil # Yes + sym E # Symbol? + jz retNil # No + sym (E TAIL) # External symbol? + jnz retNil # Yes + push X + push Y + ld X (E TAIL) # Get name + call nameX_X + ld Y Intern # Internal symbol? + call isInternEXY_F + ldz E Nil # Return NIL + pop Y + pop X + ret + +# (ext? 'any) -> sym | NIL +(code 'doExtQ 2) + ld E ((E CDR)) # Get arg + eval # Eval it + num E # Number? + jnz retNil # Yes + sym E # Symbol? + jz retNil # No + ld A (E TAIL) + sym A # External symbol? + jz retNil # No + call isLifeE_F # Alive? + ldnz E Nil # No + ret + +# (touch 'sym) -> sym +(code 'doTouch 2) + ld E ((E CDR)) # Get arg + eval # Eval it + num E # Need symbol + jnz symErrEX + sym E + jz symErrEX + sym (E TAIL) # External symbol? + if nz # Yes + call dbTouchEX # Touch it + end + ret + +# (zap 'sym) -> sym +(code 'doZap 2) + push X + ld X E + ld E ((E CDR)) # E on arg + eval # Eval it + num E # Need symbol + jnz symErrEX + sym E + jz symErrEX + ld A (E TAIL) + sym A # External symbol? + if nz # Yes + call dbZapE # Mark as "deleted" + else + cmp E Nil # Between 'NIL' and '*Bye'? + if ge + cmp E Bye + jle protErrEX # Yes + end + push Y + ld X (E TAIL) + call nameX_X # Get name + ld Y Intern + call uninternXY # Unintern symbol + pop Y + end + pop X + ret + +# (chop 'any) -> lst +(code 'doChop 2) + ld E ((E CDR)) # Get arg + eval # Eval it + atom E # Atomic? + if nz # Yes + cmp E Nil # NIL? + if ne # No + push X + call xSymE_E # Extract symbol + ld X (E TAIL) + call nameX_X # Get name + sym (E TAIL) # External symbol? + if z # No + ld C 0 + call symCharCX_FACX # First char? + if nz # Yes + push Y + link + push X # Save name + link + call mkCharA_A # Make single character + call consA_Y # Cons it + ld (Y) A + ld (Y CDR) Nil # with NIL + tuck Y # <L I> Result + link + do + call symCharCX_FACX # Next char + while nz + call mkCharA_A # Make char + call consA_E # Cons it + ld (E) A + ld (E CDR) Nil + ld (Y CDR) E # Append to result + ld Y E + loop + ld E (L I) # Get result + drop + pop Y + else + ld E Nil # Else return NIL + end + else # External symbol + call chopExtNmX_E + end + pop X + end + end + ret + +# (pack 'any ..) -> sym +(code 'doPack 2) + push X + push Y + push Z + ld Y (E CDR) # Y on args + ld E (Y) # Eval first + eval + link + push E # <L III> 'any' + push ZERO # <L II> Safe + push ZERO # <L I> Result + ld C 4 # Build name + ld X S + link + do + call packECX_CX + ld Y (Y CDR) # More args? + atom Y + while z # Yes + ld Z C # Save C + ld E (Y) # Eval next arg + eval + ld (L III) E # Save + ld C Z + loop + ld X (L I) # Get result + call consSymX_E # Make transient symbol + drop + pop Z + pop Y + pop X + ret + +(code 'packECX_CX 0) + atom E # Atomic? + if z # No + do # List + push (E CDR) # Save rest + ld E (E) # Recurse on CAR + call packECX_CX + pop E # Done? + atom E + until nz # Yes + end + cmp E Nil # NIL? + jeq ret # Yes + num E # Number? + if z # No + sym (E TAIL) # External symbol? + if nz # Yes + ld B (char "{") + call byteSymBCX_CX # Pack "{" + push C # Save status + push X + ld X (E TAIL) # Get name + call nameX_X + call packExtNmX_E # Pack name + ld (L II) E # Save + pop X # Restore status + pop C + call 10 # Pack external symbol + ld B (char "}") + jmp byteSymBCX_CX # Pack "}" + end + else + ld A 0 # Scale + call fmtNum0AE_E # Convert to symbol + ld (L II) E # Save + end +10 push C # Save status + push X + ld X (E TAIL) + call nameX_X # Get name + ld C 0 + do + call symByteCX_FACX # Next char + while nz + xchg C (S I) # Swap status + xchg X (S) + call byteSymBCX_CX # Pack byte + xchg X (S) # Swap status + xchg C (S I) + loop + pop X # Restore status + pop C + ret + +# (glue 'any 'lst) -> sym +(code 'doGlue 2) + push X + push Y + ld X (E CDR) # Args + ld E (X) # Eval first + eval + link + push E # <L IV> 'any' + ld X (X CDR) # X on rest + ld E (X) # Eval second + eval+ + push E # <L III> 'lst' + push ZERO # <L II> Number safe + push ZERO # <L I> Result + ld C 4 # Build name + ld X S + link + atom E # Any items? + if z # Yes + ld Y E # 'lst' + do + ld E (Y) # Get next item + call packECX_CX # Pack it + ld Y (Y CDR) # More? + atom Y + while z # Yes + ld E (L IV) # Get 'any' + call packECX_CX # Pack it + loop + ld X (L I) # Get result + call consSymX_E # Make transient symbol + end + drop + pop Y + pop X + ret + +# (text 'any1 'any ..) -> sym +(code 'doText 2) + push X + push Y + ld X (E CDR) # Args + call evSymX_E # Eval first + cmp E Nil # NIL? + if nz + ld E (E TAIL) + call nameE_E # Get name + link + push E # <(L) -I> Name of 'any1' + do + ld X (X CDR) # Next arg + atom X # Any? + while z # Yes + ld E (X) # Eval next arg + eval+ + push E # and save it + loop + push ZERO # <L II> Number safe + push ZERO # <L I> Result + ld X S + link + push 4 # <S I> Build name + push X # <S> Pack status + ld X ((L) -I) # Get name of 'any1' + ld C 0 # Index + do + call symByteCX_FACX # Next char? + while nz + cmp B (char "@") # Pattern? + if ne # No +10 xchg C (S I) # Swap status + xchg X (S) + call byteSymBCX_CX # Pack byte + xchg X (S) # Swap status + xchg C (S I) + continue T + end + call symByteCX_FACX # Next char after "@"? + while nz + cmp B (char "@") # "@@"? + jeq 10 # Yes + sub B (char "0") # >= "1"? + if gt # Yes + cmp B 8 # > 8? + if gt + sub B 7 # Adjust for letter + end + shl A 3 # Vector index + lea E ((L) -I) # Point above first 'any' arg + sub E A # Get arg address + lea A (L II) # Address of number save + cmp E A # Arg address too low? + if gt # No + ld E (E) + xchg C (S I) # Swap status + xchg X (S) + call packECX_CX # Pack it + xchg X (S) # Swap status + xchg C (S I) + end + end + loop + ld X (L I) # Get result + call consSymX_E # Make transient symbol + drop + end + pop Y + pop X + ret + +(code 'preCEXY_F 0) + do + call symByteCX_FACX # First string done? + jz ret # Yes + ld (Buf) B # Keep + xchg C E # Second string + xchg X Y + call symByteCX_FACX # Next byte? + jz retnz # No + cmp (Buf) B # Equal? + jne ret # No + xchg C E # First string + xchg X Y + loop + +(code 'subStrAE_F 0) + cmp A Nil # NIL? + jeq ret # Yes + ld A (A TAIL) # First symbol + call nameA_A # Get name + zero A # None? + jeq ret # Yes + ld E (E TAIL) # Second symbol + call nameE_E # Get name + zero E # Any? + jeq retnz # No + push X + push Y + push Z + push A # <S I> First name + ld Z E # Second name + push 0 # <S> Second index + do + ld X (S I) # First name + ld C 0 # First index + ld Y Z # Second name + ld E (S) # Second index + call preCEXY_F # Prefix? + while ne # No + ld A (S) + shr A 8 # New round in second index? + if z # Yes + zero Z # Second done? + if eq # Yes + clrz # 'nz' + break T + end + cnt Z # Short? + if nz # Yes + ld A Z # Get short + shr A 4 # Normalize + ld Z ZERO # Clear for next round + else + ld A (Z DIG) # Get next digit + ld Z (Z BIG) + end + end + ld (S) A + loop + pop A # Drop locals + pop A + pop Z + pop Y + pop X + ret + +# (pre? 'any1 'any2) -> any2 | NIL +(code 'doPreQ 2) + push X + push Y + push Z + ld X (E CDR) # X on args + call evSymX_E # Eval first + link + push E # <L I> 'any1' + link + ld X (X CDR) # Next arg + call evSymX_E # Eval second + ld X (L I) # 'any1' + cmp X Nil # NIL? + if ne # No + ld Z E # Keep second in Z + ld X (X TAIL) # 'any1' + call nameX_X # First name + ld C 0 + ld E (E TAIL) # 'any2' + call nameE_E # Second name + ld Y E + ld E 0 + call preCEXY_F # Prefix? + ld E Nil + ldz E Z # Yes + end + drop + pop Z + pop Y + pop X + ret + +# (sub? 'any1 'any2) -> any2 | NIL +(code 'doSubQ 2) + push X + ld X (E CDR) # X on args + call evSymX_E # Eval first + link + push E # <L I> 'any1' + link + ld X (X CDR) # Next arg + call evSymX_E # Eval second + ld A (L I) # 'any1' + ld X E # Keep second in X + call subStrAE_F # Substring? + ld E Nil + ldz E X # Yes + drop + pop X + ret + +# (val 'var) -> any +(code 'doVal 2) + push X + ld X E + ld E ((E CDR)) # E on arg + eval # Eval it + num E # Need variable + jnz varErrEX + sym E # Symbol? + if nz # Yes + sym (E TAIL) # External symbol? + if nz # Yes + call dbFetchEX # Fetch it + end + end + ld E (E) # Return value + pop X + ret + +# (set 'var 'any ..) -> any +(code 'doSet 2) + push X + push Y + ld X E + ld Y (E CDR) # Y on args + link + push ZERO # <L I> Safe + link + do + ld E (Y) # Eval next + eval + call needVarEX # Need variable + sym E # Symbol? + if nz # Yes + sym (E TAIL) # External symbol? + if nz # Yes + call dbTouchEX # Touch it + end + end + ld (L I) E # Save it + ld Y (Y CDR) # Next arg + ld E (Y) + eval # Eval 'any' + ld ((L I)) E # Set value + ld Y (Y CDR) # Next arg + atom Y # Any? + until nz # No + drop + pop Y + pop X + ret + +# (setq var 'any ..) -> any +(code 'doSetq 2) + push X + push Y + push Z + ld X E + ld Y (E CDR) # Y on args + do + ld E (Y) # Next var + call needVarEX # Need variable + ld Z E # Keep in Z + ld Y (Y CDR) # Eval next arg + ld E (Y) + eval + ld (Z) E # Store value + ld Y (Y CDR) # More args? + atom Y + until nz # No + pop Z + pop Y + pop X + ret + +# (xchg 'var 'var ..) -> any +(code 'doXchg 2) + push X + push Y + ld X E + ld Y (E CDR) # Y on args + link + push ZERO # <L I> Safe + link + do + ld E (Y) # Eval next + eval + call needVarEX # Need variable + sym E # Symbol? + if nz # Yes + sym (E TAIL) # External symbol? + if nz # Yes + call dbTouchEX # Touch it + end + end + ld (L I) E # Save it + ld Y (Y CDR) # Next arg + ld E (Y) + eval # Eval next arg + call needVarEX # Need variable + sym E # Symbol? + if nz # Yes + sym (E TAIL) # External symbol? + if nz # Yes + call dbTouchEX # Touch it + end + end + ld C (L I) # Get first 'var' + ld A (C) # Get value + ld (C) (E) # Set new + ld (E) A + ld Y (Y CDR) # Next arg + atom Y # Any? + until nz # No + ld E A # Return last + drop + pop Y + pop X + ret + +# (on var ..) -> T +(code 'doOn 2) + push X + ld X (E CDR) + do + ld E (X) # Get next arg + call needVarEX # Need variable + ld (E) TSym # Set to 'T' + ld X (X CDR) # More? + atom X + until nz # No + ld E TSym + pop X + ret + +# (off var ..) -> NIL +(code 'doOff 2) + push X + ld X (E CDR) + do + ld E (X) # Get next arg + call needVarEX # Need variable + ld (E) Nil # Set to 'NIL' + ld X (X CDR) # More? + atom X + until nz # No + ld E Nil + pop X + ret + +# (onOff var ..) -> flg +(code 'doOnOff 2) + push X + ld X (E CDR) + do + ld E (X) # Get next arg + call needVarEX # Need variable + cmp (E) Nil # Value NIL? + ld A TSym # Negate + ldnz A Nil + ld (E) A # Set new value + ld X (X CDR) # More? + atom X + until nz # No + ld E A # Return last + pop X + ret + +# (zero var ..) -> 0 +(code 'doZero 2) + push X + ld X (E CDR) + do + ld E (X) # Get next arg + call needVarEX # Need variable + ld (E) ZERO # Set to '0' + ld X (X CDR) # More? + atom X + until nz # No + ld E ZERO + pop X + ret + +# (one var ..) -> 1 +(code 'doOne 2) + push X + ld X (E CDR) + do + ld E (X) # Get next arg + call needVarEX # Need variable + ld (E) ONE # Set to '1' + ld X (X CDR) # More? + atom X + until nz # No + ld E ONE + pop X + ret + +# (default sym 'any ..) -> any +(code 'doDefault 2) + push X + push Y + push Z + ld X E + ld Y (E CDR) # Y on args + do + ld E (Y) # Next var + ld Y (Y CDR) + call needVarEX # Need variable + ld Z E # Keep in Z + cmp (Z) Nil # Value 'NIL'? + if eq # Yes + ld E (Y) # Eval next arg + eval + ld (Z) E # Store value + end + ld Y (Y CDR) # More args? + atom Y + until nz # No + ld E (Z) # Return value + pop Z + pop Y + pop X + ret + +# (push 'var 'any ..) -> any +(code 'doPush 2) + push X + push Y + ld X E + ld Y (E CDR) # Y on args + ld E (Y) # Eval first + eval + call needVarEX # Need variable + sym E # Symbol? + if nz # Yes + sym (E TAIL) # External symbol? + if nz # Yes + call dbTouchEX # Touch it + end + end + link + push E # <L I> 'var' + link + ld Y (Y CDR) # Second arg + do + ld E (Y) + eval # Eval next arg + call consE_A # Cons into value + ld (A) E + ld C (L I) # 'var' + ld (A CDR) (C) + ld (C) A + ld Y (Y CDR) # Next arg + atom Y # Any? + until nz # No + drop + pop Y + pop X + ret + +# (push1 'var 'any ..) -> any +(code 'doPush1 2) + push X + push Y + push Z + ld X E + ld Y (E CDR) # Y on args + ld E (Y) # Eval first + eval + call needVarEX # Need variable + sym E # Symbol? + if nz # Yes + sym (E TAIL) # External symbol? + if nz # Yes + call dbTouchEX # Touch it + end + end + link + push E # <L I> 'var' + link + ld Y (Y CDR) # Second arg + do + ld E (Y) + eval # Eval next arg + ld C ((L I)) # Value of 'var' + do # 'member' + atom C # List? + while z # Yes + ld A (C) + ld Z E # Preserve E + call equalAE_F # Member? + ld E Z + jeq 10 # Yes + ld C (C CDR) + loop + call consE_A # Cons into value + ld (A) E + ld C (L I) # 'var' + ld (A CDR) (C) + ld (C) A +10 ld Y (Y CDR) # Next arg + atom Y # Any? + until nz # No + drop + pop Z + pop Y + pop X + ret + +# (pop 'var) -> any +(code 'doPop 2) + push X + ld X E + ld E ((E CDR)) # E on arg + eval # Eval it + call needVarEX # Need variable + sym E # Symbol? + if nz # Yes + sym (E TAIL) # External symbol? + if nz # Yes + call dbTouchEX # Touch it + end + end + ld A E # 'var' in A + ld E (A) # Get value + atom E # List? + if z # Yes + ld (A) (E CDR) # Set to CDR + ld E (E) # Return CAR + end + pop X + ret + +# (cut 'cnt 'var) -> lst +(code 'doCut 2) + push X + push Y + ld X E + ld Y (E CDR) # Y on args + call evCntXY_FE # Eval 'cnt' + if nsz # Yes + ld Y ((Y CDR)) # Second arg + xchg E Y # 'cnt' in Y + eval # Eval 'var' + call needVarEX # Need variable + sym E # Symbol? + if nz # Yes + sym (E TAIL) # External symbol? + if nz # Yes + call dbTouchEX # Touch it + end + end + atom (E) # List value? + ldnz E (E) + if z # Yes + call consE_X # Cons first cell + ld C (E) # Get value + ld (X) (C) # CAR + ld (X CDR) Nil + link + push E # <L II> 'var' + push X # <L I> 'lst' + link + do + ld C (C CDR) # More elements? + atom C + while z # Yes + sub Y 1 # Count? + while nz # Yes + call cons_A # Copy next cell + ld (A) (C) + ld (A CDR) Nil + ld (X CDR) A # Append to result + ld X (X CDR) + loop + ld ((L II)) C # Set new value + ld E (L I) # Get result + drop + end + pop Y + pop X + ret + end + ld E Nil + pop Y + pop X + ret + +# (del 'any 'var) -> lst +(code 'doDel 2) + push X + push Y + push Z + ld X E + ld Y (E CDR) # Y on args + ld E (Y) # Eval first + eval + link + push E # <L II/III> 'any' + ld Y (Y CDR) + ld E (Y) # Eval second + eval+ + push E # <L I/II> 'var' + link + call needVarEX # Need variable + sym E # Symbol? + if nz # Yes + sym (E TAIL) # External symbol? + if nz # Yes + call dbTouchEX # Touch it + end + end + ld E ((L I)) # Get value of 'var' + atom E # List? + if z # Yes + ld Y E # Keep value in Y + ld E (Y) # First element + ld A (L II) # 'any' + call equalAE_F # Equal? + if eq # Yes + ld E (Y CDR) # Get value's CDR + ld ((L I)) E # Set 'var' + else + call cons_Z # Copy first cell + ld (Z) (Y) + ld (Z CDR) Nil + tuck Z # <L I> Save it + link + do + ld Y (Y CDR) # More cells? + atom Y + while z # Yes + ld E (Y) # Next element + ld A (L III) # 'any' + call equalAE_F # Equal? + if eq # Yes + ld (Z CDR) (Y CDR) # Skip found element + ld E (L I) # Result + ld ((L II)) E # Set 'var' + jmp 90 + end + call cons_A # Copy next cell + ld (A) (Y) + ld (A CDR) Nil + ld (Z CDR) A # Append to result + ld Z (Z CDR) + loop + ld E ((L II)) # Not found: Return old value of 'var' + end + end +90 drop + pop Z + pop Y + pop X + ret + +# (queue 'var 'any) -> any +(code 'doQueue 2) + push X + push Y + ld X E + ld Y (E CDR) # Y on args + ld E (Y) # Eval first + eval + call needVarEX # Need variable + sym E # Symbol? + if nz # Yes + sym (E TAIL) # External symbol? + if nz # Yes + call dbTouchEX # Touch it + end + end + link + push E # <L I> 'var' + link + ld Y (Y CDR) # Next arg + ld E (Y) + eval # Eval next arg + call consE_C # Build cell + ld (C) E + ld (C CDR) Nil + ld X (L I) # Get 'var' + ld Y (X) # Value + atom Y # Atomic? + if nz # Yes + ld (X) C # Store first cell + else + do + atom (Y CDR) # Find last cell + while z + ld Y (Y CDR) + loop + ld (Y CDR) C + end + drop + pop Y + pop X + ret + +# (fifo 'var ['any ..]) -> any +(code 'doFifo 2) + push X + push Y + ld X E + ld Y (E CDR) # Y on args + ld E (Y) # Eval first + eval + call needVarEX # Need variable + sym E # Symbol? + if nz # Yes + sym (E TAIL) # External symbol? + if nz # Yes + call dbTouchEX # Touch it + end + end + link + push E # <L I> 'var' + link + ld Y (Y CDR) # More args? + atom Y + if z # Yes + ld E (Y) # Eval 'any' + eval + call consE_A # Cons into new cell + ld (A) E + ld C (L I) # Get 'var' + ld X (C) # Value in X + atom X # List? + if z # Yes + ld (A CDR) (X CDR) # Concat to value + ld (X CDR) A + else + ld (A CDR) A # Circular cell + ld (C) X # Set new value + end + ld X A + do + ld Y (Y CDR) # More args? + atom Y + while z # Yes + ld E (Y) # Eval next 'any' + eval + call consE_A # Cons into new cell + ld (A) E + ld (A CDR) (X CDR) # Concat to value + ld (X CDR) A + ld X A + loop + ld ((L I)) X # Set new value + else + ld C (L I) # Get 'var' + ld X (C) # Value in X + atom X # Any? + if nz # No + ld E Nil + else + cmp X (X CDR) # Single cell? + if eq # Yes + ld E (X) # Return CAR + ld (C) Nil # Clear value + else + ld E ((X CDR)) # Return CADR + ld (X CDR) ((X CDR) CDR) # Cut cell + end + end + end + drop + pop Y + pop X + ret + +# (idx 'var 'any 'flg) -> lst +# (idx 'var 'any) -> lst +# (idx 'var) -> lst +(code 'doIdx 2) + push X + ld X E + ld E ((E CDR)) # Eval first arg + eval + call needVarEX # Need variable + ld X ((X CDR) CDR) # Second arg? + atom X + if nz # No + ld X (E) # Get tree + ld E Nil # Cons a list + call consTreeXE_E + else + push Y + link + push E # <L II> 'var' + ld E (X) + eval+ # Eval second arg + push E # <L I> 'any' + link # Save it + ld Y E # Keep in Y + ld X (X CDR) # Third arg? + atom X + if nz # No + ld X (L II) # Get 'var' + call idxGetXY_E # Find + else + ld E (X) # Eval last arg + eval + ld X (L II) # Get 'var' + cmp E Nil # Delete? + if ne # No + call idxPutXY_E # Insert + else + call idxDelXY_E # Delete + end + end + drop + pop Y + end + pop X + ret + +(code 'idxGetXY_E 0) + ld X (X) # Get value of 'var' + do + atom X # More nodes? + ld E Nil + while z # Yes + ld A Y # Get key + ld E (X) # Compare with node value + call compareAE_F # Found? + ld E X + while ne # No + ld X (X CDR) + ldc X (X) # Smaller + ldnc X (X CDR) # Greater + loop + ret + +(code 'idxPutXY_E 0) + atom (X) # First insert? + if nz # Yes + call cons_A # Cons new node + ld (A) Y # 'any' + ld (A CDR) Nil + ld (X) A # Set 'var' + ld E Nil # return NIL + else + ld X (X) # Get value of 'var' + do + ld A Y # Get key + ld E (X) # Compare with node value + call compareAE_F # Equal? + ld E X + while ne # No + ld A (X CDR) + if ge # Greater + atom A # Already has link? + if nz # No + call cons_A # Cons into a new node + ld (A) Y # key + ld (A CDR) Nil + call consA_C # Cons a new link + ld (C) Nil + ld (C CDR) A + ld (X CDR) C + ld E Nil # Return NIL + break T + end + ld X A + atom (X CDR) # CDR of link? + ldz X (X CDR) # Yes: Get CDR of link in X + if nz # No + call cons_A # Else cons into a new node + ld (A) Y # key + ld (A CDR) Nil + ld (X CDR) A # Store in CDR of link + ld E Nil # Return NIL + break T + end + else # Smaller + atom A # Already has link? + if nz # No + call cons_A # Cons into a new node + ld (A) Y # key + ld (A CDR) Nil + call consA_C # Cons a new link + ld (C) A + ld (C CDR) Nil + ld (X CDR) C + ld E Nil # Return NIL + break T + end + ld X A + atom (X) # CAR of link? + ldz X (X) # Yes: Get CAR of link in X + if nz # No + call cons_A # Else cons into a new node + ld (A) Y # key + ld (A CDR) Nil + ld (X) A # Store in CAR of link + ld E Nil # Return NIL + break T + end + end + loop + end + ret + +(code 'idxDelXY_E 0) + do + atom (X) # Next node? + ld E Nil + while z # Yes + ld A Y # Get key + ld E ((X)) # Compare with node value + call compareAE_F # Equal? + if eq # Yes + ld C (X) # Found subtree + ld E C # Preset return value + ld A (C CDR) # Get subtrees + atom (A) # Left branch? + if nz # No + ld (X) (A CDR) # Use right branch + ret + end + atom (A CDR) # Right branch? + if nz # No + ld (X) (A) # Use left branch + ret + end + ld A (A CDR) # A on right branch + ld X (A CDR) # X on sub-branches + atom (X) # Left? + if nz # No + ld (C) (A) # Insert right sub-branch + ld ((C CDR) CDR) (X CDR) + ret + end + push E # Save return value + ld X (X) # Left sub-branch + do + ld E (X CDR) # More left branches? + atom (E) + while z # Yes + ld A X # Go down left + ld X (E) + loop + ld (C) (X) # Insert left sub-branch + ld ((A CDR)) (E CDR) + pop E + ret + end + ld E Nil + ld X ((X) CDR) + if ge # Node value is greater + atom X # Link? + break nz # No + lea X (X CDR) # Go right + else # Node value is smaller + atom X # Link? + break nz # No + end + loop + ret + +# (lup 'lst 'any) -> lst +# (lup 'lst 'any 'any2) -> lst +(code 'doLup 2) + push X + ld X (E CDR) # Args + ld E (X) # Eval first + eval + atom E # List? + if z # Yes + link + push E # <L V> 'lst' + ld X (X CDR) # Eval second + ld E (X) + eval+ # 'any' + ld X (X CDR) # Next arg? + atom X + if nz # No + pop X # Get 'lst' in X + pop L # Discard partial stack frame + push Y + ld Y E # Get 'any' in Y + do + ld E (X) # CAR of 'lst' + cmp E TSym # Is it T? + if eq # Yes + ld X ((X CDR)) # Go to CADR + else + atom E # Atomic? + if nz # Yes + ld X ((X CDR) CDR) # Go to CDDR + else + ld A Y # Key 'any' + ld E (E) # CAAR of 'lst' + call compareAE_F # Equal? + if eq # Yes + ld E (X) # Return CAR of 'lst' + pop Y + pop X + ret + end + ld X (X CDR) + ldc X (X) # Smaller + ldnc X (X CDR) # Greater + end + end + atom X # Reached leaf? + until nz # Yes + ld E Nil # Return NIL + pop Y + else + push E # <L IV> "from" key + ld E (X) # Eval next + eval+ + push E # <L III> "to" key + push Nil # <L II> TOS + push Nil # <L I> Result + link + ld X (L V) # Get 'lst' in X + do + do + ld A (X CDR) + atom (A CDR) # Right subtree? + while z # Yes + ld E (X) # CAR of 'lst' + cmp E TSym # Is it T? + while ne # No + atom E # Atomic? + jnz 10 # Yes + ld A (L III) # "to" key + ld E (E) # CAAR of 'lst' + call compareAE_F # Greater or equal? + while ge # Yes +10 ld C X # Go right + ld A (X CDR) + ld X (A CDR) # Invert tree + ld (A CDR) (L II) # TOS + ld (L II) C + loop + ld (L V) X # Save tree + do + ld E (X) # CAR of 'lst' + atom E # Atomic? + if z # No + ld A (L IV) # "from" key + ld E (E) # CAAR of 'lst' + call compareAE_F # Less or equal? + if le # Yes + ld A (L III) # "to" key + ld E ((X)) # CAAR of 'lst' + call compareAE_F # Greater or equal? + if ge # Yes + call cons_A # Cons value + ld (A) (X) + ld (A CDR) (L I) # Into result + ld (L I) A + end + ld A (X CDR) # Left subtree? + atom (A) + if z # Yes + ld C X # Go left + ld X (A) # Invert tree + ld (A) (L II) # TOS + or C SYM # First visit + ld (L II) C + ld (L V) X # Save tree + break T + end + end + end + do + ld A (L II) # TOS + cmp A Nil # Empty? + if eq # Yes + ld E (L I) # Return result + drop + pop X + ret + end + sym A # Second visit? + if z # Yes + ld C (A CDR) # Nodes + ld (L II) (C CDR) # TOS on up link + ld (C CDR) X + ld X A + ld (L V) X # Save tree + break T + end + off A SYM # Set second visit + ld C (A CDR) # Nodes + ld (L II) (C) + ld (C) X + ld X A + ld (L V) X # Save tree + loop + loop + loop + end + end + pop X + ret + +### Property access ### +(code 'setAE 0) + ld (A) E # Set value + ret + +(code 'putACE 0) + zero C # Key is zero? + jeq setAE # Yes + push X + ld X (A TAIL) # Properties + num X # Any? + if z # Yes + off X SYM # Clear 'extern' tag + atom (X) # First property atomic? + if nz # Yes + cmp C (X) # Found flag? + if eq # Yes + cmp E Nil # Value NIL? + if eq # Yes +10 ld X (X CDR) # Remove property + sym (A TAIL) # Extern? + if nz # Yes + or X SYM # Set 'extern' tag + end + ld (A TAIL) X +20 pop X + ret + end + cmp E TSym # Value T? + jeq 20 # No change + push C + call consE_C # New property cell + ld (C) E + pop (C CDR) + ld (X) C + pop X + ret + end + else + cmp C ((X) CDR) # Found property? + if eq # Yes + cmp E Nil # Value NIL? + jeq 10 # Yes + cmp E TSym # Value T? + if ne # No + ld ((X)) E # Set new value + else + ld (X) C # Change to flag + end + pop X + ret + end + end + push Y + do + ld Y (X CDR) # Next property + atom Y # Any? + while z # Yes + atom (Y) # Atomic? + if nz # Yes + cmp C (Y) # Found flag? + if eq # Yes + cmp E Nil # Value NIL? + if eq # Yes + ld (X CDR) (Y CDR) # Remove cell + else + cmp E TSym # Value T? + if ne # No + push C + call consE_C # New property cell + ld (C) E + pop (C CDR) + ld (Y) C # Store + end + ld (X CDR) (Y CDR) # Unlink cell + ld X (A TAIL) # Get tail + sym X # Extern? + if z # No + ld (Y CDR) X # Insert cell in front + else + off X SYM # Clear 'extern' tag + ld (Y CDR) X # Insert cell in front + or Y SYM # Set 'extern' tag + end + ld (A TAIL) Y + pop Y + pop X + ret + end + end + else + cmp C ((Y) CDR) # Found property? + if eq # Yes + cmp E Nil # Value NIL? + if eq # Yes + ld (X CDR) (Y CDR) # Remove cell + else + cmp E TSym # Value T? + if ne # No + ld ((Y)) E # Set new value + else + ld (Y) C # Change to flag + end + ld (X CDR) (Y CDR) # Unlink cell + ld X (A TAIL) # Get tail + sym X # Extern? + if z # No + ld (Y CDR) X # Insert cell in front + else + off X SYM # Clear 'extern' tag + ld (Y CDR) X # Insert cell in front + or Y SYM # Set 'extern' tag + end + ld (A TAIL) Y + pop Y + pop X + ret + end + end + end + ld X Y + loop + pop Y + ld X (A TAIL) # Get properties again + end + cmp E Nil # Value Non-NIL? + if ne # Yes + cmp E TSym # Flag? + if ne # No + push C + call consE_C # New property cell + ld (C) E + pop (C CDR) + end + push C + call consC_C # New first property + pop (C) + sym X # Extern? + if z # No + ld (C CDR) X + else + off X SYM # Clear 'extern' tag + ld (C CDR) X + or C SYM # Set 'extern' tag + end + ld (A TAIL) C # Set new tail + end + pop X + ret + +(code 'getnECX_E 0) + num E # Need symbol or cell + jnz argErrEX + atom E # List? + if z # Yes + num C # Numeric key? + if nz # Yes + shr C 4 # Positive? + if nc # Yes + jz retNil # Return NIL if zero + do + sub C 1 # nth + jz retE_E + ld E (E CDR) + loop + end + # Key is negative + do + ld E (E CDR) + sub C 1 # nth + until z + ret + end + do # asoq + atom (E) # CAR atomic? + if z # No + cmp C ((E)) # Found? + break eq # Yes + end + ld E (E CDR) # Next + atom E # Done? + jnz retNil # Return NIL + loop + ld E ((E) CDR) # Return CDAR + ret + end + # E is symbolic + sym (E TAIL) # External symbol? + if nz # Yes + call dbFetchEX # Fetch it + end +(code 'getEC_E 0) + zero C # Key is zero? + jeq retE_E # Get value + ld A (E TAIL) # Get tail + num A # No properties? + jnz retNil # Return NIL + off A SYM # Clear 'extern' tag + atom (A) # First property atomic? + if nz # Yes + cmp C (A) # Found flag? + jeq retT # Return T + else + cmp C ((A) CDR) # Found property? + if eq # Yes + ld E ((A)) # Return value + ret + end + end + push X + do + ld X (A CDR) # Next property + atom X # Any? + while z # Yes + atom (X) # Atomic? + if nz # Yes + cmp C (X) # Found flag? + if eq # Yes + ld (A CDR) (X CDR) # Unlink cell + ld A (E TAIL) # Get tail + sym A # Extern? + if z # No + ld (X CDR) A # Insert cell in front + else + off A SYM # Clear 'extern' tag + ld (X CDR) A # Insert cell in front + or X SYM # Set 'extern' tag + end + ld (E TAIL) X + ld E TSym # Return T + pop X + ret + end + else + cmp C ((X) CDR) # Found property? + if eq # Yes + ld (A CDR) (X CDR) # Unlink cell + ld A (E TAIL) # Get tail + sym A # Extern? + if z # No + ld (X CDR) A # Insert cell in front + ld (E TAIL) X + ld E ((X)) # Return value + else + off A SYM # Clear 'extern' tag + ld (X CDR) A # Insert cell in front + ld A ((X)) # Return value + or X SYM # Set 'extern' tag + ld (E TAIL) X + ld E A + end + pop X + ret + end + end + ld A X + loop + ld E Nil # Return NIL + pop X + ret + +(code 'propEC_E 0) + ld A (E TAIL) # Get tail + num A # No properties? + jnz retNil # Return NIL + off A SYM # Clear 'extern' tag + atom (A) # First property atomic? + if nz # Yes + cmp C (A) # Found flag? + if eq # Yes + ld E C # Return key + ret + end + else + cmp C ((A) CDR) # Found property? + if eq # Yes + ld E (A) # Return property + ret + end + end + push X + do + ld X (A CDR) # Next property + atom X # Any? + while z # Yes + atom (X) # Atomic? + if nz # Yes + cmp C (X) # Found flag? + if eq # Yes + ld (A CDR) (X CDR) # Unlink cell + ld A (E TAIL) # Get tail + sym A # Extern? + if z # No + ld (X CDR) A # Insert cell in front + else + off A SYM # Clear 'extern' tag + ld (X CDR) A # Insert cell in front + or X SYM # Set 'extern' tag + end + ld (E TAIL) X + ld E C # Return key + pop X + ret + end + else + cmp C ((X) CDR) # Found property? + if eq # Yes + ld (A CDR) (X CDR) # Unlink cell + ld A (E TAIL) # Get tail + sym A # Extern? + if z # No + ld (X CDR) A # Insert cell in front + ld (E TAIL) X + ld E (X) # Return property + else + off A SYM # Clear 'extern' tag + ld (X CDR) A # Insert cell in front + ld A (X) # Return property + or X SYM # Set 'extern' tag + ld (E TAIL) X + ld E A + end + pop X + ret + end + end + ld A X + loop + ld E Nil # Return NIL + pop X + ret + +# (put 'sym1|lst ['sym2|cnt ..] 'sym|0 'any) -> any +(code 'doPut 2) + push X + push Y + ld X E + ld Y (E CDR) # Y on args + ld E (Y) # Eval first + eval + link + push E # <L II> 'sym1|lst' item + ld Y (Y CDR) + ld E (Y) # Eval second + eval+ + push E # <L I> 'sym2|cnt' key + link + do + ld Y (Y CDR) # Args + atom (Y CDR) # More than one? + while z # Yes + ld C E # Key + ld E (L II) # Current item + call getnECX_E + ld (L II) E # Store item + ld E (Y) + eval # Eval next arg + ld (L I) E # Save it + loop + ld E (L II) # Get item + num E # Need symbol + jnz symErrEX + sym E + jz symErrEX + cmp E Nil # Can't be NIL + jeq protErrEX + ld E (Y) # Eval 'any' + eval + ld A (L II) # Get symbol + sym (A TAIL) # External symbol? + if nz # Yes + push E # Save 'any' + ld E A # Get symbol + call dbTouchEX # Touch it + ld A E + pop E + end + ld C (L I) # Get key + call putACE # Put value or propery + drop + pop Y + pop X + ret + +# (get 'sym1|lst ['sym2|cnt ..]) -> any +(code 'doGet 2) + push X + push Y + ld X E + ld Y (E CDR) # Y on args + ld E (Y) # Eval first + eval + ld Y (Y CDR) # Next arg? + atom Y + if z # Yes + link + push E # <L I> 'sym|lst' item + link + do + ld E (Y) + eval # Eval next arg + ld C E # Key + ld E (L I) # Current item + call getnECX_E + ld Y (Y CDR) # More args? + atom Y + while z # Yes + ld (L I) E # Save item + loop + drop + end + pop Y + pop X + ret + +# (prop 'sym1|lst ['sym2|cnt ..] 'sym) -> lst|sym +(code 'doProp 2) + push X + push Y + ld X E + ld Y (E CDR) # Y on args + ld E (Y) # Eval first + eval + link + push E # <L II> 'sym|lst' item + ld Y (Y CDR) # Next arg + ld E (Y) + eval+ # Eval next arg + push E # <L I> 'sym2|cnt' key + link + do + ld Y (Y CDR) # More args? + atom Y + while z # Yes + ld C E # Key + ld E (L II) # Current item + call getnECX_E + ld (L II) E # Store item + ld E (Y) + eval # Eval next arg + ld (L I) E # Save it + loop + ld E (L II) # Get item + num E # Need symbol + jnz symErrEX + sym E + jz symErrEX + sym (E TAIL) # External symbol? + if nz # Yes + call dbFetchEX # Fetch it + end + ld C (L I) # Get key + call propEC_E + drop + pop Y + pop X + ret + +# (; 'sym1|lst [sym2|cnt ..]) -> any +(code 'doSemicol 2) + push X + push Y + ld X E + ld Y (E CDR) # Y on args + ld E (Y) # Eval first + eval + ld Y (Y CDR) # Next arg? + atom Y + if z # Yes + link + push E # <L I> 'sym|lst' item + link + do + ld C (Y) # Key + ld E (L I) # Current item + call getnECX_E + ld Y (Y CDR) # More args? + atom Y + while z # Yes + ld (L I) E # Save item + loop + drop + end + pop Y + pop X + ret + +# (=: sym|0 [sym1|cnt .. sym2|0] 'any) -> any +(code 'doSetCol 2) + push X + push Y + ld X E + ld Y (E CDR) # Y on args + ld E (This) # Get value of This + sym (E TAIL) # External symbol? + if nz # Yes + call dbFetchEX # Fetch it + end + ld C (Y) # sym1|cnt + ld Y (Y CDR) # Args + atom (Y CDR) # More than one? + if z # Yes + call getEC_E + do + ld C (Y) # sym2|cnt + ld Y (Y CDR) # Args + atom (Y CDR) # More than one? + while z # Yes + call getnECX_E + loop + end + num E # Need symbol + jnz symErrEX + sym E + jz symErrEX + cmp E Nil # Can't be NIL + jeq protErrEX + sym (E TAIL) # External symbol? + if nz # Yes + call dbTouchEX # Touch it + end + push C # Save key + push E # Save symbol + ld E (Y) # Eval 'any' + eval + pop A # Retrieve symbol + pop C # and key + call putACE # Put value or propery + pop Y + pop X + ret + +# (: sym|0 [sym1|cnt ..]) -> any +(code 'doCol 2) + push X + push Y + ld X E + ld Y (E CDR) # Y on args + ld E (This) # Get value of This + sym (E TAIL) # External symbol? + if nz # Yes + call dbFetchEX # Fetch it + end + ld C (Y) # Next key + call getEC_E + do + ld Y (Y CDR) # More args? + atom Y + while z # Yes + ld C (Y) # Next key + call getnECX_E + loop + pop Y + pop X + ret + +# (:: sym|0 [sym1|cnt .. sym2]) -> lst|sym +(code 'doPropCol 2) + push X + push Y + ld X E + ld Y (E CDR) # Y on args + ld E (This) # Get value of This + sym (E TAIL) # External symbol? + if nz # Yes + call dbFetchEX # Fetch it + end + ld C (Y) # Next key + atom (Y CDR) # More than one arg? + if z # Yes + call getEC_E + do + ld Y (Y CDR) + ld C (Y) # Next key + atom (Y CDR) # More than one arg? + while z # Yes + call getnECX_E + loop + end + call propEC_E + pop Y + pop X + ret + +# (putl 'sym1|lst1 ['sym2|cnt ..] 'lst) -> lst +(code 'doPutl 2) + push X + push Y + ld X E + ld Y (E CDR) # Y on args + ld E (Y) # Eval first + eval + link + push E # <L II> 'sym|lst' item + ld Y (Y CDR) # Next arg + ld E (Y) + eval+ # Eval next arg + push E # <L I> 'sym2|cnt' key + link + do + ld Y (Y CDR) # More args? + atom Y + while z # Yes + ld C E # Key + ld E (L II) # Current item + call getnECX_E + ld (L II) E # Store item + ld E (Y) + eval # Eval next arg + ld (L I) E # Save it + loop + ld E (L II) # Get item + num E # Need symbol + jnz symErrEX + sym E + jz symErrEX + cmp E Nil # Can't be NIL + jeq protErrEX + sym (E TAIL) # External symbol? + if nz # Yes + call dbTouchEX # Touch it + end + ld X (E TAIL) # Skip old properties + off X SYM # Clear 'extern' tag + do + num X # More properties? + while z # Yes + ld X (X CDR) + loop + ld Y (L I) # New property list + do + atom Y # Any? + while z # Yes + ld C (Y) + atom C # Flag? + if nz # Yes + ld A X + call consA_X # New property cell + ld (X) C + ld (X CDR) A + else + cmp (C) Nil # Value Nil? + if ne # No + cmp (C) TSym # Flag? + if eq # Yes + ld C (C CDR) # Get key + end + ld A X + call consA_X # New property cell + ld (X) C + ld (X CDR) A + end + end + ld Y (Y CDR) + loop + sym (E TAIL) # Extern? + if nz # Yes + or X SYM # Set 'extern' tag + end + ld (E TAIL) X + ld E (L I) # Return new property list + drop + pop Y + pop X + ret + +# (getl 'sym1|lst1 ['sym2|cnt ..]) -> lst +(code 'doGetl 2) + push X + push Y + ld X E + ld Y (E CDR) # Y on args + ld E (Y) # Eval first + eval + link + push E # <L I> 'sym|lst' item + link + do + ld Y (Y CDR) # More args? + atom Y + while z + ld E (Y) + eval # Eval next arg + ld C E # Key + ld E (L I) # Current item + call getnECX_E + ld (L I) E # Save item + loop + num E # Need symbol + jnz symErrEX + sym E + jz symErrEX + sym (E TAIL) # External symbol? + if nz # Yes + call dbFetchEX # Fetch it + end + ld X (E TAIL) # Get tail + num X # No properties? + if nz # Yes + ld E Nil + else + off X SYM # Clear 'extern' tag + call cons_C # Copy first cell + ld (C) (X) + ld (C CDR) Nil + tuck C # Save it + link + do + ld X (X CDR) # More properties? + atom X + while z # Yes + call cons_A # Copy next cell + ld (A) (X) + ld (A CDR) Nil + ld (C CDR) A # Append + ld C A + loop + ld E (L I) # Get result + end + drop + pop Y + pop X + ret + +# (wipe 'sym|lst) -> sym +(code 'doWipe 2) + ld E ((E CDR)) # Get arg + eval # Eval it + cmp E Nil # NIL? + if ne # No + atom E # List? + if nz # No + call wipeE # Wipe it + else + push E # Save + ld C E # Get list + do + ld E (C) # Next symbol + call wipeE # Wipe it + ld C (C CDR) + atom C # More? + until nz # No + pop E + end + end + ret + +(code 'wipeE 0) + ld A (E TAIL) # Get tail + sym A # Extern? + if z # No + call nameA_A # Get name + ld (E) Nil # Clear value + ld (E TAIL) A # And properties + ret + end + call nameA_A # Get name + shl A 1 # Dirty? + if nc # No + shl A 1 # Loaded? + if c # Yes + clrc # Set "not loaded" + rcr A 1 + rcr A 1 + ld (E) Nil # Clear value + or A SYM # Set 'extern' tag + ld (E TAIL) A + end + end + ret + +# (meta 'obj|typ 'sym ['sym2|cnt ..]) -> any +(code 'doMeta 2) + push X + push Y + ld X E + ld Y (E CDR) # Y on args + ld E (Y) # Eval first + eval + link + push E # <L I> 'obj|typ' + link + num E # Need symbol or cell + jnz argErrEX + sym E # Symbol? + if nz # Yes + sym (E TAIL) # External symbol? + if nz # Yes + call dbFetchEX # Fetch it + end + ld (L I) (E) # Get value + end + ld Y (Y CDR) # Next arg + ld E (Y) + eval # Eval next arg + ld C E # Key + ld X (L I) # 'obj|typ' + call metaCX_E # Fetch + do + ld Y (Y CDR) # More args? + atom Y + while z # Yes + ld (L I) E # Save item + ld E (Y) + eval # Eval next arg + ld C E # Key + ld E (L I) # Current item + call getnECX_E + loop + drop + pop Y + pop X + ret + +(code 'metaCX_E 0) + do + atom X # List? + jnz retNil # No + ld E (X) # Next item + num E # Symbol? + if z + sym E + if nz # Yes + call getEC_E # Propery + cmp E Nil # found? + jne Ret # No + push X + ld X ((X)) # Try in superclass(es) + call metaCX_E + pop X + cmp E Nil # found? + jne Ret # No + end + end + ld X (X CDR) + loop + +### Case mappings from the GNU Kaffe Project ### +(code 'caseDataA_AC 0) + ld C A # Keep character in C + shr A 4 # Make index + off A 1 + ld2 (A CaseBlocks) # Get blocks entry + add A C # Add character + and A (hex "FFFF") # Limit to 16 bits + shl A 1 # Adjust index + ld2 (A CaseData) # Get case data + ret + +# (low? 'any) -> sym | NIL +(code 'doLowQ 2) + ld E ((E CDR)) # Get arg + eval # Eval it + num E # Number? + jnz retNil # Yes + sym E # Symbol? + jz retNil # No + call firstCharE_A # Get first character + call caseDataA_AC # Get case info + and B (hex "1F") # Character type + cmp B CHAR_LOWERCASE # Lower case? + ldnz E Nil # No + ret + +# (upp? 'any) -> sym | NIL +(code 'doUppQ 2) + ld E ((E CDR)) # Get arg + eval # Eval it + num E # Number? + jnz retNil # Yes + sym E # Symbol? + jz retNil # No + call firstCharE_A # Get first character + call caseDataA_AC # Get case info + and B (hex "1F") # Character type + cmp B CHAR_UPPERCASE # Lower case? + ldnz E Nil # No + ret + +# (lowc 'any) -> any +(code 'doLowc 2) + push X + ld E ((E CDR)) # Get arg + eval # Eval it + num E # Number? + if z # No + sym E # Symbol? + if nz # Yes + cmp E Nil # NIL? + if ne # No + ld E (E TAIL) + call nameE_E # Get name + link + push E # <L II> Name + push ZERO # <L I> Result + ld X S + link + push 4 # <S I> Build name + push X # <S> Pack status + ld X (L II) # Get name + ld C 0 # Index + do + call symCharCX_FACX # Next char? + while nz + ld E C # Save C + call caseDataA_AC # Get case info + and A (hex "FFFF") + shr A 6 # Make index + off A 1 + ld2 (A CaseLower) # Get lower case entry + add A C # plus character + and A (hex "FFFF") + ld C (S I) # Swap status + xchg X (S) + call charSymACX_CX # Pack char + xchg X (S) # Swap status + ld (S I) C + ld C E # Restore C + loop + ld X (L I) # Get result + call consSymX_E # Make transient symbol + drop + end + end + end + pop X + ret + +# (uppc 'any) -> any +(code 'doUppc 2) + push X + ld E ((E CDR)) # Get arg + eval # Eval it + num E # Number? + if z # No + sym E # Symbol? + if nz # Yes + cmp E Nil # NIL? + if ne # No + ld E (E TAIL) + call nameE_E # Get name + link + push E # <L II> Name + push ZERO # <L I> Result + ld X S + link + push 4 # <S I> Build name + push X # <S> Pack status + ld X (L II) # Get name + ld C 0 # Index + do + call symCharCX_FACX # Next char? + while nz + ld E C # Save C + call caseDataA_AC # Get case info + and A (hex "FFFF") + shr A 6 # Make index + off A 1 + ld2 (A CaseUpper) # Get upper case entry + add A C # plus character + and A (hex "FFFF") + ld C (S I) # Swap status + xchg X (S) + call charSymACX_CX # Pack char + xchg X (S) # Swap status + ld (S I) C + ld C E # Restore C + loop + ld X (L I) # Get result + call consSymX_E # Make transient symbol + drop + end + end + end + pop X + ret + +# (fold 'any ['cnt]) -> sym +(code 'doFold 2) + push X + push Y + ld X E + ld Y (E CDR) # Y on args + ld E (Y) # Eval first + eval + num E # Number? + if z # No + sym E # Symbol? + if nz # Yes + cmp E Nil # NIL? + if ne + ld E (E TAIL) + call nameE_E # Get name + link + push E # <L II> Name + push ZERO # <L I> Result + link + ld Y (Y CDR) # Next arg? + atom Y + if nz # No + push 24 # <S II> Default 'cnt' 24 + else + call evCntXY_FE # Eval 'cnt' + push E # <S II> 'cnt' + end + push 4 # <S I> Build name + lea X (L I) + push X # <S> Pack status + ld X (L II) # Get name + ld C 0 # Index + do + call symCharCX_FACX # Next char? + while nz + ld E C # Save C + call isLetterOrDigitA_F # Letter or digit? + if nz # Yes + sub (S II) 1 # Decrement 'cnt' + break s + call caseDataA_AC # Get case info + and A (hex "FFFF") + shr A 6 # Make index + off A 1 + ld2 (A CaseLower) # Get lower case entry + add A C # plus character + and A (hex "FFFF") + ld C (S I) # Swap status + xchg X (S) + call charSymACX_CX # Pack char + xchg X (S) # Swap status + ld (S I) C + end + ld C E # Restore C + loop + ld X (L I) # Get result + call consSymX_E # Make transient symbol + drop + end + end + end + pop Y + pop X + ret + +(code 'isLetterOrDigitA_F 0) # C + push A + call caseDataA_AC # Get case info + and B (hex "1F") # Character type + ld C 1 + zxt + shl C A + test C (| CHAR_DIGIT CHAR_LETTER) + pop A + ret + +# vi:et:ts=3:sw=3 diff --git a/src64/sys/linux.code.l b/src64/sys/linux.code.l @@ -0,0 +1,39 @@ +# 02oct09abu +# (c) Software Lab. Alexander Burger + +# System macros +(code 'errno_A 0) + call __errno_location # Get address of 'errno' + ld A (A) # Load value + ret + +(code 'errnoC 0) + call __errno_location # Get address of 'errno' + ld (A) C # Store new value + ret + +(code 's_isdirS_F 0) # S_ISDIR + ld4 (S `(+ I ST_MODE)) # Get 'st_mode' from 'stat' + and A `S_IFMT + cmp A `S_IFDIR + ret + +(code 'wifstoppedS_F 0) # WIFSTOPPED + ld A (S I) # Get status + cmp B `(hex "7F") # (((status) & 0xff) == 0x7f) + ret + +(code 'wifsignaledS_F 0) # WIFSIGNALED + ld A (S I) # Get status + and B `(hex "7F") # (((status) & 0x7f) + 1) >> 1) > 0) + add B 1 + shr B 1 + ret + +(code 'wtermsigS_A 0) # WTERMSIG + ld A (S I) # Get status + and B `(hex "7F") # ((status) & 0x7f) + zxt + ret + +# vi:et:ts=3:sw=3 diff --git a/src64/sys/linux.defs.l b/src64/sys/linux.defs.l @@ -0,0 +1,145 @@ +# 09sep09abu +# (c) Software Lab. Alexander Burger + +# errno +(equ ENOENT 2) # No such file or directory +(equ EINTR 4) # Interrupted system call +(equ EBADF 9) # Bad file number +(equ EAGAIN 11) # Try again +(equ EACCES 13) # Permission denied +(equ EPIPE 32) # Broken pipe +(equ ECONNRESET 104) # Connection reset by peer + +# open/fcntl +(equ O_RDONLY 0) +(equ O_WRONLY 1) +(equ O_RDWR 2) +(equ O_CREAT 64) +(equ O_EXCL 128) +(equ O_TRUNC 512) +(equ O_APPEND 1024) +(equ F_GETFD 1) +(equ F_SETFD 2) +(equ FD_CLOEXEC 1) + +# stdio +(equ BUFSIZ 8192) +(equ PIPE_BUF 4096) + +# dlfcn +(equ RTLD_LAZY 1) +(equ RTLD_GLOBAL 256) + +# fcntl +(equ FLOCK 32) # File lock structure +(equ L_TYPE 0) # 2 +(equ L_WHENCE 2) # 2 +(equ L_START 8) +(equ L_LEN 16) +(equ L_PID 24) +(equ SEEK_SET 0) +(equ SEEK_CUR 1) +(equ F_RDLCK 0) +(equ F_WRLCK 1) +(equ F_UNLCK 2) +(equ F_GETFL 3) +(equ F_SETFL 4) +(equ F_GETLK 5) +(equ F_SETLK 6) +(equ F_SETLKW 7) +(equ O_NONBLOCK 2048) + +# stat +(equ STAT 144) # File status structure +(equ ST_MODE 24) # 4 +(equ ST_SIZE 48) +(equ ST_MTIME 88) +(equ S_IFMT (hex "F000")) +(equ S_IFDIR (hex "4000")) + +# times +(equ TMS 32) # 'times' structure +(equ TMS_UTIME 0) +(equ TMS_STIME 8) + +# termios +(equ TERMIOS (+ 60 4)) # Terminal I/O structure (+ Padding) +(equ C_IFLAG 0) +(equ C_LFLAG 12) +(equ C_CC 17) +(equ ISIG 1) +(equ VMIN 6) +(equ VTIME 5) +(equ TCSADRAIN 1) + +# signal +(equ SIGACTION 152) # Sigaction structure +(equ SIGSET_T 128) +(equ SA_HANDLER 0) +(equ SA_MASK 8) +(equ SA_FLAGS 136) + +(equ SIG_DFL 0) +(equ SIG_IGN 1) +(equ SIG_UNBLOCK 1) + +(equ SIGHUP 1) # Signals +(equ SIGINT 2) +(equ SIGUSR1 10) +(equ SIGUSR2 12) +(equ SIGPIPE 13) +(equ SIGALRM 14) +(equ SIGTERM 15) +(equ SIGCHLD 17) +(equ SIGCONT 18) +(equ SIGSTOP 19) +(equ SIGTSTP 20) +(equ SIGTTIN 21) +(equ SIGTTOU 22) + +# wait +(equ WNOHANG 1) +(equ WUNTRACED 2) + +# poll +(equ POLLFD 8) +(equ POLL_EVENTS 4) # 2 +(equ POLL_REVENTS 6) # 2 +(equ POLLIN 1) +(equ POLLOUT 4) +(equ POLLHUP 16) +(equ POLLNVAL 32) + +# time +(equ TM_SEC 0) +(equ TM_MIN 4) +(equ TM_HOUR 8) +(equ TM_MDAY 12) +(equ TM_MON 16) +(equ TM_YEAR 20) + +# dir +(equ D_NAME 19) + +# Sockets +(equ HOSTENT 32) +(equ H_NAME 0) +(equ H_LENGTH 20) +(equ H_ADDR_LIST 24) + +(equ IN_ADDR 4) +(equ S_ADDR 0) + +(equ SOCKADDR_IN 16) +(equ SIN_ADDR 4) +(equ SIN_ADDR.S_ADDR 4) +(equ SIN_PORT 2) +(equ SIN_FAMILY 0) +(equ AF_INET 2) +(equ SOCK_STREAM 1) +(equ SOCK_DGRAM 2) +(equ INADDR_ANY 0) +(equ SOL_SOCKET 1) +(equ SO_REUSEADDR 2) + +# vi:et:ts=3:sw=3 diff --git a/src64/version.l b/src64/version.l @@ -0,0 +1,6 @@ +# 22apr10abu +# (c) Software Lab. Alexander Burger + +(de *Version 3 0 2 13) + +# vi:et:ts=3:sw=3 diff --git a/test/lib.l b/test/lib.l @@ -0,0 +1,201 @@ +# 18mar10abu +# (c) Software Lab. Alexander Burger + +### task ### +(test (3 . 4) + (let (*Run NIL *A NIL *B NIL) + (task -10 0 (setq *A 3)) + (task (port T 4444) (eval (udp @))) + (udp "localhost" 4444 '(setq *B 4)) + (wait NIL (and *A *B)) + (cons *A *B) ) ) + + +### timeout ### +(test '((-1 3600000 (bye))) + (let *Run NIL + (timeout 3600000) + *Run ) ) + + +### abort ### +(test 6 (abort 2 (+ 1 2 3))) +(test NIL (abort 2 (wait 4000))) + + +### macro ### +(test 6 + (let (@A 1 @B 2 @C 3) + (macro (* @A @B @C)) ) ) + + +### later ### +(test '((@ . 1) (@ . 4) (@ . 9) (@ . 16) (@ . 25) (@ . 36)) + (prog1 + (mapcan + '((N) (later (cons) (cons *Pid (* N N)))) + (1 2 3 4 5 6) ) + (wait NIL (full @)) ) ) + + +### recur recurse ### +(test 720 + (let N 6 + (recur (N) + (if (=0 N) + 1 + (* N (recurse (dec N))) ) ) ) ) + + +### curry ### +(test '((N) (* 7 N)) + ((quote (@X) (curry (@X) (N) (* @X N))) 7) ) +(test 21 + (((quote (@X) (curry (@X) (N) (* @X N))) 7) 3) ) +(test '((N) (job '((A . 1)) (+ A 7 N))) + (let (A 1 @X 7) (curry (A @X) (N) (+ A @X N))) ) + + +### getd ### +(test car (getd 'car)) +(test '((File . @) (load File)) + (getd 'script) ) +(test NIL (getd 1)) + + +### expr subr undef ### +(let foo car + (test 7 (foo (7))) + (test T (== 'pass (caadr (expr 'foo)))) + (test car (subr 'foo)) + (test car (undef 'foo)) + (test NIL (val 'foo)) ) + + +### redef ### +(let foo inc + (redef foo (N) (inc (foo N))) + (test 3 (foo 1)) ) + + +### daemon patch ### +(let foo car + (daemon 'foo (msg 'daemon)) + (test T (= '(msg 'daemon) (cadr (getd 'foo)))) + (patch foo 'daemon 'patch) + (test T (= '(msg 'patch) (cadr (getd 'foo)))) ) + + +### scl ### +(scl 0) +(test 123 (any "123.45"))) +(scl 1) +(test 1235 (any "123.45"))) +(scl 3) +(test 123450 (any "123.45"))) + + +### script ### +(out (tmp "script") + (println '(pass * 7)) ) +(test 42 (script (tmp "script") 2 3)) + + +### once ### +(let N 0 + (test 1 + (once (inc 'N)) + (once (inc 'N)) + N ) ) + + +### rc ### +(let F (tmp "rc") + (rc F 'a 123) + (rc F 'b "test") + (rc F 'c (1 2 3)) + (test '((c 1 2 3) (b . "test") (a . 123)) + (in F (read)) ) + (test 123 (rc F 'a)) + (test "test" (rc F 'b)) + (test (1 2 3) (rc F 'c)) ) + + +### acquire release ### +(let F (tmp "sema") + (test *Pid (acquire F)) + (test T (acquire F)) + (test *Pid (in F (rd))) + (test NIL (release F)) + (test NIL (in F (rd))) ) + + +### insert ### +(test '(a b 777 c d e) (insert 3 '(a b c d e) 777)) +(test (777 a b c d e) (insert 1 '(a b c d e) 777)) +(test '(a b c d e 777) (insert 9 '(a b c d e) 777)) + + +### remove ### +(test '(a b d e) (remove 3 '(a b c d e))) +(test '(b c d e) (remove 1 '(a b c d e))) +(test '(a b c d e) (remove 9 '(a b c d e))) + + +### place ### +(test '(a b 777 d e) (place 3 '(a b c d e) 777)) +(test (777 b c d e) (place 1 '(a b c d e) 777)) +(test '(a b c d e 777) (place 9 '(a b c d e) 777)) + + +### uniq ### +(test (2 4 6 1 3 5) (uniq (2 4 6 1 2 3 4 5 6 1 3 5))) + + +### group ### +(test '((1 a b c) (2 d e f)) + (group '((1 . a) (1 . b) (1 . c) (2 . d) (2 . e) (2 . f))) ) + + +### qsym ### +(let "A" 1234 + (put '"A" 'a 1) + (put '"A" 'b 2) + (put '"A" 'f T) + (test (1234 f (2 . b) (1 . a)) + (qsym . "A") ) ) + +### loc ### +(let (X 'foo bar '((A B) (foo B A))) + (test "foo" (zap 'foo)) + (test "foo" (str? "foo")) + (test T (== X (loc "foo" bar))) ) + + +### class ### +(off "+A" "+B" "+C") +(test '"+A" (class "+A" "+B" "+C")) +(test '"+A" *Class) +(test '("+B" "+C") "+A") + + +### object ### +(off "Obj") +(test '"Obj" + (object '"Obj" '("+A" "+B" "+C") 'a 1 'b 2 'c 3) ) +(test '((3 . c) (2 . b) (1 . a)) (getl '"Obj")) + + +### extend var var: ### +(test '"+B" (extend "+B")) +(test T (== *Class '"+B")) + +(test 1 (var a . 1)) +(test 2 (var b . 2)) +(test '((2 . b) (1 . a)) (getl '"+B")) + +(with '"Obj" + (test 1 (var: a)) + (test 2 (var: b)) ) + +# vi:et:ts=3:sw=3 diff --git a/test/lib/lint.l b/test/lib/lint.l @@ -0,0 +1,21 @@ +# 26mar09abu +# (c) Software Lab. Alexander Burger + +### noLint ### +(let foo '(() (bar FreeVariable)) + (use *NoLint + (noLint 'bar) + (noLint 'foo 'FreeVariable) + (test NIL (lint 'foo)) ) ) + + +### lint ### +(let foo '((R S T R) (let N 7 (bar X Y))) + (test '((var T) (dup R) (def bar) (bnd Y X) (use N)) + (lint 'foo) ) ) + +(let foo '(() (task -6000 0 X 7 (println N))) + (test '((bnd N) (use X)) + (lint 'foo) ) ) + +# vi:et:ts=3:sw=3 diff --git a/test/lib/misc.l b/test/lib/misc.l @@ -0,0 +1,213 @@ +# 04sep08abu +# (c) Software Lab. Alexander Burger + +### locale ### +(locale "DE" "de") +(test "Ja" (val ,"Yes")) +(locale) + + +### ** ### +(test 32768 (** 2 15)) + + +### accu ### +(off Sum) + +(test '(a . 1) (accu 'Sum 'a 1)) +(test 6 (accu 'Sum 'a 5)) +(test (22 . 100) (accu 'Sum 22 100)) +(test '((22 . 100) (a . 6)) Sum) + +(test '((b . 2) (a . 3)) + (let L NIL (accu 'L 'a 2) (accu 'L 'b 2) (accu 'L 'a 1) L) ) + + +### align ### +(test " a" (align 4 'a)) +(test " a" (align 4 "a")) +(test "12 " (align -4 12)) +(test " a 12 b" (align (4 4 4) "a" 12 "b")) + + +### center ### +(test " 12" (center 4 12)) +(test " a" (center 4 "a")) +(test " a" (center 7 'a)) +(test " a b c" (center (3 3 3) "a" "b" "c")) + + +### wrap ### +(test "The quick brown fox^Jjumps over the lazy^Jdog" + (wrap 20 (chop "The quick brown fox jumps over the lazy dog")) ) +(test "The^Jquick^Jbrown^Jfox^Jjumps^Jover the^Jlazy dog" + (wrap 8 (chop "The quick brown fox jumps over the lazy dog")) ) + + +### pad ### +(test "00001" (pad 5 1)) +(test "123456789" (pad 5 123456789)) + + +### oct ### +(test "111" (oct (+ 64 8 1))) +(test (+ 64 8 1) (oct "111")) + + +### hex ### +(test "111" (hex (+ 256 16 1))) +(test (+ 256 16 1) (hex "111")) +(test "-FFFF" (hex -65535)) + + +### money ### +(test "1,234,567.89" (money 123456789)) +(test "1,234,567.89 EUR" (money 123456789 "EUR")) + +(locale "DE" "de") +(test "1.234.567,89 EUR" (money 123456789 "EUR")) +(locale) + + +### balance ### +(test (5 (2 (1) 3 NIL 4) 7 (6) 8 NIL 9) + (let I NIL (balance 'I (sort (1 4 2 5 3 6 7 9 8))) I) ) + + +### *Allow allowed allow ### +(allowed ("app/" "img/") + "start" "stop" "favicon.ico" "lib.css" "psh" ) +(allow "myFoo") +(allow "myDir/" T) + +(test '(("psh" ("favicon.ico" NIL "lib.css" NIL "myFoo") "start" NIL "stop") "app/" "img/" "myDir/") + *Allow ) + +(test '("favicon.ico" "lib.css" "myFoo" "psh" "start" "stop") + (idx *Allow) ) + +(test '("app/" "img/" "myDir/") + (cdr *Allow) ) + + +### telStr ### +(test "+49 1234 5678-0" (telStr "49 1234 5678-0")) + +(locale "DE" "de") +(test "01234 5678-0" (telStr "49 1234 5678-0")) +(locale) + + +### expTel ### +(test "49 1234 5678-0" (expTel "+49 1234 5678-0")) +(test "49 1234 5678-0" (expTel "0049 1234 5678-0")) +(test NIL (expTel "01234 5678-0")) + +(locale "DE" "de") +(test "49 1234 5678-0" (expTel "01234 5678-0")) +(locale) + + +### dat$ ### +(test "20070601" (dat$ (date 2007 6 1))) +(test "2007-06-01" (dat$ (date 2007 6 1) "-")) + + +### $dat ### +(test 733134 ($dat "20070601")) +(test 733134 ($dat "2007-06-01" "-")) + + +### datSym ### +(test "01jun07" (datSym (date 2007 6 1))) + + +### datStr ### +(test "2007-06-01" (datStr (date 2007 6 1))) + +(locale "DE" "de") +(test "01.06.2007" (datStr (date 2007 6 1))) +(test "01.06.07" (datStr (date 2007 6 1) T)) +(locale) + + +### strDat ### +(test 733134 (strDat "2007-06-01")) +(test NIL (strDat "01.06.2007")) + +(locale "DE" "de") +(test 733134 (strDat "01.06.2007")) +(test 733134 (strDat "1.6.2007")) +(locale) + + +### expDat ### +(test 733133 (date 2007 5 31)) +(test 733133 (expDat "31057")) +(test 733133 (expDat "310507")) +(test 733133 (expDat "2007-05-31")) +(test 733133 (expDat "7-5-31")) + +(locale "DE" "de") +(test 733133 (expDat "31.5.7")) +(locale) + + +### day ### +(test "Friday" (day (date 2007 6 1))) + +(locale "DE" "de") +(test "Freitag" (day (date 2007 6 1))) +(test "Fr" + (day (date 2007 6 1) '("Mo" "Tu" "We" "Th" "Fr" "Sa" "Su")) ) +(locale) + + +### week ### +(test 22 (week (date 2007 6 1))) + + +### ultimo ### +(test (2007 1 31) (date (ultimo 2007 1))) +(test (2007 2 28) (date (ultimo 2007 2))) +(test (2004 2 29) (date (ultimo 2004 2))) +(test (2000 2 29) (date (ultimo 2000 2))) +(test (1900 2 28) (date (ultimo 1900 2))) + + +### tim$ ### +(test "10:57" (tim$ (time 10 57 56))) +(test "10:57:56" (tim$ (time 10 57 56) T)) + + +### $tim ### +(test (10 57 56) (time ($tim "10:57:56"))) +(test (10 57 0) (time ($tim "10:57"))) +(test (10 0 0) (time ($tim "10"))) + + +### stamp ### +(test "2007-06-01 10:57:56" + (stamp (date 2007 6 1) (time 10 57 56)) ) + + +### chdir ### +(let P (pwd) + (chdir "test" + (test (pwd) (pack P "/test")) ) + (test P (pwd)) ) + + +### dirname ### +(test "a/b/c/" (dirname "a/b/c/d")) + + +### fmt64 ### +(test "9" (fmt64 9)) +(test ":" (fmt64 10)) +(test ";" (fmt64 11)) +(test "A" (fmt64 12)) +(test 4096 (fmt64 "100")) + + +# vi:et:ts=3:sw=3 diff --git a/test/src/apply.l b/test/src/apply.l @@ -0,0 +1,107 @@ +# 12jul08abu +# (c) Software Lab. Alexander Burger + +### apply ### +(test 6 (apply + (1 2 3))) +(test 360 (apply * (5 6) 3 4)) +(test 27 (apply '((X Y Z) (* X (+ Y Z))) (3 4 5))) + + +### pass ### +(test 24 ((quote (N . @) (* N (pass + 6))) 2 1 2 3)) + + +### maps ### +(let L '((1 . a) (2 . b) flg) + (test L (let X (box) (putl X (reverse L)) (make (maps link X)))) ) + + +### map ### +(test '((1 2 3) (2 3) (3)) (make (map link (1 2 3)))) + + +### mapc ### +(test (1 2 3) (make (mapc link (1 2 3)))) + + +### maplist ### +(test '(((1 2 3) A B C) ((2 3) B C) ((3) C)) (maplist cons (1 2 3) '(A B C))) + + +### mapcar ### +(test (5 7 9) (mapcar + (1 2 3) (4 5 6))) +(test (26 38 52 68) (mapcar '((X Y) (+ X (* Y Y))) (1 2 3 4) (5 6 7 8))) + + +### mapcon ### +(test (1 2 3 4 5 2 3 4 5 3 4 5 4 5 5) (mapcon copy (1 2 3 4 5))) + + +### mapcan ### +(test '(c b a f e d i h g) (mapcan reverse '((a b c) (d e f) (g h i)))) + + +### filter ### +(test (1 2 3) (filter num? (1 A 2 (B) 3 CDE))) + + +### extract ### +(let (A NIL B 1 C NIL D 2 E NIL F 3) + (test (1 2 3) + (extract val '(A B C D E F)) ) + (test (1 2 3) + (extract val '(B D E F)) ) ) + + +### seek ### +(test (12 19 22) (seek '((X) (> (car X) 9)) (1 5 8 12 19 22))) + + +### find ### +(test '(B) (find pair (1 A 2 (B) 3 CDE))) +(test 4 (find > (1 2 3 4 5 6) (6 5 4 3 2 1))) +(test 4 (find '((A B) (> A B)) (1 2 3 4 5 6) (6 5 4 3 2 1))) + + +### pick ### +(test "Hello" + (pick '((X) (get X 'str)) + (list (box) (prog1 (box) (put @ 'str "Hello")) (box)) ) ) + + +### cnt ### +(test 2 (cnt cdr '((1 . T) (2) (3 4) (5)))) + + +### sum ### +(test 6 (sum val (list (box 1) (box) (box 2) (box 'a) (box 3)))) + + +### maxi mini ### +(let (A 1 B 2 C 3) + (test 'C (maxi val '(A B C))) + (test 'A (mini val '(A B C))) + (test '(A B C) (by val sort '(C A B))) ) + + +### fish ### +(test (1 2 3) + (fish gt0 '(a -2 (1 b (-3 c 2)) 3 d -1)) ) +(test '(a b c d) + (fish sym? '(a -2 (1 b (-3 c 2)) 3 d -1)) ) + + +### by ### +(test '(A B C) + (let (A 1 B 2 C 3) + (by val sort '(C A B)) ) ) +(test '((3 11 9 5 7 1) (6 2 4 10 12 8)) + (by '((N) (bit? 1 N)) + group + (3 11 6 2 9 5 4 10 12 7 8 1) ) ) +(test '(("x" "x" "x") ("y") ("z" "z")) + (by name group '("x" "x" "y" "z" "x" "z")) ) +(test '((123 "xyz") ((1 2) "XY") ("abcd" (1 2 3 4))) + (by length group '(123 (1 2) "abcd" "xyz" (1 2 3 4) "XY")) ) + +# vi:et:ts=3:sw=3 diff --git a/test/src/big.l b/test/src/big.l @@ -0,0 +1,159 @@ +# 09sep09abu +# (c) Software Lab. Alexander Burger + +### format ### +(test "123456789" (format 123456789)) +(test "12346" (format 12345.6789)) +(test "1234567.89" (format 123456789 2)) +(test "1234567,89" (format 123456789 2 ",")) +(test "1.234.567,89" (format 123456789 2 "," ".")) +(test 123456789 (format "123456789")) +(test 12345678900 (format "1234567.89" 4)) +(test NIL (format "1.234.567,89")) +(test 12345678900 (format "1234567,89" 4 ",")) +(test NIL (format "1.234.567,89" 4 ",")) +(test 12345678900 (format "1.234.567,89" 4 "," ".")) + + +### + ### +(test 6 (+ 1 2 3)) +(test 0 (+ 1 2 -3)) +(test NIL (+ NIL 7)) + + +### - ### +(test -7 (- 7)) +(test 7 (- -7)) +(test 6 (- 7 2 -1)) +(test NIL (- NIL 7)) + + +### inc ### +(test 8 (inc 7)) +(test -6 (inc -7)) +(test 0 (inc -1)) +(test 1 (inc 0)) +(test (8 -6 0 1) (let L (7 -7 -1 0) (map inc L) L)) +(test NIL (inc NIL)) +(let N 0 + (test 1 (inc 'N)) + (test 1 N) + (test 8 (inc 'N 7)) + (test 8 N) ) +(let L (1 2 3 4) + (test 3 (inc (cdr L))) + (test (1 3 3 4) L) ) + + +### dec ### +(test 7 (dec 8)) +(test -8 (dec -7)) +(test -1 (dec 0)) +(test (7 -8 -1) (let L (8 -7 0) (map dec L) L)) +(test NIL (dec NIL)) +(let N 7 + (test 6 (dec 'N)) + (test 6 N) + (test 3 (dec 'N 3)) + (test 3 N) ) + + +### * ### +(test 6 (* 1 2 3)) +(test -60 (* -5 3 2 2)) +(test NIL (* NIL 7)) + + +### */ ### +(test 6 (*/ 3 4 2)) +(test -247 (*/ 1234 -2 10)) +(test 17 (*/ 100 6)) +(test NIL (*/ 3 4 NIL)) + + +### / ### +(test 4 (/ 12 3)) +(test -5 (/ 60 -3 2 2)) +(test NIL (/ 10 NIL)) + + +### % ### +(test 2 (% 17 5)) +(test -2 (% -17 5)) +(test 1 (% 5 2)) +(test 5 (% 15 10)) +(test 1 (% 15 10 2)) +(test NIL (% NIL 7)) + + +### >> ### +(test 4 (>> 1 8)) +(test 2 (>> 3 16)) +(test 128 (>> -3 16)) +(test -32 (>> -1 -16)) + + +### lt0 ### +(test -2 (lt0 -2)) +(test NIL (lt0 7)) +(test NIL (lt0 0)) + + +### ge0 ### +(test 7 (ge0 7)) +(test NIL (ge0 -2)) +(test 0 (ge0 0)) + + +### gt0 ### +(test 7 (gt0 7)) +(test NIL (gt0 -2)) +(test NIL (gt0 0)) + + +### abs ### +(test 7 (abs -7)) +(test 7 (abs 7)) +(test NIL (abs NIL)) + + +### bit? ### +(test 7 (bit? 7 15 255)) +(test 1 (bit? 1 3)) +(test NIL (bit? 1 2)) + + +### & ### +(test 2 (& 6 3)) +(test 1 (& 7 3 1)) +(test NIL (& 7 NIL)) + + +### | ### +(test 3 (| 1 2)) +(test 15 (| 1 2 4 8)) +(test NIL (| NIL 1)) + + +### x| ### +(test 5 (x| 2 7)) +(test 4 (x| 2 7 1)) +(test NIL (x| NIL 1)) + + +### sqrt ### +(test 8 (sqrt 64)) +(test 31 (sqrt 1000)) +(test 100000000000000000000 + (sqrt 10000000000000000000000000000000000000000) ) +(test NIL (sqrt NIL)) + + +### seed rand ### +(test (if (== 64 64) 963569716595329593 2015582081) (seed "init string")) +(test (if (== 64 64) 881495644906500132 -706917003) (rand)) +(test (if (== 64 64) -510782208671386616 1224196082) (rand)) +(test (if (== 64 64) 4 8) (rand 3 9)) +(test (if (== 64 64) 5 5) (rand 3 9)) + +# vi:et:ts=3:sw=3 diff --git a/test/src/db.l b/test/src/db.l @@ -0,0 +1,43 @@ +# 08oct09abu +# (c) Software Lab. Alexander Burger + +### id ### +(test *DB (id 1)) +(test 1 (id *DB)) +(let I (id 3 4) + (test (3 . 4) (id I T)) ) + + +### lieu ### +(rollback) +(test NIL (lieu *DB)) +(test *DB (val *DB) (lieu *DB)) + + +### commit rollback ### +(let (X (new T) Y (new T)) + (set X 1 Y 2) + (commit) + (test 1 (val X)) + (test 2 (val Y)) + (set X 111) + (set Y 222) + (test 111 (val X)) + (test 222 (val Y)) + (rollback) + (test 1 (val X)) + (test 2 (val Y)) ) + + +### mark ### +(test NIL (mark *DB)) +(test NIL (mark *DB T)) +(test T (mark *DB)) +(test T (mark *DB 0)) +(test NIL (mark *DB)) + + +### dbck ### +(test NIL (dbck)) + +# vi:et:ts=3:sw=3 diff --git a/test/src/ext.l b/test/src/ext.l @@ -0,0 +1,22 @@ +# 12nov09abu +# (c) Software Lab. Alexander Burger + +### ext:Snx ### +(test "PSLSFSNTSNNLSF" + (ext:Snx "PicoLisp is not Common Lisp") ) +(test "PSLSFSNT" + (ext:Snx "PicoLisp is not Common Lisp" 8) ) + + +### ext:Ulaw ### +(test (32 47 63 78 255 206 191 175 160) + (mapcar 'ext:Ulaw (-8000 -4000 -2000 -1000 0 1000 2000 4000 8000)) ) + + +### ext:Base64 ### +(test "TQ==" + (pipe (ext:Base64 77) (line T)) ) +(test "AQID" + (pipe (ext:Base64 1 2 3) (line T)) ) + +# vi:et:ts=3:sw=3 diff --git a/test/src/ext2.l b/test/src/ext2.l @@ -0,0 +1,31 @@ +# 19feb10abu +# (c) Software Lab. Alexander Burger + +### ext:Sin ### +(test 0 + (ext:Sin 0 100000) ) +(test 100000 + (ext:Sin (/ 314159 2) 100000) ) + + +### ext:Cos ### +(test 100000 + (ext:Cos 0 100000) ) +(test -10000000 + (ext:Cos 31415926 10000000) ) + + +### ext:Tan ### +(test 0 + (ext:Tan 0 10000000) ) +(test -1 + (ext:Tan 31415926 10000000) ) + + +### ext:Atan ### +(test 0 + (ext:Atan 0 10000000 10000000) ) +(test 15707963 + (ext:Atan 10000000 0 10000000) ) + +# vi:et:ts=3:sw=3 diff --git a/test/src/flow.l b/test/src/flow.l @@ -0,0 +1,434 @@ +# 22mar10abu +# (c) Software Lab. Alexander Burger + +### quote ### +(test (1 2 3) (quote 1 2 3)) + + +### as ### +(test NIL (as (= 3 4) A B C)) +(test '(A B C) (as (= 3 3) A B C)) + + +### pid ### +(test NIL (pid 1 '+ 3 4))) +(test 7 (pid *Pid '+ 3 4)) +(test 7 (pid (list 0 *Pid 1) '+ 3 4)) + + +### lit ### +(test 123 (lit 123)) +(test NIL (lit NIL)) +(test T (lit T)) +(test (1) (lit '(1))) +(test ''"abc" (lit "abc")) +(test ''a (lit 'a)) +(test (1 2 3) (lit '(1 2 3))) +(test ''(a b c) (lit '(a b c))) + + +### eval ### +(test 6 (eval (list '+ 1 2 3))) +(let (X 'Y Y 7) + (test 7 (eval X)) ) +(let N 1 + ((quote (N) + ((quote (N) + (test 3 N) + (test 2 (eval 'N 1)) + (test 2 (eval 'N 1 '(X))) + (test 3 (eval 'N 1 '(N))) + (test 1 (eval 'N 2)) + (test 3 (eval 'N 2 '(N))) ) + 3 ) ) + 2 ) ) + + +### run ### +(test 6 (run (list (list '+ 1 2 3)))) +(test 2 + (let N 1 + ((quote (N) (run '((+ N N)) 1)) 2) ) ) + + +### def ### +(test '"a" + (def '"a" '((X Y) (* X (+ X Y)))) ) +(test '((X Y) (* X (+ X Y))) + "a" ) + + +### de ### +(test '"b" + (de "b" (X Y) (* X (+ X Y))) ) +(test '((X Y) (* X (+ X Y))) + "b" ) + + +### dm ### +(off "+Cls" "+A") +(class "+Cls" "+A") + +(test '"foo>" + (dm "foo>" (X Y) + (* X (+ X Y)) ) ) +(test '"foo>" + (dm ("foo>" . "+Cls") (X Y) + (* X (+ X Y)) ) ) +(test '(("foo>" (X Y) (* X (+ X Y))) "+A") + "+Cls" ) + + +### box ### +(let X (box '(A B C)) + (test X (box? X)) + (test '(A B C) (val X)) ) + + +### new type isa method meth send try ### +(let X (new '("+Cls")) + (test X (box? X)) + (test 21 ("foo>" X 3 4)) + (test '("+Cls") (type X)) + (test X (isa '"+Cls" X)) + (test NIL (isa '(A B C) X)) + (test '((X Y) (* X (+ X Y))) + (method '"foo>" X) ) + (test meth "foo>") + (test 21 (send '"foo>" X 3 4)) + (test NIL (try '"bar>" X)) + (test 21 (try '"foo>" X 3 4)) ) + + +### super ### +(off "+Sub") +(class "+Sub" "+Cls") + +(dm ("foo>" . "+Sub") (X Y) + (super X Y) ) +(let X (new '("+Sub")) + (test 21 ("foo>" X 3 4)) ) + + +### super ### +(off "+Pref") +(class "+Pref") + +(dm ("foo>" . "+Pref") (X Y) + (extra X Y) ) +(let X (new '("+Pref" "+Sub")) + (test 21 ("foo>" X 3 4)) ) + + +### with ### +(let X (box) + (put X 'a 1) + (put X 'b 2) + (test (1 2) + (with X (list (: a) (: b))) ) ) + + +### bind ### +(let X 123 + (test "Hello" + (bind 'X + (setq X "Hello") + X ) ) + (test (3 4 12) + (bind '((X . 3) (Y . 4)) + (list X Y (* X Y)) ) ) ) + + +### job ### +(off "tst") + +(de "tst" () + (job '((A . 0) (B . 0)) + (cons (inc 'A) (inc 'B 2)) ) ) + +(test (1 . 2) ("tst")) +(test (2 . 4) ("tst")) +(test (3 . 6) ("tst")) + + +### let let? use ### +(let N 1 + (test NIL (let? N NIL N)) + (test 7 (let? N 7 N)) + (use N + (setq N 2) + (let N 3 + (test 3 N) ) + (test 2 N) ) + (test 1 N) ) +(let N 1 + (use (N) + (setq N 2) + (let (N 3) + (test 3 N) ) + (test 2 N) ) + (test 1 N) ) + + +### and ### +(test 7 (and T 123 7)) +(test NIL (and NIL 123)) + + +### or ### +(test NIL (or NIL)) +(test 7 (or NIL 7 123)) + + +### nand ### +(test NIL (nand T 123 7)) +(test T (nand NIL 123)) + + +### nor ### +(test T (nor NIL)) +(test NIL (nor NIL 7 123)) + + +### xor ### +(test T (xor T NIL)) +(test T (xor NIL T)) +(test NIL (xor NIL NIL)) +(test NIL (xor T T)) + + +### bool ### +(test T (bool 'a)) +(test T (bool 123)) +(test NIL (bool NIL)) + + +### not ### +(test T (not NIL)) +(test NIL (not T)) +(test NIL (not 'a)) + + +### nil ### +(test NIL (nil (+ 1 2 3))) + + +### t ### +(test T (t (+ 1 2 3))) + + +### prog ### +(let N 7 + (test 3 + (prog (dec 'N) (dec 'N) (dec 'N) (dec 'N) N) ) ) + + +### prog1 prog2 ### +(test 1 (prog1 1 2 3)) +(test 2 (prog2 1 2 3)) + + +### if ### +(test 1 (if (= 3 3) 1 2)) +(test 2 (if (= 3 4) 1 2)) + + +### if2 ### +(test 'both + (if2 T T 'both 'first 'second 'none) ) +(test 'first + (if2 T NIL 'both 'first 'second 'none) ) +(test 'second + (if2 NIL T 'both 'first 'second 'none) ) +(test 'none + (if2 NIL NIL 'both 'first 'second 'none) ) + + +### ifn ### +(test 2 (ifn (= 3 3) 1 2)) +(test 1 (ifn (= 3 4) 1 2)) + + +### when ### +(test 7 (when (= 3 3) 7)) +(test NIL (when (= 3 4) 7)) + + +### unless ### +(test NIL (unless (= 3 3) 7)) +(test 7 (unless (= 3 4) 7)) + + +### cond ### +(test 1 (cond ((= 3 3) 1) (T 2))) +(test 2 (cond ((= 3 4) 1) (T 2))) + + +### nond ### +(test 2 (nond ((= 3 3) 1) (NIL 2))) +(test 1 (nond ((= 3 4) 1) (NIL 2))) +(test (1 . a) + (nond ((num? 'a) (cons 1 'a)) (NIL (cons 2 @))) ) +(test (2 . 7) + (nond ((num? 7) (cons 1 7)) (NIL (cons 2 @))) ) + + +### case ### +(test 1 (case 'a (a 1) ((b c) 2) (T 3))) +(test 2 (case 'b (a 1) ((b c) 2) (T 3))) +(test 2 (case 'c (a 1) ((b c) 2) (T 3))) +(test 3 (case 'd (a 1) ((b c) 2) (T 3))) + + +### state ### +(off "tst") + +(de "tst" () + (job '((Cnt . 4)) + (state '(start) + (start 'run + (link 'start) ) + (run (and (gt0 (dec 'Cnt)) 'run) + (link 'run) ) + (run 'stop + (link 'run) ) + (stop 'start + (setq Cnt 4) + (link 'stop) ) ) ) ) + +(test '(start run run run run stop start run run run run stop) + (make (do 12 ("tst"))) ) +(test '(start run run) + (make (do 3 ("tst"))) ) + + +### while ### +(test (1 2 3 4 5 6 7) + (make + (let N 0 + (while (>= 7 (inc 'N)) + (link N) ) ) ) ) + + +### until ### +(test (1 2 3 4 5 6 7) + (make + (let N 0 + (until (> (inc 'N) 7) + (link N) ) ) ) ) + + +### loop ### +(test (1 2 3 4 5 6 7) + (make + (let N 1 + (loop + (link N) + (T (> (inc 'N) 7)) ) ) ) ) +(test (1 2 3 4 5 6 7) + (make + (let N 1 + (loop + (link N) + (NIL (>= 7 (inc 'N))) ) ) ) ) + +(test + '(a . 3) + (loop (T NIL (cons @ 1)) (NIL 'a (cons @ 2)) (NIL NIL (cons @ 3))) ) + + +### do ### +(test (1 2 3 4 5 6 7) + (make + (let N 0 + (do 7 + (link (inc 'N)) ) ) ) ) +(test (1 2 3 4 5 6 7) + (make + (let N 1 + (do T + (link N) + (T (> (inc 'N) 7)) ) ) ) ) + + +### at ### +(test (1 2 3 - 4 5 6 - 7 8 9 -) + (make + (let N 0 + (do 9 + (link (inc 'N)) + (at (0 . 3) (link '-)) ) ) ) ) + + +### for ### +(test (1 2 3 4 5 6 7) + (make + (for N (1 2 3 4 5 6 7) + (link N) ) ) ) +(test (1 2 3 4 5 6 7) + (make + (for (N . X) '(a b c d e f g) + (link N) ) ) ) +(test (1 2 3 4 5 6 7) + (make + (for N 7 + (link N) ) ) ) +(test (1 2 3 4 5 6 7) + (make + (for (N 1 (>= 7 N) (inc N)) + (link N) ) ) ) +(test (1 2 3 4 5 6 7) + (make + (for ((N . X) 7 (gt0 X) (dec X)) + (link N) ) ) ) +(test (1 2 3 4 5 6 7) + (make + (for (N 1 T) + (link N) + (T (> (inc 'N) 7)) ) ) ) + + +### catch throw ### +(test NIL (catch NIL (throw))) +(test 'b (catch 'a (throw 'a 'b))) +(test 123 (catch T (throw 'a 123))) +(test "Undefined" + (catch '("Undefined") (mist)) ) +(test "No such file" + (catch '("No such file") + (in "doesntExist" (foo)) ) ) +(test 6 + (case + (catch '("No such file" "Undefined" "expected") + (+ 1 2 3) ) + ("No such file" (shouldNotComeHere)) + ("Undefined" (shouldNotComeHere)) + ("expected" (shouldNotComeHere)) + (T @) ) ) + + +### finally ### +(test 'B + (let X 'A + (catch NIL + (finally (setq X 'B) + (setq X 'C) + (throw) + (setq X 'D) ) ) + X ) ) + + +### sys ### +(test "PicoLisp" (sys "TEST" "PicoLisp")) +(test "PicoLisp" (sys "TEST")) + + +### call ### +(test T (call 'test "-d" "test")) +(test NIL (call 'test "-f" "test")) + + +### kill ### +(test T (kill *Pid 0)) + +# vi:et:ts=3:sw=3 diff --git a/test/src/ht.l b/test/src/ht.l @@ -0,0 +1,46 @@ +# 29jan09abu +# (c) Software Lab. Alexander Burger + +### ht:Prin ### +(test "1&lt;2&gt;3&amp;äöü<i>ÄÖÜß" + (pipe (ht:Prin "1<2>3&äöü<i>ÄÖÜß") (line T)) ) + + +### ht:Fmt ### +(test "+123&abc&$def&-123&_+1_xyz_+7" + (ht:Fmt 123 "abc" 'def '{123} (1 "xyz" 7)) ) + + +### ht:Pack ### +(test "A+B C" + (ht:Pack '("A" "+" "B" "%" "2" "0" "C")) ) +(test "a b>c" + (ht:Pack '("a" "%" "2" "0" "b" "&" "g" "t" ";" "c")) ) +(test "a€z" + (ht:Pack '("a" "&" "#" "8" "3" "6" "4" ";" "z")) ) +(test "äöü" + (ht:Pack '("%" "C" "3" "%" "A" "4" "%" "C" "3" "%" "B" "6" "%" "C" "3" "%" "B" "C")) ) + + +### ht:Read ### +(test NIL + (pipe (prin "abcde") (ht:Read 0)) ) +(test NIL + (pipe (prin "abcde") (ht:Read 6)) ) +(test NIL + (pipe NIL (ht:Read 3)) ) +(test NIL + (pipe (prin "äö") (ht:Read 3)) ) +(test '("ä" "ö") + (pipe (prin "äö") (ht:Read 4)) ) +(test '("a" "b" "c") + (pipe (prin "abcde") (ht:Read 3)) ) +(test '("ä" "ö" "ü") + (pipe (prin "äöüxyz") (ht:Read 6)) ) + + +### ht:In ht:Out ### +(test "Hello world" + (pipe (ht:Out T (prinl "Hello world")) (ht:In T (line T))) ) + +# vi:et:ts=3:sw=3 diff --git a/test/src/io.l b/test/src/io.l @@ -0,0 +1,220 @@ +# 22mar10abu +# (c) Software Lab. Alexander Burger + +### path ### +(test (path '@) (pack (pwd) '/)) +(test (char "+") (char (path "+@"))) + + +### read ### +(test (1 2 3) (~(1 2) 3)) +(test (1 3) (~(1 . 2) 3)) +(test (1 2 3 4) (1 ~(2 3) 4)) +(test (1 2 4) (1 ~(2 . 3) 4)) +(test (1 abc (d e f)) + (pipe (prinl "(1 abc (d e f))") + (read) ) ) +(test '(abc "=" def_ghi "(" "xyz" "+" "-" 123 ")") + (pipe (prinl "abc = def_ghi(\"xyz\"+-123) # Comment") + (make + (while (read "_" "#") + (link @) ) ) ) ) + + +### wait ### +(let (*Run NIL *Cnt 0) + (test (1 2 3 4 5 6 7) + (make + (task -10 0 (link (inc '*Cnt))) + (wait NIL (>= *Cnt 7)) ) ) ) + + +### peek char ### +(pipe (prin "ab") + (test "a" (peek)) + (test "a" (char)) + (test "b" (peek)) + (test "b" (char)) + (test NIL (peek)) + (test NIL (char)) ) +(test "A" (char 65)) +(test 65 (char "A")) + + +### skip ### +(test "a" + (pipe (prinl "# Comment^Ja") + (skip "#") ) ) +(test "#" + (pipe (prinl "# Comment^Ja") + (skip) ) ) + + +### eof ### +(test T (pipe NIL (eof))) +(test NIL (pipe (prin "a") (eof))) +(test T (pipe (prin "a") (eof T) (eof))) + + +### from till ### +(test "cd" + (pipe (prin "ab.cd:ef") + (from ".") + (till ":" T) ) ) + + +### line ### +(test '("a" "b" "c") + (pipe (prin "abc^J") (line)) ) +(test "abc" + (pipe (prin "abc") (line T)) ) +(test '("abc" "def") + (pipe (prin "abc^Jdef") + (list (line T) (line T)) ) ) +(test '("abc" "def") + (pipe (prin "abc^Mdef") + (list (line T) (line T)) ) ) +(test '("abc" "def") + (pipe (prin "abc^M^Jdef") + (list (line T) (line T)) ) ) +(test '("a" "bc" "def") + (pipe (prin "abcdef") + (line T 1 2 3) ) ) + + +### lines ### +(out (tmp "lines") + (do 3 (prinl "abc")) ) + +(test 3 (lines (tmp "lines"))) + + +### any ### +(test '(a b c d) (any "(a b # Comment^Jc d)")) +(test "A String" (any "\"A String\"")) + + +### sym ### +(test "(abc \"Hello\" 123)" + (sym '(abc "Hello" 123)) ) + + +### str ### +(test '(a (1 2) b) + (str "a (1 2) b") ) +(test '(a (1 2)) + (str "a (1 2) # b") ) +(test "a \"Hello\" DEF" + (str '(a "Hello" DEF)) ) + + +### load ### +(test 6 (load "-* 1 2 3")) + + +### in out ### +(out (tmp "file") + (println 123) + (println 'abc) + (println '(d e f)) ) +(in (tmp "file") + (test 123 (read)) + (in (tmp "file") + (test 123 (read)) + (test 'abc (in -1 (read))) ) + (test '(d e f) (read)) ) + + +### pipe ### +(test 123 (pipe (println 123) (read))) + + +### open close ### +(let F (open (tmp "file")) + (test 123 (in F (read))) + (test 'abc (in F (read))) + (test '(d e f) (in F (read))) + (test F (close F)) ) + + +### echo ### +(out (tmp "echo") + (in (tmp "file") + (echo) ) ) +(in (tmp "echo") + (test 123 (read)) + (test 'abc (read)) + (test '(d e f) (read)) ) + + +### prin prinl space print printsp println ### +(out (tmp "prin") + (prin 1) + (prinl 2) + (space) + (print 3) + (printsp 4) + (println 5) ) +(test (12 "^J" " " 34 5) + (in (tmp "prin") + (list (read) (char) (char) (read) (read)) ) ) + + +### flush rewind ### +(out (tmp "prin") + (prinl "abc") + (flush) + (test "abc" (in (tmp "prin") (line T))) + (rewind) ) +(out (tmp "prin") (prinl "def")) +(test "def" (in (tmp "prin") (line T))) + + +### ext rd pr ### +(let L (list (id 1 2) (cons (id 3 9) 'a) (cons (id 2 7) 'b)) + (let L5 (list (id 6 2) (cons (id 8 9) 'a) (cons (id 7 7) 'b)) + (out (tmp "ext") + (ext 5 (pr L5)) ) + (test L + (in (tmp "ext") (rd)) ) + (test L5 + (in (tmp "ext") (ext 5 (rd))) ) ) ) + +(pipe + (for N 4096 + (pr N) ) + (for N 4096 + (test N (rd)) ) ) +(pipe + (for C 4096 + (pr (char C)) ) + (for C 4096 + (test C (char (rd))) ) ) +(pipe + (pr (7 "abc" (1 2 3) 'a)) + (test (7 "abc" (1 2 3) 'a) (rd)) ) +(test "def" + (out (tmp "pr") + (pr 'abc "EOF" 123 "def") ) ) +(test '(abc "EOF" 123 "def") + (in (tmp "pr") + (make + (use X + (until (== "EOF" (setq X (rd "EOF"))) + (link X) ) ) ) ) ) + + +### wr ### +(test 3 + (out (tmp "wr") + (wr 1 2 3) ) ) +(test (hex "010203") + (in (tmp "wr") + (rd 3) ) ) + + +### rpc ### +(test *Pid + (pipe (rpc '*Pid) (run (rd))) ) + +# vi:et:ts=3:sw=3 diff --git a/test/src/main.l b/test/src/main.l @@ -0,0 +1,150 @@ +# 31jan10abu +# (c) Software Lab. Alexander Burger + +### alarm ### +(let N 6 + (alarm 1 (inc 'N)) + (test 6 N) + (wait 2000) + (test 7 N) + (alarm 0) ) + + +### protect ### +(test NIL (pipe (prog (kill *Pid) (pr 7)) (rd))) +(test 7 (pipe (protect (kill *Pid) (pr 7)) (rd))) + + +### quit ### +(test "Quit" (catch '("Quit") (quit "Quit"))) + + +### env ### +(test NIL (env)) +(test '((A . 1) (B . 2)) + (let (A 1 B 2) + (env) ) ) +(test '((B . 2) (A . 1)) + (let (A 1 B 2) + (env '(A B)) ) ) +(test '((Y . 8) (B . 2) (A . 1) (X . 7)) + (let (A 1 B 2) + (env 'X 7 '(A B) 'Y 8) ) ) + + +### up ### +(test 1 + (let N 1 + ((quote (N) (up N)) 2) ) ) +(test 7 + (let N 1 + ((quote (N) (up N 7)) 2) + N ) ) + + +### args next arg rest #### +(test '(T 1 1 3 (2 3 4)) + (let foo '(@ (list (args) (next) (arg) (arg 2) (rest))) + (foo 1 2 3 4) ) ) + +(test (7 7 NIL NIL) + ((quote @ (list (next) (arg) (next) (arg))) 7) ) + + +### usec ### +(let U (usec) + (wait 400) + (test 4 (*/ (- (usec) U) 100000)) ) + + +### pwd ### +(test (path '@) (pack (pwd) '/)) + + +### cd ### +(cd "test") +(test (path "@test") (pwd)) +(cd "..") + + +### info ### +(test '(T . @) (info "test")) +(test (5 . @) + (out (tmp "info") (prinl "info")) + (info (tmp "info")) ) + + +### file ### +(test (cons (tmp) "file" 1) + (out (tmp "file") (println '(file))) + (load (tmp "file")) ) + + +### dir ### +(call 'mkdir "-p" (tmp "dir")) +(out (tmp "dir/a")) +(out (tmp "dir/b")) +(out (tmp "dir/c")) + +(test '("a" "b" "c") (sort (dir (tmp "dir")))) + + +### cmd ### +(cmd "test") +(test "test" (cmd)) + + +### argv ### +(test '("abc" "123") + (pipe + (call "bin/picolisp" "-prog (println (argv)) (bye)" "abc" 123) + (read) ) ) +(test '("abc" "123") + (pipe + (call "bin/picolisp" "-prog (argv A B) (println (list A B)) (bye)" "abc" 123) + (read) ) ) + + +### opt ### +(test '("abc" "123") + (pipe + (call "bin/picolisp" "-prog (println (list (opt) (opt))) (bye)" "abc" 123) + (read) ) ) +(test "abc" + (pipe + (call "bin/picolisp" "-de f () (println (opt))" "-f" "abc" "-bye") + (read) ) ) + + +### date time ### +(use (Dat1 Tim1 Dat2 Tim2 D1 T1 D2 T2) + (until + (= + (setq Dat1 (date) Tim1 (time T)) + (prog + (setq + Dat2 (date T) + Tim2 (time T) + D1 (in '(date "+%Y %m %d") (list (read) (read) (read))) + T1 (in '(date "+%H %M %S") (list (read) (read) (read))) + D2 (in '(date "-u" "+%Y %m %d") (list (read) (read) (read))) + T2 (in '(date "-u" "+%H %M %S") (list (read) (read) (read))) ) + (time) ) ) ) + (test Tim1 (time T1)) + (test Tim1 (apply time T1)) + (test Tim2 (time T2)) + (test Dat1 (date D1)) + (test Dat1 (apply date D1)) + (test Dat2 (date D2)) ) + +(test (2000 7 15) (date 730622)) +(test 730622 (date 2000 7 15)) +(test 730622 (date (2000 7 15))) +(test NIL (date NIL)) + +(test (11 17 23) (time 40643)) +(test 40643 (time 11 17 23)) +(test 40643 (time (11 17 23))) +(test NIL (time NIL)) + +# vi:et:ts=3:sw=3 diff --git a/test/src/net.l b/test/src/net.l @@ -0,0 +1,25 @@ +# 24nov09abu +# (c) Software Lab. Alexander Burger + +### port listen connect ### +(test '(a b c) + (if (fork) + (let P (port 4445) + (prog1 + (in (listen P) (rd)) + (close P) ) ) + (wait 400) + (and (connect "localhost" 4445) (out @ (pr '(a b c)))) + (bye) ) ) + + +### udp ### +(test '(a b c) + (ifn (fork) + (prog + (wait 400) + (udp "localhost" 4446 '(a b c)) + (bye) ) + (udp (port T 4446)) ) ) + +# vi:et:ts=3:sw=3 diff --git a/test/src/subr.l b/test/src/subr.l @@ -0,0 +1,477 @@ +# 07nov09abu +# (c) Software Lab. Alexander Burger + +### c[ad]*r ### +(let L '(1 2 3 4 5) + (test 1 (car L)) + (test (2 3 4 5) (cdr L)) + (test 2 (cadr L)) + (test (3 4 5) (cddr L)) + (test 3 (caddr L)) + (test (4 5) (cdddr L)) + (test 4 (cadddr L)) + (test (5) (cddddr L)) ) +(let L '((1 2 3) (4 5)) + (test 1 (caar L)) + (test (2 3) (cdar L)) + (test 2 (cadar L)) + (test (3) (cddar L)) + (test 4 (caadr L)) + (test (5) (cdadr L)) ) +(let L '(((1 2))) + (test 1 (caaar L)) + (test (2) (cdaar L)) ) + + +### nth ### +(test '(b c d) (nth '(a b c d) 2)) +(test '(c) (nth '(a (b c) d) 2 2)) + + +### con ### +(let C (1 . a) + (test '(b c d) (con C '(b c d))) + (test (1 b c d) C) ) + + +### cons ### +(test (1 . 2) (cons 1 2)) +(test '(a b c d) (cons 'a '(b c d))) +(test '((a b) c d) (cons '(a b) '(c d))) +(test '(a b c . d) (cons 'a 'b 'c 'd)) + + +### conc ### +(let (A (1 2 3) B '(a b c)) + (test (1 2 3 a b c) (conc A B)) + (test (1 2 3 a b c) A) ) + + +### circ ### +(let C (circ 'a 'b 'c) + (test '(a b c . @) C) + (test T (== C (cdddr C))) ) + + +### rot ### +(test (4 1 2 3) (rot (1 2 3 4))) +(test (3 1 2 4 5 6) (rot (1 2 3 4 5 6) 3)) +(test (3 1 2 . @Z) (rot (1 2 3 .))) + + +### list ### +(test (1 2 3 4) (list 1 2 3 4)) +(test '(a (2 3) "OK") (list 'a (2 3) "OK")) + + +### need ### +(test '(NIL NIL NIL NIL NIL) (need 5)) +(test '(NIL NIL a b c) (need 5 '(a b c))) +(test '(a b c NIL NIL) (need -5 '(a b c))) +(test '(" " " " a b c) (need 5 '(a b c) " ")) + + +### range ### +(test (1 2 3 4 5 6) (range 1 6)) +(test (1 2 3 4 5 6) (range 1 6)) +(test (6 5 4 3 2 1) (range 6 1)) +(test (-3 -2 -1 0 1 2 3) (range -3 3)) +(test (3 1 -1 -3) (range 3 -3 2)) +(test (-3 -2 -1) (range -3 -1)) + + +### full ### +(test T (full (1 2 3))) +(test NIL (full (1 NIL 3))) +(test T (full 123)) + + +### make made chain link yoke ### +(let (A 'a I 'i) + (test '(x y z z a) + (make + (link (for A '(x y z) (link A))) + (link A) ) ) + (test (0 1 x 2 y 3 z i a) + (make + (for (I . A) '(x y z) (link I A)) + (test (1 x 2 y 3 z) (made)) + (made (cons 0 (made))) + (link I A) ) ) + (test (1 2 3 4 5 6 7 8 9) + (make (chain (1 2 3)) (chain (4 5 6) (7 8 9))) ) + (test '(a b c) + (make (yoke 'b) (link 'c) (yoke 'a)) ) + (test '((x y z) (y z) (z) (z) a) + (make (link (for (A '(x y z) A (cdr A)) (link A))) (link A)) ) + (test (1 (x y z) 2 (y z) 3 (z) (z) i a) + (make (link (for ((I . A) '(x y z) A (cdr A)) (link I A))) (link I A)) ) ) + + +### copy ### +(test T (=T (copy T))) +(let L (1 2 3) + (test T (== L L)) + (test NIL (== L (copy L))) + (test T (= L (copy L))) + (test T (= (1 2 3) (copy L))) ) + + +### mix ### +(test '(c d a b) (mix '(a b c d) 3 4 1 2)) +(test '(a A d D) (mix '(a b c d) 1 'A 4 'D)) + + +### append ### +(test '(a b c 1 2 3) (append '(a b c) (1 2 3))) +(test (1 2 3 . 4) (append (1) (2) (3) 4)) + + +### delete ### +(test (1 3) (delete 2 (1 2 3))) +(test '((1 2) (5 6) (3 4)) (delete (3 4) '((1 2) (3 4) (5 6) (3 4)))) + + +### delq ### +(test '(a c) (delq 'b '(a b c))) +(test (1 (2) 3) (delq (2) (1 (2) 3))) + + +### replace ### +(test '(A b b A) (replace '(a b b a) 'a 'A)) +(test '(a B B a) (replace '(a b b a) 'b 'B)) +(test '(B A A B) (replace '(a b b a) 'a 'B 'b 'A)) + + +### strip ### +(test 123 (strip 123)) +(test '(a) (strip '''(a))) +(test '(a b c) (strip (quote quote a b c))) + + +### split ### +(test '((1) (2 b) (c 4 d 5) (6)) + (split (1 a 2 b 3 c 4 d 5 e 6) 'e 3 'a) ) +(test '("The" "quick" "brown" "fox") + (mapcar pack (split (chop "The quick brown fox") " ")) ) + + +### reverse ### +(test (4 3 2 1) (reverse (1 2 3 4))) +(test NIL (reverse NIL)) + + +### flip ### +(test (4 3 2 1) (flip (1 2 3 4))) +(test (3 2 1 4 5 6) (flip (1 2 3 4 5 6) 3)) +(test NIL (flip NIL)) + + +### trim ### +(test (1 NIL 2) (trim (1 NIL 2 NIL NIL))) +(test '(a b) (trim '(a b " " " "))) + + +### clip ### +(test (1 NIL 2) (clip '(NIL 1 NIL 2 NIL))) +(test '(a " " b) (clip '(" " a " " b " "))) + + +### head ### +(test '(a b c) (head 3 '(a b c d e f))) +(test NIL (head NIL '(a b c d e f))) +(test NIL (head 0 '(a b c d e f))) +(test '(a b c d e f) (head 10 '(a b c d e f))) +(test '(a b c d) (head -2 '(a b c d e f))) +(test '(a b c) (head '(a b c) '(a b c d e f))) + + +### tail ### +(test '(d e f) (tail 3 '(a b c d e f))) +(test '(c d e f) (tail -2 '(a b c d e f))) +(test NIL (tail NIL '(a b c d e f))) +(test NIL (tail 0 '(a b c d e f))) +(test '(a b c d e f) (tail 10 '(a b c d e f))) +(test '(d e f) (tail '(d e f) '(a b c d e f))) + + +### stem ### +(test '("g" "h" "i") (stem (chop "abc/def\\ghi") "/" "\\")) +(test '("g" "h" "i") (stem (chop "abc/def\\ghi") "\\" "/")) + + +### fin ### +(test 'a (fin 'a)) +(test 'b (fin '(a . b))) +(test 'c (fin '(a b . c))) +(test NIL (fin '(a b c))) + + +### last ### +(test 4 (last (1 2 3 4))) +(test '(d e f) (last '((a b) c (d e f)))) + + +### == ### +(test T (== 'a 'a)) +(test T (== 'NIL NIL (val NIL) (car NIL) (cdr NIL))) +(test NIL (== (1 2 3) (1 2 3))) + + +### n== ### +(test NIL (n== 'a 'a)) +(test T (n== (1) (1))) + + +### = ### +(test T (= 6 (* 1 2 3))) +(test T (= "a" "a")) +(test T (== "a" "a")) +(test T (= (1 (2) 3) (1 (2) 3))) + + +### <> ### +(test T (<> 'a 'b)) +(test T (<> 'a 'b 'b)) +(test NIL (<> 'a 'a 'a)) + + +### =0 ### +(test 0 (=0 (- 6 3 2 1))) +(test NIL (=0 'a)) + + +### =T ### +(test NIL (=T 0)) +(test NIL (=T "T")) +(test T (=T T)) + + +### n0 ### +(test NIL (n0 (- 6 3 2 1))) +(test T (n0 'a)) + + +### nT ### +(test T (nT 0)) +(test T (nT "T")) +(test NIL (nT T)) + + +### < ### +(test T (< 3 4)) +(test T (< 'a 'b 'c)) +(test T (< 999 'a)) +(test T (< NIL 7 'x (1) T)) + + +### <= ### +(test T (<= 3 3)) +(test T (<= 1 2 3)) +(test T (<= "abc" "abc" "def")) + + +### > ### +(test T (> 4 3)) +(test T (> 'A 999)) +(test T (> T (1) 'x 7 NIL)) + + +### >= ### +(test T (>= 'A 999)) +(test T (>= 3 2 2 1)) + + +### max ### +(test 'z (max 2 'a 'z 9)) +(test (5) (max (5) (2 3) 'X)) + + +### min ### +(test 2 (min 2 'a 'z 9)) +(test 'X (min (5) (2 3) 'X)) + + +### atom ### +(test T (atom 123)) +(test T (atom 'a)) +(test T (atom NIL)) +(test NIL (atom (123))) + + +### pair ### +(test NIL (pair NIL)) +(test (1 . 2) (pair (1 . 2))) +(test (1 2 3) (pair (1 2 3))) + + +### lst? ### +(test T (lst? NIL)) +(test NIL (lst? T)) +(test T (lst? (1 . 2))) +(test T (lst? (1 2 3))) + + +### num? ### +(test 123 (num? 123)) +(test NIL (num? 'abc)) +(test NIL (num? (1 2 3))) + + +### sym? ### +(test T (sym? 'a)) +(test T (sym? NIL)) +(test NIL (sym? 123)) +(test NIL (sym? '(a b))) + + +### flg? ### +(test T (flg? T)) +(test T (flg? NIL)) +(test NIL (flg? 0)) +(test T (flg? (= 3 3))) +(test T (flg? (= 3 4))) +(test NIL (flg? (+ 3 4))) + + +### member ### +(test (3 4 5 6) (member 3 (1 2 3 4 5 6))) +(test NIL (member 9 (1 2 3 4 5 6))) +(test '((d e f) (g h i)) + (member '(d e f) '((a b c) (d e f) (g h i))) ) + + +### memq ### +(test '(c d e f) (memq 'c '(a b c d e f))) +(test NIL (memq (2) '((1) (2) (3)))) +(test 'c (memq 'c '(a b . c))) +(test '(b c a . @Z) (memq 'b '(a b c .))) +(test NIL (memq 'd '(a b c .))) + + +### mmeq ### +(test NIL (mmeq '(a b c) '(d e f))) +(test '(b x) (mmeq '(a b c) '(d b x))) + + +### sect ### +(test (3 4) (sect (1 2 3 4) (3 4 5 6))) +(test (1 2 3) (sect (1 2 3) (1 2 3))) +(test NIL (sect (1 2 3) (4 5 6))) + + +### diff ### +(test (1 3 5) (diff (1 2 3 4 5) (2 4))) +(test (1 2 3) (diff (1 2 3) NIL)) +(test NIL (diff (1 2 3) (1 2 3))) + + +### index ### +(test 3 (index 'c '(a b c d e f))) +(test NIL (index 'z '(a b c d e f))) +(test 3 (index '(5 6) '((1 2) (3 4) (5 6) (7 8)))) + + +### offset ### +(test 3 (offset '(c d e f) '(a b c d e f))) +(test NIL (offset '(c d e) '(a b c d e f))) + + +### length ### +(test 3 (length "abc")) +(test 3 (length "äbc")) +(test 3 (length 123)) +(test 3 (length (1 (2) 3))) +(test T (length (1 2 3 .))) + + +### size ### +(test 3 (size "abc")) +(test 4 (size "äbc")) +(test 1 (size 127)) +(test 2 (size 128)) +(test 4 (size (1 (2) 3))) +(test 3 (size (1 2 3 .))) +(test 8 (size '((1 2 3) (4 5 6)))) +(test 6 (size '((1 2 .) (4 5 .)))) + + +### assoc ### +(test '("b" . 7) + (assoc "b" '((999 1 2 3) ("b" . 7) ("ok" "Hello"))) ) +(test (999 1 2 3) + (assoc 999 '((999 1 2 3) ("b" . 7) ("ok" "Hello"))) ) +(test NIL + (assoc 'u '((999 1 2 3) ("b" . 7) ("ok" "Hello"))) ) + + +### asoq ### +(test NIL + (asoq (9) '(((9) 1 2 3) (b . 7) ("ok" "Hello"))) ) +(test '(b . 7) + (asoq 'b '(((9) 1 2 3) (b . 7) ("ok" "Hello"))) ) + + +### rank ### +(test NIL + (rank 0 '((1 . a) (100 . b) (1000 . c))) ) +(test (1 . a) + (rank 50 '((1 . a) (100 . b) (1000 . c))) ) +(test (100 . b) + (rank 100 '((1 . a) (100 . b) (1000 . c))) ) +(test (100 . b) + (rank 300 '((1 . a) (100 . b) (1000 . c))) ) +(test (1000 . c) + (rank 9999 '((1 . a) (100 . b) (1000 . c))) ) +(test (100 . b) + (rank 50 '((1000 . a) (100 . b) (1 . c)) T) ) + + +### match ### +(use (@A @B @X @Y @Z) + (test T + (match '(@A is @B) '(This is a test)) ) + (test '(This) @A) + (test '(a test) @B) + (test T + (match '(@X (d @Y) @Z) '((a b c) (d (e f) g) h i)) ) + (test '((a b c)) @X) + (test '((e f) g) @Y) + (test '(h i) @Z) ) + + +### fill ### +(let (@X 1234 @Y (1 2 3 4)) + (test 1234 (fill '@X)) + (test '(a b (c 1234) (((1 2 3 4) . d) e)) + (fill '(a b (c @X) ((@Y . d) e))) ) ) +(let X 2 (test (1 2 3) (fill (1 X 3) 'X))) +(let X 2 (test (1 2 3) (fill (1 X 3) '(X)))) + + +### prove ### +(test T + (prove (goal '((equal 3 3)))) ) +(test '((@X . 3)) + (prove (goal '((equal 3 @X)))) ) +(test NIL + (prove (goal '((equal 3 4)))) ) + + +### -> ### +(test '((@A . 3) (@B . 7)) + (prove (goal '(@A 3 (@B + 4 (-> @A))))) ) + + +### unify ### +(test '((@A ((NIL . @C) 0 . @C) ((NIL . @B) 0 . @B) T)) + (prove (goal '((@A unify '(@B @C))))) ) + + +### sort ### +(test '(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)) ) +(test '(T (x y z) (a b c) (1 2 3) d c b a 4 3 2 1 NIL) + (sort '(a 3 1 (1 2 3) d b 4 T NIL (a b c) (x y z) c 2) >) ) + +# vi:et:ts=3:sw=3 diff --git a/test/src/sym.l b/test/src/sym.l @@ -0,0 +1,368 @@ +# 09sep09abu +# (c) Software Lab. Alexander Burger + +### name ### +(test "abc" (name 'abc)) +(test "A123" (name '{A123})) +(let X (box) + (test NIL (name X)) + (name X "xxx") + (test "xxx" (name X)) ) + + +### sp? ### +(test T (sp? " ^I^J")) +(test NIL (sp? " abc")) +(test NIL (sp? 123)) + + +### pat? ### +(test `(char '@) (char (pat? '@))) +(test NIL (pat? "ABC")) +(test NIL (pat? 123)) + + +### fun? ### +(test 1000000000 (fun? 1000000000)) +(test NIL (fun? 12345678901234567890)) +(test '(A B) (fun? '((A B) (* A B)))) +(test NIL (fun? '((A B) (* A B) . C))) +(test NIL (fun? (1 2 3 4))) +(test NIL (fun? '((A 2 B) (* A B)))) +(test T (fun? '(NIL (* 3 4)))) + + +### all ### +(test '(test) + (filter '((S) (= S "test")) (all)) ) + + +### intern ### +(test car (val (intern (pack "c" "a" "r")))) + + +### extern ### +(test NIL (extern (box))) +(test *DB (extern "1")) + + +### ==== ### +(setq *Sym "abc") +(test T (== *Sym "abc")) +(====) +(test NIL (== *Sym "abc")) + + +### box? ### +(let X (box) + (test X (box? X)) ) +(test NIL (box? 123)) +(test NIL (box? 'a)) +(test NIL (box? NIL)) + + +### str? ### +(test NIL (str? 123)) +(test NIL (str? '{A123})) +(test NIL (str? 'abc)) +(test "abc" (str? "abc")) + + +### ext? ### +(test *DB (ext? *DB)) +(test NIL (ext? 'abc)) +(test NIL (ext? "abc")) +(test NIL (ext? 123)) + + +### touch ### +(test *DB (touch *DB)) +(rollback) + + +### zap ### +(test "abc" (str? (zap 'abc))) + + +### chop ### +(test '("c" "a" "r") (chop 'car))) +(test '("H" "e" "l" "l" "o") (chop "Hello")) +(test '("1" "2" "3") (chop 123)) +(test (1 2 3) (chop (1 2 3))) +(test NIL (chop NIL)) + + +### pack ### +(test "car is 1 symbol name" + (pack 'car " is " 1 '(" symbol " name)) ) + + +### glue ### +(test 1 (glue NIL 1)) +(test "a" (glue NIL '(a))) +(test "ab" (glue NIL '(a b))) +(test "a,b" (glue "," '(a b))) +(test "a8b" (glue 8 '(a b))) +(test "a123b123c" (glue (1 2 3) '(a b c))) + + +### text ### +(test "abc XYZ def 123" (text "abc @1 def @2" 'XYZ 123)) +(test "aXYZz" (text "a@3z" 1 2 '(X Y Z))) +(test "a@bc.de" (text "a@@bc.@1" "de")) +(test "10.11.12" (text "@A.@B.@C" 1 2 3 4 5 6 7 8 9 10 11 12)) + + +### pre? ### +(test "abcdef" (pre? "" "abcdef"))) +(test NIL (pre? "abc" ""))) +(test "abcdef" (pre? "abc" "abcdef"))) +(test NIL (pre? "def" "abcdef")) +(test "abcdef" (pre? "" "abcdef")) +(test "7fach" (pre? (+ 3 4) "7fach")) + + +### sub? ### +(test "abcdef" (sub? "" "abcdef"))) +(test NIL (sub? "abc" ""))) +(test "abcdef" (sub? "cde" "abcdef")) +(test "abcdef" (sub? "def" "abcdef")) +(test NIL (sub? "abb" "abcdef")) +(test "abcdef" (sub? "" "abcdef")) + + +### val ### +(let L '(a b c) + (test '(a b c) (val 'L)) + (test 'b (val (cdr L))) ) + + +### set ### +(use L + (test '(a b c) (set 'L '(a b c))) + (test 999 (set (cdr L) '999)) + (test '(a 999 c) L) ) + + +### setq ### +(use (A B) + (test (123 123) + (setq A 123 B (list A A)) ) + (test 123 A) + (test (123 123) B) ) + + +### xchg ### +(let (A 1 B 2 C '(a b c)) + (test 2 (xchg 'A C 'B (cdr C))) + (test 'a A) + (test 'b B) + (test (1 2 c) C) ) + + +### on off onOff zero one ### +(use (A B) + (test T (on A B)) + (test T A) + (test T B) + (test NIL (off A)) + (test NIL A) + (test NIL (onOff B)) + (test NIL B) + (test T (onOff A B)) + (test T A) + (test T B) + (test 0 (zero A B)) + (test 0 A) + (test 0 B) + (test 1 (one A B)) + (test 1 A) + (test 1 B) ) + + +### default ### +(let (A NIL B NIL) + (test 2 (default A 1 B 2)) + (test A 1) + (test B 2) + (test 2 (default A 7 B 8)) + (test A 1) + (test B 2) ) + + +### push push1 pop cut ### +(let L NIL + (test 1 (push 'L 3 2 1)) + (test L (1 2 3)) + (test 0 (push1 'L 0)) + (test 1 (push1 'L 1)) + (test L (0 1 2 3)) + (test 0 (pop 'L)) + (test (1 2) (cut 2 'L)) + (test (3) L) ) + + +### del ### +(let (L '((a b c) (d e f)) S (new)) + (put S 'lst L) + (test '((a b c)) (del '(d e f) 'L)) + (test '(a b c) (del 'x L)) + (test '(a c) (del 'b L)) + (with S + (test '((a b c)) (del '(d e f) (:: lst))) + (test NIL (del '(a b c) (:: lst))) + (test NIL (: lst)) ) ) + + +### queue ### +(let A NIL + (test 1 (queue 'A 1)) + (test 2 (queue 'A 2)) + (test 3 (queue 'A 3)) + (test (1 2 3) A) ) + + +### fifo ### +(let X NIL + (test 1 (fifo 'X 1)) + (test 3 (fifo 'X 2 3)) + (test 1 (fifo 'X)) + (test 2 (fifo 'X)) + (test 3 (fifo 'X)) ) + + +### idx lup ### +(let X NIL + (test NIL (idx 'X 'd T)) + (test NIL (idx 'X (2 . f) T)) + (test NIL (idx 'X (3 . g) T)) + (test NIL (idx 'X '(a b c) T)) + (test NIL (idx 'X 17 T)) + (test NIL (idx 'X 'A T)) + (test '(d . @) (idx 'X 'd T)) + (test NIL (idx 'X T T)) + (test '(A) (idx 'X 'A)) + (test '(17 A d (2 . f) (3 . g) (a b c) T) + (idx 'X) ) + (test (2 . f) (lup X 2)) + (test '((2 . f) (3 . g)) (lup X 1 4)) + (test '(17 . @) (idx 'X 17 NIL)) + (test '(A d (2 . f) (3 . g) (a b c) T) + (idx 'X) ) + (off X) + (for N '((4 . D) 3 (2 . B) Y (3 . C) Z (6 . F) 7 (7 . G) X (1 . A) T (5 . E) 5) + (idx 'X N T) ) + (test '(3 5 7 X Y Z (1 . A) (2 . B) (3 . C) (4 . D) (5 . E) (6 . F) (7 . G) T) + (idx 'X) ) + (test '((3 . C) (4 . D) (5 . E)) + (lup X 3 5) ) + (test '((1 . A) (2 . B) (3 . C) (4 . D) (5 . E) (6 . F) (7 . G)) + (lup X 0 9) ) ) + + +### put get prop ; =: : :: putl getl ### +(let (A (box) B (box A) C (box (cons A B))) + (put B 'a A) + (put C 'b B) + (put A 'x 1) + (put B 'a 'y 2) + (put C 0 -1 'a 'z 3) + (test 1 (get A 'x)) + (test 1 (; A x)) + (test 2 (with A (: y))) + (test 2 (get A 'y)) + (test 2 (; A y)) + (test 2 (with B (: 0 y))) + (test 2 (get B 0 'y)) + (test 2 (; B 0 y)) + (test 3 (with C (: b a z))) + (test 3 (with C (: 0 1 z))) + (test 3 (with C (: 0 -1 a z))) + (test 3 (get C 0 1 'z)) + (test 3 (get C 0 -1 'a 'z)) + (test 3 (; C 0 -1 a z)) + (test (3 . z) (prop C 0 -1 'a 'z)) + (test 9 (with C (=: 0 -1 a z (* 3 3)))) + (test (9 . z) (with C (:: 0 -1 a z))) + (test (putl C 0 -1 'a '((1 . x) (2 . y))) (flip (getl C 'b 0))) ) + +(test NIL (get (1 2 3) 0)) +(test 1 (get (1 2 3) 1)) +(test 3 (get (1 2 3) 3)) +(test NIL (get (1 2 3) 4)) +(test (3) (get (1 2 3) -2)) +(test 1 (get '((a (b . 1) (c . 2)) (d (e . 3) (f . 4))) 'a 'b)) +(test 4 (get '((a (b . 1) (c . 2)) (d (e . 3) (f . 4))) 'd 'f)) + + +### wipe ### +(let X (box (1 2 3 4)) + (put X 'a 1) + (put X 'b 2) + (test (1 2 3 4) (val X)) + (test '((2 . b) (1 . a)) (getl X)) + (wipe X) + (test NIL (val X)) + (test NIL (getl X)) ) + +(setq "W" (1 2 3 4)) +(put '"W" 'a 1) +(put '"W" 'b 2) +(test (1 2 3 4) "W") +(test '((2 . b) (1 . a)) (getl '"W")) +(wipe '"W") +(test NIL "W") +(test NIL (getl '"W")) + +(set *DB (1 2 3 4)) +(put *DB 'a 1) +(put *DB 'b 2) +(test (1 2 3 4) (val *DB)) +(test '((2 . b) (1 . a)) (getl *DB)) +(wipe *DB) +(test (1 2 3 4) (val *DB)) +(test '((2 . b) (1 . a)) (getl *DB)) +(rollback) +(test NIL "W") +(test NIL (getl '"W")) + + +### meta ### +(let A '("B") + (put '"B" 'a 123) + (test 123 (meta 'A 'a)) ) + + +### low? ### +(test "a" (low? "a")) +(test NIL (low? "A")) +(test NIL (low? 123)) +(test NIL (low? ".")) + + +### upp? ### +(test "A" (upp? "A")) +(test NIL (upp? "a")) +(test NIL (upp? 123)) +(test NIL (upp? ".")) + + +### lowc ### +(test "abc" (lowc "ABC")) +(test "äöü" (lowc "ÄÖÜ")) +(test "äöü" (lowc "äöü")) +(test 123 (lowc 123)) + + +### uppc ### +(test "ABC" (uppc "abc")) +(test "ÄÖÜ" (uppc "äöü")) +(test "ÄÖÜ" (uppc "ÄÖÜ")) +(test 123 (lowc 123)) + + +### fold ### +(test "1a2b3" (fold " 1A 2-b/3")) +(test "1a2" (fold " 1A 2-B/3" 3)) + +# vi:et:ts=3:sw=3