├── COPYING ├── INSTALL ├── README ├── bin ├── pil ├── psh ├── pty ├── vip └── watchdog ├── doc ├── ChangeLog ├── Tracks ├── des.html ├── doc.css ├── faq.html ├── httpGate.html ├── man.html ├── microTemplates ├── native.html ├── rc.sample ├── ref.html ├── refA.html ├── refB.html ├── refC.html ├── refD.html ├── refE.html ├── refF.html ├── refG.html ├── refH.html ├── refI.html ├── refJ.html ├── refK.html ├── refL.html ├── refM.html ├── refN.html ├── refO.html ├── refP.html ├── refQ.html ├── refR.html ├── refS.html ├── refT.html ├── refU.html ├── refV.html ├── refW.html ├── refX.html ├── refY.html ├── refZ.html ├── ref_.html ├── search ├── search.html ├── select.html ├── structures ├── tut.html └── viprc.sample ├── ext.l ├── img ├── go.png └── no.png ├── lib.css ├── lib.l ├── lib ├── adm.l ├── android.l ├── app.l ├── bash_completion ├── btree.l ├── canvas.js ├── canvas.l ├── clang.l ├── complete.l ├── db.l ├── dbgc.l ├── debug.l ├── form.js ├── form.l ├── frac.l ├── gis.js ├── gis.l ├── heartbeat.l ├── http.l ├── json.l ├── lint.l ├── map ├── math.l ├── misc.l ├── net.l ├── pilog.l ├── plio.js ├── replica.l ├── role.l ├── select.l ├── simul.l ├── sq.l ├── svg.l ├── term.l ├── test.l ├── too.l ├── user.l ├── vip.l ├── vip │ ├── draw.l │ ├── html.l │ └── load.l ├── xhtml.l ├── xhtml │ ├── area │ ├── field │ ├── grid │ ├── html │ ├── input │ ├── layout │ ├── menu │ ├── select │ ├── submit │ ├── tab │ └── table └── xm.l ├── loc ├── AE.l ├── AR.l ├── CH.l ├── CKB.l ├── CN.l ├── DE.l ├── ES.l ├── FR.l ├── GB.l ├── GR.l ├── HR.l ├── IT.l ├── JP.l ├── NIL.l ├── NO.l ├── RU.l ├── SE.l ├── TR.l ├── UA.l ├── UK.l ├── US.l ├── ar ├── ca ├── ch ├── ckb ├── cn ├── de ├── el ├── es ├── fr ├── gr ├── hr ├── it ├── ja ├── jp ├── no ├── ru ├── sv ├── tr └── uk ├── man └── man1 │ ├── picolisp.1 │ └── pil.1 ├── misc ├── bigtest └── stress.l ├── pil ├── src ├── Makefile ├── Makefile.macos ├── Makefile.openbsd ├── apply.l ├── balance.c ├── base.ll ├── big.l ├── db.l ├── dec.l ├── defs.l ├── ext.l ├── ext.ll ├── flow.l ├── gc.l ├── glob.l ├── ht.l ├── ht.ll ├── httpGate.c ├── io.l ├── lib.c ├── lib │ └── llvm.l ├── main.l ├── pico.h ├── ssl.c ├── subr.l ├── sym.l ├── sysdefs.c └── vers.l ├── test ├── lib.l ├── lib │ ├── db.l │ ├── lint.l │ ├── math.l │ └── misc.l └── src │ ├── apply.l │ ├── big.l │ ├── db.l │ ├── ext.l │ ├── flow.l │ ├── ht.l │ ├── io.l │ ├── main.l │ ├── net.l │ ├── subr.l │ └── sym.l └── vip /COPYING: -------------------------------------------------------------------------------- 1 | PicoLisp Copyright (c) Software Lab. Alexander Burger 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining a 4 | copy of this software and associated documentation files (the 5 | "Software"), to deal in the Software without restriction, including 6 | without limitation the rights to use, copy, modify, merge, publish, 7 | distribute, sublicense, and/or sell copies of the Software, and to 8 | permit persons to whom the Software is furnished to do so, subject to 9 | the following conditions: 10 | 11 | The above copyright notice and this permission notice shall be included 12 | in all copies or substantial portions of the Software. 13 | 14 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS 15 | OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. 17 | IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY 18 | CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, 19 | TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE 20 | SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 21 | -------------------------------------------------------------------------------- /INSTALL: -------------------------------------------------------------------------------- 1 | # 09jun24 Software Lab. Alexander Burger 2 | 3 | 4 | PicoLisp Installation 5 | ===================== 6 | 7 | 8 | PicoLisp needs a POSIX compatible system and the LLVM infrastructure. It 9 | supports two installation strategies: Local and Global. 10 | 11 | For a global installation, allowing system-wide access to the executable 12 | and library/documentation files, you can either install it from a 13 | ready-made distribution, or set some symbolic links to one of the local 14 | installation directories as described below. 15 | 16 | Note that you are still free to have local installations along with a 17 | global installation, and invoke them explicitly as desired. 18 | 19 | 20 | Local Installation 21 | ------------------ 22 | 23 | The following instructions work on Debian Linux. They should be similar 24 | on other systems. 25 | 26 | 1. Install required packages 27 | 28 | $ sudo apt install binutils make clang llvm libreadline-dev libffi-dev libssl-dev pkg-config 29 | 30 | 2. Unpack the tarball 31 | 32 | $ wget https://software-lab.de/pil21.tgz 33 | $ tar xfz pil21.tgz 34 | 35 | 3. Change the directory 36 | 37 | $ cd pil21 38 | 39 | 4. Compile the PicoLisp interpreter 40 | 41 | $ (cd src; make) 42 | 43 | 44 | Global Installation 45 | ------------------- 46 | 47 | The recommended way for a global installation is to use a picolisp 48 | package from the OS distribution. 49 | 50 | If that is not available, you can (as root) create symbolic links from 51 | /usr/lib and /usr/bin to a local installation directory: 52 | 53 | # ln -s //pil21 /usr/lib/picolisp 54 | # ln -s /usr/lib/picolisp/bin/picolisp /usr/bin 55 | # ln -s /usr/lib/picolisp/bin/pil /usr/bin 56 | 57 | For additional access to the man pages, utilities and bash completion: 58 | 59 | # ln -s //pil21/man/man1/picolisp.1 /usr/share/man/man1 60 | # ln -s //pil21/man/man1/pil.1 /usr/share/man/man1 61 | # ln -s //pil21 /usr/share/picolisp 62 | # ln -s //pil21/lib/bash_completion /usr/share/bash-completion/completions/pil 63 | 64 | 65 | Invocation 66 | ---------- 67 | 68 | In a global installation, the 'pil' command should be used. You can 69 | either start in plain or in debug mode. The difference is that for debug 70 | mode the command is followed by single plus ('+') sign. The '+' must be 71 | the very last argument on the command line. 72 | 73 | $ pil # Plain mode 74 | : 75 | 76 | $ pil + # Debug mode 77 | : 78 | 79 | In both cases, the colon ':' is PicoLisp's prompt. You may enter some 80 | Lisp expression, 81 | 82 | : (+ 1 2 3) 83 | -> 6 84 | 85 | To exit the interpreter, enter 86 | 87 | : (bye) 88 | 89 | or just type Ctrl-D. 90 | 91 | 92 | For a local invocation, specify a path name, e.g. 93 | 94 | $ ./pil # Plain mode 95 | : 96 | 97 | $ ./pil + # Debug mode 98 | : 99 | 100 | or 101 | 102 | $ /home/app/pil # Invoking a local installation from some other directory 103 | 104 | Note that 'pil' can also serve as a template for your own stand-alone 105 | scripts. 106 | 107 | 108 | Documentation 109 | ------------- 110 | 111 | For further information, please look at "doc/index.html". There you find 112 | the PicoLisp Reference Manual ("doc/ref.html"), the PicoLisp tutorial 113 | ("doc/tut.html"), and the frequently asked questions ("doc/faq.html"). 114 | 115 | As always, the most accurate and complete documentation is the source 116 | code ;-) 117 | 118 | Any feedback is welcome! 119 | Hope you enjoy :-) 120 | 121 | -------------------------------------------------------------------------------- 122 | 123 | Alexander Burger 124 | Software Lab. / 7fach GmbH 125 | Bahnhofstr. 24a, D-86462 Langweid 126 | abu@software-lab.de, https://www.software-lab.de, +49 8230 5060 127 | -------------------------------------------------------------------------------- /README: -------------------------------------------------------------------------------- 1 | # 09jun24 Software Lab. Alexander Burger 2 | 3 | Perfection is attained 4 | not when there is nothing left to add 5 | but when there is nothing left to take away 6 | (Antoine de Saint-Exupery) 7 | 8 | The PicoLisp System 9 | =================== 10 | 11 | _PI_co Lisp is not _CO_mmon Lisp 12 | 13 | PicoLisp can be viewed from two different aspects: As a general purpose 14 | programming language, and a dedicated application server framework. 15 | 16 | 17 | (1) As a programming language, PicoLisp provides a 1-to-1 mapping of a 18 | clean and powerful Lisp derivate, to a simple and efficient virtual 19 | machine. It supports persistent objects as a first class data type, 20 | resulting in a database system of Entity/Relation classes and a 21 | Prolog-like query language tightly integrated into the system. 22 | 23 | The virtual machine was designed to be 24 | 25 | Simple 26 | The internal data structure should be as simple as possible. Only 27 | one single data structure is used to build all higher level 28 | constructs. 29 | Unlimited 30 | There are no limits imposed upon the language due to limitations 31 | of the virtual machine architecture. That is, there is no upper 32 | bound in symbol name length, number digit counts, or data 33 | structure and buffer sizes, except for the total memory size of 34 | the host machine. 35 | Dynamic 36 | Behavior should be as dynamic as possible ("run"-time vs. 37 | "compile"-time). All decisions are delayed till runtime where 38 | possible. This involves matters like memory management, dynamic 39 | symbol binding, and late method binding. 40 | Practical 41 | PicoLisp is not just a toy of theoretical value. PicoLisp is used 42 | since 1988 in actual application development, research and 43 | production. 44 | 45 | The language inherits the major advantages of classical Lisp systems 46 | like 47 | 48 | * Dynamic data types and structures 49 | * Formal equivalence of code and data 50 | * Functional programming style 51 | * An interactive environment 52 | 53 | PicoLisp is very different from any other Lisp dialect. This is partly 54 | due to the above design principles, and partly due to its long 55 | development history since 1984. 56 | 57 | You can download the latest release version at 58 | 59 | https://software-lab.de/pil21.tgz 60 | 61 | 62 | (2) As an application server framework, PicoLisp provides for 63 | 64 | NoSQL Database Management 65 | Index trees 66 | Object local indexes 67 | Entity/Relation classes 68 | Pilog (PicoLisp Prolog) queries 69 | Multi-user synchronization 70 | DB Garbage collection 71 | Journaling, Replication 72 | User Interface 73 | Browser GUI 74 | (X)HTML/CSS 75 | XMLHttpRequest/JavaScript 76 | Application Server 77 | Process management 78 | Process family communication 79 | XML I/O 80 | Import/export 81 | User administration 82 | Internationalization 83 | Security 84 | Object linkage 85 | Postscript/Printing 86 | 87 | PicoLisp is not an IDE. All program development in Software Lab. is done 88 | using the console, bash, vip (vi-style editor) and the Lisp interpreter. 89 | 90 | The only type of GUI supported for applications is through a browser via 91 | HTML. This makes the client side completely platform independent. The 92 | GUI is created dynamically. Though it uses JavaScript and XMLHttpRequest 93 | for speed improvements, it is fully functional also without JavaScript 94 | or CSS. 95 | 96 | The GUI is deeply integrated with - and generated dynamically from - the 97 | application's data model. Because the application logic runs on the 98 | server, multiple users can view and modify the same database object 99 | without conflicts, everyone seeing changes done by other users on her 100 | screen immediately due to the internal process and database 101 | synchronization. 102 | 103 | PicoLisp is free software, and you are welcome to use and redistribute 104 | it under the conditions of the MIT/X11 License (see "COPYING"). 105 | 106 | It is based on LLVM and compiles and runs on any 64-bit POSIX system. 107 | 108 | -------------------------------------------------------------------------------- 109 | 110 | Alexander Burger 111 | Software Lab. / 7fach GmbH 112 | Bahnhofstr. 24a, D-86462 Langweid 113 | abu@software-lab.de, http://www.software-lab.de, +49 8230 5060 114 | -------------------------------------------------------------------------------- /bin/pil: -------------------------------------------------------------------------------- 1 | #!/usr/bin/picolisp /usr/lib/picolisp/lib.l 2 | (load "@lib/net.l" "@lib/misc.l" "@lib/btree.l" "@lib/db.l" "@lib/pilog.l") 3 | 4 | `*Dbg 5 | (docs "@doc/") 6 | -------------------------------------------------------------------------------- /bin/psh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/pil 2 | # 06aug24 Software Lab. Alexander Burger 3 | 4 | (load "@lib/net.l" "@lib/misc.l" "@lib/http.l") 5 | 6 | (let Arg (opt) 7 | (client "localhost" 8 | (or 9 | (format Arg) 10 | (client "localhost" 80 (pack Arg "/!psh") (read)) ) 11 | (pack (opt) "!psh?" 12 | (pw) "&" 13 | (in '("tty") (line T)) "&" 14 | (sys "TERM") ) 15 | (ctty (read)) 16 | (line) 17 | (line) ) ) 18 | (bye) 19 | -------------------------------------------------------------------------------- /bin/pty: -------------------------------------------------------------------------------- 1 | #!/usr/bin/pil 2 | # 05jul24abu 3 | # Pseudo Terminal (PilBox) 4 | # pty [host] [flg] 5 | 6 | (load "@lib/term.l") 7 | 8 | (setq 9 | *Host (or (opt) "localhost") 10 | *Port 8081 ) # Sync with ~/Port in PilBox 11 | 12 | (unless (setq *Sock (connect *Host (inc *Port))) 13 | (bye) ) 14 | 15 | (out *Sock 16 | (in "~/.pty" (echo)) # Sync with ~/.pty in PilBox 17 | (prinl) ) 18 | (in *Sock (rd 2)) # Skip "\r\n" 19 | 20 | (finish (prinl)) 21 | 22 | (de sendCmd @ 23 | (udp *Host `(inc *Port) 24 | (cons (in "~/.pty" (line T)) (rest)) ) ) 25 | 26 | (unless (opt) 27 | (task (port (+ *Port 2)) 28 | (let? S (accept @) 29 | (catch '(NIL) 30 | (in S 31 | (when (= (rd) (in "~/.pty" (line T))) 32 | (let Z (tmp "pty.zip") 33 | (casq (rd) 34 | (+ 35 | (apply call (rd) "zip" "-r" Z) 36 | (in Z (out S (echo))) ) 37 | (- 38 | (out Z (echo)) 39 | (call "unzip" "-o" Z) ) ) ) ) ) 40 | (off *Msg) ) 41 | (close S) 42 | (and *Msg (prinl @)) ) ) ) 43 | 44 | (when (getTerm) 45 | (sendCmd 46 | (cons 'setTerm (sys "TERM") @) 47 | '(off *Err) ) 48 | (de *Winch 49 | (sendCmd (cons 'setTerm (sys "TERM") (getTerm))) ) ) 50 | 51 | (raw T) 52 | (call "stty" "intr" NIL) 53 | 54 | (task *Sock 55 | (in @ 56 | (ifn (rd 1) 57 | (bye) 58 | (wr @) 59 | (flush) ) ) ) 60 | 61 | (loop 62 | (and (key) (out *Sock (prin @))) ) 63 | -------------------------------------------------------------------------------- /bin/vip: -------------------------------------------------------------------------------- 1 | #!/usr/bin/picolisp /usr/lib/picolisp/lib.l 2 | # 26feb25abu 3 | 4 | (unless *Dbg 5 | (load "@lib/vip.l") ) 6 | 7 | (stack 1024) 8 | 9 | (bye 10 | (if 11 | (vip~vi ## [+ | +[]] [+[]] .. 12 | (make 13 | (while (opt) 14 | (let (S @ L (chop S)) 15 | (cond 16 | ((pre? "+" S) 17 | (link 18 | (ifn (get (any (cdr L)) '*Dbg 1) 19 | (cons 20 | (cond 21 | ((= "+" S) T) 22 | ((format S) @) 23 | (T (cdr L)) ) 24 | (opt) ) 25 | (symbols (cddr @)) 26 | (cons (car @) (cadr @)) ) ) ) 27 | ((pre? "-" S) (load S)) 28 | (T (link S)) ) ) ) ) ) 29 | 0 30 | 1 ) ) 31 | -------------------------------------------------------------------------------- /bin/watchdog: -------------------------------------------------------------------------------- 1 | #!/usr/bin/pil 2 | # 13apr23 Software Lab. Alexander Burger 3 | # Use: bin/watchdog .. 4 | 5 | (load "@lib/misc.l") 6 | 7 | # *MailHost *MailPort *MailFrom *MailTo *Watch 8 | 9 | (argv *MailHost *MailPort *MailFrom . *MailTo) 10 | (setq *MailPort (format *MailPort)) 11 | 12 | (unless (call 'test "-p" "fifo/beat") 13 | (call 'mkdir "-p" "fifo") 14 | (call 'rm "-f" "fifo/beat") 15 | (call 'mkfifo "fifo/beat") ) 16 | 17 | (finish (call 'rm "fifo/beat")) 18 | 19 | (de *Err 20 | (prin (stamp)) 21 | (space) 22 | (println *Watch) ) 23 | 24 | (task (open "fifo/beat") 25 | (in @ 26 | (let X (rd) 27 | (cond 28 | ((not X) (bye)) 29 | ((num? X) 30 | (let? W (assoc X *Watch) 31 | (when (caddr W) 32 | (msg (car W) " " (stamp) " bye") ) 33 | (del W '*Watch) ) ) 34 | ((atom X) # bin/picolisp -"out 'fifo/beat (pr '$(tty))" -bye 35 | (let D (+ (* 86400 (date T)) (time T)) 36 | (out X 37 | (for W *Watch 38 | (prinl 39 | (align 7 (car W)) 40 | " " 41 | (- (cadr W) D) 42 | " " 43 | (or (caddr W) "o") 44 | " " 45 | (cdddr W) ) ) ) ) ) 46 | ((assoc (car X) *Watch) # X = (Pid Tim . Any) 47 | (let W @ # W = (Pid Tim Flg . Any) 48 | (when (caddr W) 49 | (msg (car W) " " (stamp) " resumed") ) 50 | (set (cdr W) (cadr X)) 51 | (set (cddr W)) 52 | (con (cddr W) (or (cddr X) (cdddr W))) ) ) 53 | (T (push '*Watch (list (car X) (cadr X) NIL (cddr X)))) ) ) ) ) 54 | 55 | (task -54321 54321 56 | (let D (+ (* 86400 (date T)) (time T)) 57 | (for W *Watch 58 | (cond 59 | ((>= (cadr W) D)) 60 | ((caddr W) 61 | (msg (car W) " " (stamp) 62 | (if (kill (car W) 15) " killed" " gone") ) 63 | (del W '*Watch) ) 64 | (T 65 | (inc (cdr W) 3600) 66 | (set (cddr W) T) 67 | (let Sub (pack "Timeout " (car W) " " (cdddr W)) 68 | (msg (car W) " " (stamp)) 69 | (unless (mail *MailHost *MailPort *MailFrom *MailTo Sub) 70 | (msg (cons Sub *MailTo) " mail failed " (stamp)) ) ) ) ) ) ) ) 71 | 72 | (wait) 73 | -------------------------------------------------------------------------------- /doc/Tracks: -------------------------------------------------------------------------------- 1 | # VIP @lib/vip/draw.l 2 | # 25may23 Software Lab. Alexander Burger 3 | 4 | (label 1 1 "Connectors:") 5 | 6 | (cells 7 6 '(| | | . |)) 7 | (go 1 3 "-") 8 | (right 9 "+") 9 | (down 2 "v") 10 | (go 10 8 "+") 11 | (down 8 "v") 12 | (go 28 6 "+") 13 | (up 3 "+") 14 | (right 14 ">") 15 | (go 46 6 "+") 16 | (up 3 "+") 17 | (right 30 ">") 18 | 19 | (box 7 17 13 6 "Track" 20 | (label 1 1 "- a") 21 | (label 10 1 "b -") 22 | (label 2 5 "x") 23 | (label 11 5 "y") ) 24 | (go 7 18 "+") 25 | (left 4 "+") 26 | (up 11 "+") 27 | (right 3 ">") 28 | (go 20 18 "+") 29 | (right 4 ">") 30 | 31 | (cells 25 17 '(| | | . |)) 32 | (go 28 17 "+") 33 | (up 3 "+") 34 | (left 11 "+") 35 | (down 2 "v") 36 | (go 76 22 "-") 37 | (left 48 "+") 38 | (up 2 "\^") 39 | (go 46 19 "+") 40 | (down 6 "+") 41 | (left 45 "<") 42 | (go 64 19 "+") 43 | (down 6 "+") 44 | (left 14 "<") 45 | 46 | (go 70 17 "+") 47 | (up 6 "+") 48 | (left 58 "+") 49 | (up 2 "\^") 50 | (go 52 8 "+") 51 | (down 6 "+") 52 | (left 22 "+") 53 | (down 2 "v") 54 | -------------------------------------------------------------------------------- /doc/doc.css: -------------------------------------------------------------------------------- 1 | /* 22oct23 Software Lab. Alexander Burger 2 | * 06dec12jk 3 | */ 4 | 5 | html { 6 | background-color: #ddd; 7 | } 8 | 9 | body { 10 | margin: auto; 11 | max-width: 50em; 12 | border: 1px solid #bbb; 13 | background-color: white; 14 | padding: 2em 7% 4em 10%; 15 | } 16 | 17 | h5 { 18 | font-size: 95%; 19 | margin-bottom: 1em; 20 | } 21 | 22 | dt { 23 | margin: 0.4em -2em 0 0; 24 | font-weight: 600; 25 | color: #444; 26 | } 27 | 28 | dd { 29 | margin-top: 0.3em; 30 | margin-bottom: 0.4em; 31 | } 32 | 33 | code, pre { 34 | color: rgb(0%,40%,0%); 35 | } 36 | 37 | dt code { 38 | word-spacing: -0.04em; 39 | } 40 | -------------------------------------------------------------------------------- /doc/man.html: -------------------------------------------------------------------------------- 1 | Content-type: text/html; charset=UTF-8 2 | 3 | 4 | Man page of PICOLISP 5 | 6 |

PICOLISP

7 | Section: User Commands (1)
Updated:
Index 8 | Return to Main Contents
9 | 10 |   11 |

NAME

12 | 13 | pil, picolisp - a fast, lightweight Lisp interpreter 14 |   15 |

SYNOPSIS

16 | 17 | pil 18 | 19 | [arguments ...] [-] [arguments ...] [+] 20 |
21 | 22 | picolisp 23 | 24 | [arguments ...] [-] [arguments ...] [+] 25 |   26 |

DESCRIPTION

27 | 28 | PicoLisp 29 | 30 | is a Lisp interpreter with a small memory footprint, yet relatively high 31 | execution speed. It combines an elegant and powerful language with built-in 32 | database functionality. 33 |

34 | 35 | pil 36 | 37 | is the startup front-end for the interpreter. It takes care of starting the 38 | binary base system and loading a useful runtime environment. 39 |

40 | 41 | picolisp 42 | 43 | is just the bare interpreter binary. It is usually called in stand-alone 44 | scripts, using the she-bang notation in the first line, passing the minimal 45 | environment in 46 | lib.l 47 | 48 | and loading additional files as needed: 49 |

50 | 51 |

52 | #!/usr/bin/picolisp /usr/lib/picolisp/lib.l 53 |
54 | 55 |
56 | (load "@ext.l" "myfiles/lib.l" "myfiles/foo.l") 57 |
58 | 59 |
60 | (do ... something ...) 61 |
62 | 63 |
64 | (bye) 65 |
66 | 67 |   68 |

INVOCATION

69 | 70 | PicoLisp 71 | 72 | has no pre-defined command line flags; applications are free to define their 73 | own. Any built-in or user-level Lisp function can be invoked from the command 74 | line by prefixing it with a hyphen. Examples for built-in functions useful in 75 | this context are 76 | version 77 | 78 | (print the version number) or 79 | bye 80 | 81 | (exit the interpreter). Therefore, a minimal call to print the version number 82 | and then immediately exit the interpreter would be: 83 |

84 | 85 |

86 | $ pil -version -bye 87 |
88 | 89 |

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

95 | 96 | All arguments are evaluated from left to right, then an interactive 97 | read-eval-print 98 | 99 | loop is entered (with a colon as prompt). 100 |

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

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

110 | 111 |

112 | $ pil + 113 |
114 | 115 |

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

120 | 121 |

122 | : (doc) 123 |
124 | 125 |

126 | 127 | and the online documentation for most functions, 128 |

129 | 130 |

131 | : (doc 'vi) 132 |
133 | 134 |

135 | 136 | or directly inspect their sources: 137 |

138 | 139 |

140 | : (vi 'doc) 141 |
142 | 143 |

144 | 145 | The interpreter can be terminated with 146 |

147 | 148 |

149 | : (bye) 150 |
151 | 152 |

153 | 154 | or by typing Ctrl-D. 155 |   156 |

FILES

157 | 158 | Runtime files are maintained in the ~/.pil directory: 159 |
160 |
~/.pil/tmp/<pid>/
161 | Process-local temporary directories 162 |
~/.pil/rc
163 | Loaded after interpreter startup 164 |
~/.pil/viprc
165 | Loaded by the Vip editor 166 |
167 |   168 |

BUGS

169 | 170 | PicoLisp 171 | 172 | doesn't try to protect you from every possible programming error ("You asked for 173 | it, you got it"). 174 |   175 |

AUTHOR

176 | 177 | Alexander Burger <abu@software-lab.de> 178 |   179 |

RESOURCES

180 | 181 | Home page: 182 | 183 | http://home.picolisp.com 184 |
185 | 186 | Download: 187 | 188 | http://www.software-lab.de/down.html 189 |

190 | 191 |

192 |  

Index

193 |
194 |
NAME
195 |
SYNOPSIS
196 |
DESCRIPTION
197 |
INVOCATION
198 |
FILES
199 |
BUGS
200 |
AUTHOR
201 |
RESOURCES
202 |
203 |
204 | This document was created by 205 | man2html, 206 | using the manual pages.
207 | Time: 08:01:21 GMT, March 29, 2021 208 | 209 | 210 | -------------------------------------------------------------------------------- /doc/microTemplates: -------------------------------------------------------------------------------- 1 | Micro-Templates 2 | 3 | * Each template file in the @lib/xhtml/ directory applies to one type of 4 | component in the @lib/xhtml.l functions. 5 | 6 | * The template files are line oriented. One micro-template per line. 7 | 8 | * A micro-template can be continued on the following line(s) by 9 | indenting these lines with space(s). 10 | 11 | * Each line has a defined meaning. Except for indented lines, no lines 12 | can be added or removed. 13 | 14 | * A micro-template may contain either variables or expressions enclosed 15 | by "¦" (broken bar character, hex "00A6"). 16 | 17 | * An empty line is denoted by "<>". 18 | 19 | * "~" is replaced at runtime with the session ID. 20 | 21 | * At program start, all templates from @lib/xhtml/ are loaded. 22 | 23 | * The application may override one or more files in a local directory, 24 | and call 'xhtml' with that path. Also more than once. 25 | 26 | * Available templates: 27 | 28 | html 29 | 1. DOCTYPE 30 | 2. HTML start 31 | 3. HEAD 32 | 4. BODY 33 | 5. HTML end 34 | 35 | table 36 | 1. Table start 37 | 2. Caption 38 | 3. Header row start 39 | 4. Header row entry 40 | 5. Header row end 41 | 6. Data row start 42 | 7. Data row entry 43 | 8. Data row end 44 | 9. Table end 45 | 46 | grid 47 | 1. Grid start 48 | 2. Grid row start 49 | 3. Grid row entry 50 | 4. Grid row end 51 | 5. Grid end 52 | 53 | layout 54 | Variable number of lines, one per code block 55 | 56 | menu 57 | 1. Menu start 58 | 2. Submenu start 59 | 3. Plain HTML 60 | 4. Disabled link 61 | 5. Enabled link 62 | 6. Enabled active link 63 | 7. Closed submenu 64 | 8. Open submenu start 65 | 9. Open submenu end 66 | 10. Submenu end 67 | 11. Menu end 68 | 69 | tab 70 | 1. TABLE start 71 | 2. Disabled entry 72 | 3. Enabled entry 73 | 4. TABLE end 74 | 75 | input 76 | 1. (Non-text) Input element 77 | 78 | field 79 | 1. Text input element 80 | 81 | area 82 | 1. TEXTAREA start 83 | 2. TEXTAREA end 84 | 85 | select 86 | 1. SELECT start 87 | 2. OPTION 88 | 3. SELECT end 89 | 90 | submit 91 | 1. Submit input element 92 | -------------------------------------------------------------------------------- /doc/rc.sample: -------------------------------------------------------------------------------- 1 | # 20nov24 Software Lab. Alexander Burger 2 | # Copy to ~/.pil/rc 3 | 4 | (history 5 | (make 6 | (skip "#") 7 | (while (line T) (link @)) # Global history 8 | (while (read) (eval @)) # Initial commands 9 | (when (info ".pilrc") # Local history and commands 10 | (in @@ 11 | (skip "#") 12 | (while (line T) (link @)) 13 | (while (read) (eval @)) ) ) ) ) 14 | 15 | # Initial history 16 | (stack) 17 | (gc 1200) (dbCheck) 18 | (show (; *FormLst 1 2)) 19 | (vi (; *FormLst 1 2 *Dbg 1 -1)) 20 | (show (; *FormLst 1 2 obj)) 21 | 22 | # Initial commands 23 | (de x () 24 | (load "x.l") ) 25 | -------------------------------------------------------------------------------- /doc/refJ.html: -------------------------------------------------------------------------------- 1 | 5 | 6 | 7 | 8 | 9 | 10 | J 11 | 12 | 13 | 14 | 15 |

J

16 | 17 |
18 | 19 |
+Joint
20 |
Class for bidirectional object relations, a subclass of +Link. Expects a (symbolic) attribute, a list 22 | of classes as type of the referred 23 | database object (of class +Entity), 24 | and two optional functions called when 'put'ting and/or 'get'ting a value. A 25 | +Joint corresponds to two +Links, where the attribute 26 | argument is the relation of the back-link in the referred object. See also Database. 28 | 29 | 
30 | (class +Ord +Entity)                   # Order class
31 | (rel pos (+List +Joint) ord (+Pos))    # List of positions in that order
32 | ...
33 | (class +Pos +Entity)                   # Position class
34 | (rel ord (+Joint) pos (+Ord))          # Back-link to the parent order
35 |
36 | 37 |
(job 'lst . prg) -> any
38 |
Executes a job within its own environment (as specified by symbol-value 39 | pairs in lst). The current values of all symbols are saved, the 40 | symbols are bound to the values in lst, prg is 41 | executed, then the (possibly modified) symbol values are (destructively) stored 42 | in the environment list, and the symbols are restored to their original values. 43 | The return value is the result of prg. Typically used in curried functions and *Run tasks. See also env, bind, let, use and state. 51 | 52 | 
53 | : (de tst ()
54 |    (job '((A . 0) (B . 0))
55 |       (println (inc 'A) (inc 'B 2)) ) )
56 | -> tst
57 | : (tst)
58 | 1 2
59 | -> 2
60 | : (tst)
61 | 2 4
62 | -> 4
63 | : (tst)
64 | 3 6
65 | -> 6
66 | : (pp 'tst)
67 | (de tst NIL
68 |    (job '((A . 3) (B . 6))
69 |       (println (inc 'A) (inc 'B 2)) ) )
70 | -> tst
71 |
72 | 73 |
(journal ['T] 'any ..) -> T
74 |
Reads journal data from the files with the names any, and 75 | writes all changes to the database. If the first argument is T, the 76 | replication journal and transaction logs are disabled. See also pool. 78 | 79 | 
80 | : (journal "db.log")
81 | -> T
82 |
83 | 84 |
85 | 86 | 87 | 88 | -------------------------------------------------------------------------------- /doc/refK.html: -------------------------------------------------------------------------------- 1 | 5 | 6 | 7 | 8 | 9 | 10 | K 11 | 12 | 13 | 14 | 15 |

K

16 | 17 |
18 | 19 |
+Key
20 |
Prefix class for maintaining unique indexes to +relations, a subclass of +index. Accepts an optional argument for a 23 | +Hook attribute. See also Database. 25 | 26 | 
27 | (rel nr (+Need +Key +Number))  # Mandatory, unique Customer/Supplier number
28 |
29 | 30 |
(key ['cnt ['var]]) -> sym
31 |
Returns the next character from standard input as a single-character 32 | transient symbol. The console is set to raw mode. While waiting for a key press, 33 | a poll(2) system call is executed for all file descriptors and 34 | timers in the VAL of the global variable *Run. If cnt is 36 | non-NIL, that amount of milliseconds is waited maximally, and 37 | NIL is returned upon timeout. Otherwise, the remaining milliseconds 38 | are optionally stored in var. See also raw and wait. 41 | 42 | 
43 | : (key)           # Wait for a key
44 | -> "a"            # 'a' pressed
45 |
46 | 47 |
(kids) -> lst
48 |
Returns a list of process IDs of all running child processes. See also 49 | fork, detach, pipe, tell, proc and kill. 55 | 56 | 
57 | : (unless (fork) (wait 60000) (bye))
58 | -> NIL
59 | : (unless (fork) (wait 60000) (bye))
60 | -> NIL
61 | 
62 | : (proc 'pil)
63 |   PID  PPID  STARTED  SIZE %CPU WCHAN  CMD
64 |  2205 22853 19:45:24  1336  0.1 -      /usr/bin/picolisp /usr/lib/picolisp/lib.l /usr/bin/pil +
65 |  2266  2205 19:45:30  1336  0.0 -        /usr/bin/picolisp /usr/lib/picolisp/lib.l /usr/bin/pil +
66 |  2300  2205 19:45:33  1336  0.0 -        /usr/bin/picolisp /usr/lib/picolisp/lib.l /usr/bin/pil +
67 | -> T
68 | 
69 | : (kids)
70 | -> (2300 2266)
71 |
72 | 73 |
(kill 'pid ['cnt]) -> flg
74 |
Sends a signal with the signal number cnt (or SIGTERM if 75 | cnt is not given) to the process with the ID pid. 76 | Returns T if successful. 77 | 78 | 
79 | : (kill *Pid 20)                                # Stop current process
80 | 
81 | [2]+  Stopped               pil +               # Unix shell
82 | $ fg                                            # Job control: Foreground
83 | pil +
84 | -> T                                            # 'kill' was successful
85 |
86 | 87 |
88 | 89 | 90 | 91 | -------------------------------------------------------------------------------- /doc/refQ.html: -------------------------------------------------------------------------------- 1 | 5 | 6 | 7 | 8 | 9 | 10 | Q 11 | 12 | 13 | 14 | 15 |

Q

16 | 17 |
18 | 19 |
(qsym . sym) -> lst
20 |
Returns a cons pair of the value and property list of sym. See 21 | also quote, val and getl. 24 | 25 | 
 26 | : (setq A 1234)
 27 | -> 1234
 28 | : (put 'A 'a 1)
 29 | -> 1
 30 | : (put 'A 'b 2)
 31 | -> 2
 32 | : (put 'A 'f T)
 33 | -> T
 34 | : (qsym . A)
 35 | -> (1234 f (2 . b) (1 . a))
 36 |
37 | 38 |
(quote . any) -> any
39 |
Returns any unevaluated. The reader recognizes the single quote 40 | char ' as a macro for this function. See also lit. 42 | 43 | 
 44 | : 'a
 45 | -> a
 46 | : '(foo a b c)
 47 | -> (foo a b c)
 48 | : (quote (quote (quote a)))
 49 | -> ('('(a)))
 50 |
51 | 52 |
(query 'lst ['lst]) -> flg
53 |
Handles an interactive Pilog query. The two 54 | lst arguments are passed to prove. query displays each 56 | result, waits for a key, and terminates when ESC is pressed. See also ?, pilog and solve. 60 | 61 | 
 62 | : (query (goal '((append @X @Y (a b c)))))
 63 |  @X=NIL @Y=(a b c)
 64 |  @X=(a) @Y=(b c)
 65 |  @X=(a b) @Y=(c)
 66 |  @X=(a b c) @Y=NIL
 67 | -> NIL
 68 |
69 | 70 |
(queue 'var 'any) -> any
71 |
Implements a queue using a list in var. The any 72 | argument is (destructively) concatenated to the end of the value list. See also 73 | push, pop, rid and fifo. 77 | 78 | 
 79 | : (queue 'A 1)
 80 | -> 1
 81 | : (queue 'A 2)
 82 | -> 2
 83 | : (queue 'A 3)
 84 | -> 3
 85 | : A
 86 | -> (1 2 3)
 87 | : (pop 'A)
 88 | -> 1
 89 | : A
 90 | -> (2 3)
 91 |
92 | 93 |
(quit ['any ['any]])
94 |
Stops current execution. If no arguments are given, all pending finally expressions are executed and control 96 | is returned to the top level read-eval-print loop. Otherwise, an error handler 97 | is entered. The first argument can be some error message, and the second might 98 | be the reason for the error. See also Error 99 | Handling. 100 | 101 | 
102 | : (de foo (X) (quit "Sorry, my error" X))
103 | -> foo
104 | : (foo 123)                                  # 'X' is bound to '123'
105 | 123 -- Sorry, my error                       # Error entered
106 | ? X                                          # Inspect 'X'
107 | -> 123
108 | ?                                            # Empty line: Exit
109 | :
110 |
111 | 112 |
113 | 114 | 115 | 116 | -------------------------------------------------------------------------------- /doc/refV.html: -------------------------------------------------------------------------------- 1 | 5 | 6 | 7 | 8 | 9 | 10 | V 11 | 12 | 13 | 14 | 15 |

V

16 | 17 |
18 | 19 |
(val 'var) -> any
20 |
Returns the current value of var. See also setq, set and def. 24 | 25 | 
 26 | : (setq L '(a b c))
 27 | -> (a b c)
 28 | : (val 'L)
 29 | -> (a b c)
 30 | : (val (cdr L))
 31 | -> b
 32 |
33 | 34 |
val/3
35 |
(Deprecated since version 25.5.30) Pilog predicate that returns the value of an 37 | object's attribute. Typically used in database queries. The first 38 | argument is a Pilog variable to bind the value, the second is the 39 | object, and the third and following arguments are used to apply the 40 | get algorithm to that object. 41 | See also db/3 and select/3. 43 | 44 | 
 45 | : (?
 46 |    (db nr +Item (2 . 5) @Item)   # Fetch articles 2 through 5
 47 |    (val @Nm @Item nm)            # Get item description
 48 |    (val @Sup @Item sup nm) )     # and supplier's name
 49 |  @Item={B2} @Nm="Spare Part" @Sup="Seven Oaks Ltd."
 50 |  @Item={B3} @Nm="Auxiliary Construction" @Sup="Active Parts Inc."
 51 |  @Item={B4} @Nm="Enhancement Additive" @Sup="Seven Oaks Ltd."
 52 |  @Item={B5} @Nm="Metal Fittings" @Sup="Active Parts Inc."
 53 | -> NIL
 54 |
55 | 56 |
(var sym . any) -> any
57 |
(var (sym . cls) . any) -> any
58 |
Defines a class variable sym with the initial value 59 | any for the current class, implicitly given by the value of the 60 | global variable *Class, or - in the 61 | second form - for the explicitly given class cls. See also OO Concepts, rel and var:. 65 | 66 | 
 67 | : (class +A)
 68 | -> +A
 69 | : (var a . 1)
 70 | -> 1
 71 | : (var b . 2)
 72 | -> 2
 73 | : (show '+A)
 74 | +A NIL
 75 |    b 2
 76 |    a 1
 77 | -> +A
 78 |
79 | 80 |
(var: sym) -> any
81 |
Fetches the value of a class variable sym for the current 82 | object This, by searching the property 83 | lists of its class(es) and superclasses. See also OO 84 | Concepts, var, with, meta, :, 87 | =: and ::. 89 | 90 | 
 91 | : (class +A)
 92 | -> +A
 93 | : (var a . 1)
 94 | -> 1
 95 | : (var b . 2)
 96 | -> 2
 97 | : (object 'O '(+A) 'a 9 'b 8)
 98 | -> O
 99 | : (with 'O (list (: a) (: b) (var: a) (var: b)))
100 | -> (9 8 1 2)
101 |
102 | 103 |
(version ['flg]) -> lst
104 |
(version 'lst) -> lst
105 |
Prints the current version as a string of dot-separated numbers, and returns 106 | the current version as a list of numbers. When flg is non-NIL, 107 | printing is suppressed. The second form checks for the required version in 108 | lst and throws an error if the current version is too old. See also 109 | *CPU and *OS. 111 | 112 | 
113 | $ pil -version
114 | 25.5.8
115 | 
116 | : (version T)
117 | -> (25 5 8)
118 | : (version)
119 | 25.5.8
120 | -> (25 5 8)
121 | 
122 | : (version (25 5 9))
123 | !? (version (25 5 9))
124 | (25 5 8) -- Inadequate PicoLisp version
125 | ?
126 |
127 | 128 |
(vi 'sym) -> sym | NIL
129 |
(vi 'sym 'cls) -> sym | NIL
130 |
(vi 'lst) -> lst | NIL
131 |
(v . lst) -> lst | NIL
132 |
(v) -> NIL
133 |
(Debug mode only) Opens the Vip editor on the function or method definition 134 | of sym (source file or direct path name), or on a list of symbols 135 | lst (in-memory). (v) resumes a Vip session suspended 136 | with "qz". See also doc, *Dbg, debug and pp. 140 | 141 | 
142 | : (vi 'put> '+Entity)  # Edit the method's source code
143 | : (v {1})  # In-memory-edit the database root object
144 | -> put>
145 |
146 | 147 |
(view 'lst ['T]) -> any
148 |
Views lst as tree-structured ASCII graphics. When the 149 | T argument is given, lst should be a binary tree 150 | structure (as generated by idx), which 151 | is then shown as a left-rotated tree. See also pretty and show. 154 | 155 | 
156 | : (balance 'I '(a b c d e f g h i j k l m n o))
157 | -> NIL
158 | : I
159 | -> (h (d (b (a) c) f (e) g) l (j (i) k) n (m) o)
160 | 
161 | : (view I)
162 | +-- h
163 | |
164 | +---+-- d
165 | |   |
166 | |   +---+-- b
167 | |   |   |
168 | |   |   +---+-- a
169 | |   |   |
170 | |   |   +-- c
171 | |   |
172 | |   +-- f
173 | |   |
174 | |   +---+-- e
175 | |   |
176 | |   +-- g
177 | |
178 | +-- l
179 | |
180 | +---+-- j
181 | |   |
182 | |   +---+-- i
183 | |   |
184 | |   +-- k
185 | |
186 | +-- n
187 | |
188 | +---+-- m
189 | |
190 | +-- o
191 | -> NIL
192 | 
193 | : (view I T)
194 |          o
195 |       n
196 |          m
197 |    l
198 |          k
199 |       j
200 |          i
201 | h
202 |          g
203 |       f
204 |          e
205 |    d
206 |          c
207 |       b
208 |          a
209 | -> NIL
210 |
211 | 212 |
213 | 214 | 215 | 216 | -------------------------------------------------------------------------------- /doc/refX.html: -------------------------------------------------------------------------------- 1 | 5 | 6 | 7 | 8 | 9 | 10 | X 11 | 12 | 13 | 14 | 15 |

X

16 | 17 |
18 | 19 |
(xchg 'var 'var ..) -> any
20 |
Exchange the values of successive var argument pairs. See also 21 | swap and set. 23 | 24 | 
25 | : (setq  A 1  B 2  C '(a b c))
26 | -> (a b c)
27 | : (xchg  'A C  'B (cdr C))
28 | -> 2
29 | : A
30 | -> a
31 | : B
32 | -> b
33 | : C
34 | -> (1 2 c)
35 |
36 | 37 |
(xor 'any 'any) -> flg
38 |
Returns T if exactly one of the arguments evaluates to non-NIL. 39 | 40 | 
41 | : (xor T NIL)
42 | -> T
43 | : (xor T T)
44 | -> NIL
45 |
46 | 47 |
(x| 'num ..) -> num
48 |
Returns the bitwise XOR of all num arguments. When 49 | one of the arguments evaluates to NIL, it is returned immediately. 50 | See also &, | and bit?. 53 | 54 | 
55 | : (x| 2 7)
56 | -> 5
57 | : (x| 2 7 1)
58 | -> 4
59 |
60 | 61 |
62 | 63 | 64 | 65 | -------------------------------------------------------------------------------- /doc/refY.html: -------------------------------------------------------------------------------- 1 | 5 | 6 | 7 | 8 | 9 | 10 | Y 11 | 12 | 13 | 14 | 15 |

Y

16 | 17 |
18 | 19 |
(yield 'any ['any2]) -> any
20 |
Transfers control from the current coroutine back to the caller (when the 22 | any2 tag is not given), or to some other coroutine (specified by 23 | any2) to continue execution at the point where that coroutine had 24 | called yield before. In the first case, the value any 25 | will be returned from the corresponding co call, in the second case it will be the return 27 | value of that yield call. See also stack, catch and throw. 31 | 32 | 
33 | : (co "rt1"                            # Start first routine
34 |    (msg (yield 1) " in rt1 from rt2")  # Return '1', wait for value from "rt2"
35 |    7 )                                 # Then return '7'
36 | -> 1
37 | 
38 | : (co "rt2"                            # Start second routine
39 |    (yield 2 "rt1") )                   # Send '2' to "rt1"
40 | 2 in rt1 from rt2
41 | -> 7
42 |
43 | 44 |
(yoke 'any ..) -> any
45 |
Inserts one or several new elements any in front of the list in 46 | the current make environment. 47 | yoke returns the last inserted argument. See also link, chain and made. 51 | 52 | 
53 | : (make (link 2 3) (yoke 1) (link 4))
54 | -> (1 2 3 4)
55 |
56 | 57 |
58 | 59 | 60 | 61 | -------------------------------------------------------------------------------- /doc/refZ.html: -------------------------------------------------------------------------------- 1 | 5 | 6 | 7 | 8 | 9 | 10 | Z 11 | 12 | 13 | 14 | 15 |

Z

16 | 17 |
18 | 19 |
*Zap
20 |
A global variable holding a list and a pathname. If given, and the value of 21 | *Solo is NIL, external 22 | symbols which are no longer accessible can be collected in the CAR, e.g. during 23 | DB tree processing, and written to the file in the CDR at the next commit. A (typically periodic) call to 25 | zap_ will clean them up later. 26 | 27 | 
 28 | : (setq *Zap '(NIL . "db/app/_zap"))
 29 | -> (NIL . "db/app/_zap")
 30 |
31 | 32 |
(zap 'sym) -> sym
33 |
"Delete" the symbol sym. For internal symbols, that means to 34 | remove it from the current namespace, effectively transforming it to a transient 35 | symbol. For external symbols, it means to mark it as "deleted", so that upon a 36 | later commit it will be removed from 37 | the database file. See also intern. 38 | 39 | 
 40 | : (de foo (Lst) (car Lst))          # 'foo' calls 'car'
 41 | -> foo
 42 | : (zap 'car)                        # Delete the symbol 'car'
 43 | -> "car"
 44 | : (pp 'foo)
 45 | (de foo (Lst)
 46 |    ("car" Lst) )                    # 'car' is now a transient symbol
 47 | -> foo
 48 | : (foo (1 2 3))                     # 'foo' still works
 49 | -> 1
 50 | : (car (1 2 3))                     # Reader returns a new 'car' symbol
 51 | !? (car (1 2 3))
 52 | car -- Undefined
 53 | ?
 54 |
55 | 56 |
(zapTree 'sym)
57 |
Recursively deletes a tree structure from the database. See also tree, chkTree and prune. 61 | 62 | 
 63 | : (zapTree (cdr (root (tree 'nm '+Item))))
 64 |
65 | 66 |
(zap_)
67 |
Delayed deletion (with zap) of 68 | external symbols which were collected e.g. during DB tree processing. An 69 | auxiliary file (with the name taken from the CDR of the value of *Zap, concatenated with a "_" 71 | character) is used as an intermediary file. 72 | 73 | 
 74 | : *Zap
 75 | -> (NIL . "db/app/Z")
 76 | : (call 'ls "-l" "db/app")
 77 | ...
 78 | -rw-r--r-- 1 abu abu     1536 2007-06-23 12:34 Z
 79 | -rw-r--r-- 1 abu abu     1280 2007-05-23 12:15 Z_
 80 | ...
 81 | : (zap_)
 82 | ...
 83 | : (call 'ls "-l" "db/app")
 84 | ...
 85 | -rw-r--r-- 1 abu abu     1536 2007-06-23 12:34 Z_
 86 | ...
 87 |
88 | 89 |
(zero var ..) -> 0
90 |
Stores 0 in all var arguments. See also one, on, 92 | off and onOff. 94 | 95 | 
 96 | : (zero A B)
 97 | -> 0
 98 | : A
 99 | -> 0
100 | : B
101 | -> 0
102 |
103 | 104 |
105 | 106 | 107 | 108 | -------------------------------------------------------------------------------- /doc/search: -------------------------------------------------------------------------------- 1 | Search criteria 2 | Numbers 3 | 3 4 | (3 . 4) 5 | Strings 6 | "abc" 7 | ("a" . "z") 8 | Objects 9 | {2} 10 | Symbols 11 | abc 12 | (a . z) 13 | 14 | Relation types 15 | Number, Date, Time 16 | (+Key +Number) 17 | 7 {2} 18 | 19 | (+Ref +Number) 20 | (7 . {2}) {2} 21 | 22 | Keywords 23 | (+Key +String) 24 | "Regen Axer" {2} 25 | 26 | (+Ref +String) 27 | ("Regen Axer" . {2}) {2} 28 | 29 | Phone numbers 30 | (+Fold +Ref +String) 31 | ("regenaxer" . {2}) {2} 32 | 33 | E-Mail addresses 34 | (+Fold +Idx +String) 35 | ("axer" {2}) {2} 36 | ("egenaxer" {2}) {2} 37 | ("enaxer" {2}) {2} 38 | ("genaxer" {2}) {2} 39 | ("naxer" {2}) {2} 40 | ("regenaxer" . {2}) {2} 41 | ("xer" {2}) {2} 42 | 43 | Personal names 44 | (+Sn +IdxFold +String) 45 | ("RSNSR" {2} . T) {2} 46 | ("Regen Axer" . {2}) {2} 47 | ("axer" {2}) {2} 48 | ("egen" {2}) {2} 49 | ("gen" {2}) {2} 50 | ("regenaxer" {2}) {2} 51 | ("xer" {2}) {2} 52 | 53 | Item names 54 | (+IdxFold +String) 55 | ("Regen Axer" . {2}) {2} 56 | ("axer" {2}) {2} 57 | ("egen" {2}) {2} 58 | ("gen" {2}) {2} 59 | ("regenaxer" {2}) {2} 60 | ("xer" {2}) {2} 61 | 62 | (+List +Fold +Ref +String) 63 | ("axer" . {2}) {2} 64 | ("regen" . {2}) {2} 65 | 66 | Identifiers 67 | (+Idx +String) 68 | ("Axer" {2}) {2} 69 | ("Regen Axer" . {2}) {2} 70 | ("egen" {2}) {2} 71 | ("gen" {2}) {2} 72 | ("xer" {2}) {2} 73 | 74 | GIS coordinates 75 | (+UB +Aux +Ref +Number) 76 | (56919522950766600 . {2}) {2} 77 | 78 | Objects 79 | (+Ref +Link) 80 | ({7} . {2}) {2} 81 | -------------------------------------------------------------------------------- /doc/viprc.sample: -------------------------------------------------------------------------------- 1 | # 05mar24 Software Lab. Alexander Burger 2 | # Copy to ~/.pil/viprc 3 | 4 | (map+q "d" ":bd\r") 5 | 6 | ## If you prefer LEFT and RIGHT to move the cursor: 7 | ## (map+ "\e[D" "h") 8 | ## (map+ "\e[C" "l") 9 | 10 | (cmd "pb1n" (L Lst Cnt) # Pastebin 11 | (pipe 12 | (out '("curl" "-F" "f=@-;" "pb1n.de") 13 | (mapc prinl (: buffer text)) ) 14 | (prCmd (rdLines)) ) ) 15 | 16 | (cmd "ix.io" (L Lst Cnt) 17 | (pipe 18 | (out '("curl" "-sF" "f:1=<-" "ix.io") 19 | (mapc prinl (: buffer text)) ) 20 | (prCmd (rdLines)) ) ) 21 | 22 | (cmd "tabs" (L Lst Cnt) 23 | (let N (or (format L) 3) 24 | (=: buffer text 25 | (mapcar 26 | '((L) 27 | (make 28 | (for (I . C) L 29 | (if (= "\t" C) 30 | (loop 31 | (link (name " ")) 32 | (T (=0 (% I N))) 33 | (inc 'I) ) 34 | (link C) ) ) ) ) 35 | (: buffer text) ) ) ) ) 36 | 37 | (cmd "words" (L Lst Cnt) 38 | (xchg 'delimNs 39 | (quote 40 | ((C) 41 | (nand C 42 | (sub? C 43 | "0123456789\ 44 | ABCDEFGHIJKLMNOPQRSTUVWXYZ\ 45 | _\ 46 | abcdefghijklmnopqrstuvwxyz" ) ) ) ) ) 47 | (prCmd 48 | (list (chop (xchg '(" C") '(" Lisp")))) ) ) 49 | 50 | (de *F7 # Find current definition 51 | (let L (nth (: buffer text) (: posY)) 52 | (prCmd 53 | (list 54 | (loop 55 | (NIL (setq L (prior L (: buffer text)))) 56 | (T (head '`(chop "(class ") (car L)) 57 | (car L) ) 58 | (T (head '`(chop "(extend ") (car L)) 59 | (car L) ) ) ) ) ) ) 60 | 61 | (de *F8 # Expression size 62 | (evCmd (size (s-expr))) ) 63 | 64 | # Timestamp 65 | (local) vipDat 66 | 67 | (de vipDat (N) 68 | (when (<> N (: posY)) 69 | (let (@L (get (: text) N) @A) 70 | (and 71 | (match '(@A " " @L) @L) 72 | (member @A '(("#") ("/" "/") ("/" "*"))) 73 | (>= 31 (format (cut 2 '@L)) 1) 74 | (member (pack (cut 3 '@L)) *mon) 75 | (format (cut 2 '@L)) 76 | (mapc set 77 | (set (nth (: text) N) 78 | (conc 79 | @A 80 | (list (char 32)) 81 | (chop (datSym (date))) 82 | @L ) ) 83 | 1 ) ) ) ) ) 84 | 85 | (daemon '(save> . +Buffer) 86 | (or (vipDat 1) (vipDat 2) (vipDat 3)) ) 87 | 88 | # Local 89 | (and (info ".viprc") (load ".viprc")) 90 | -------------------------------------------------------------------------------- /ext.l: -------------------------------------------------------------------------------- 1 | # 27oct20 Software Lab. Alexander Burger 2 | 3 | (load "@lib/net.l" "@lib/misc.l" "@lib/btree.l" "@lib/db.l" "@lib/pilog.l") 4 | 5 | `*Dbg 6 | (docs "@doc/") 7 | -------------------------------------------------------------------------------- /img/go.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/picolisp/pil21/6428739cc8979f5e63e84d016c0bc6201b7f8e70/img/go.png -------------------------------------------------------------------------------- /img/no.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/picolisp/pil21/6428739cc8979f5e63e84d016c0bc6201b7f8e70/img/no.png -------------------------------------------------------------------------------- /lib/adm.l: -------------------------------------------------------------------------------- 1 | # 30dec24 Software Lab. Alexander Burger 2 | 3 | # *Salt *Login *Users *Perms 4 | 5 | # crypt(3) algorithm, e.g. (setq *Salt (16 . "$6$@1$")) 6 | (de passwd (Str Salt) 7 | (if *Salt 8 | (native "libcrypt.so" "crypt" 'S Str (or Salt (salt))) 9 | Str ) ) 10 | 11 | (de salt () 12 | (text (cdr *Salt) (randpw (car *Salt))) ) 13 | 14 | (de randpw (Len) 15 | (make 16 | (in "/dev/urandom" 17 | (do Len 18 | (link 19 | (get 20 | '`(mapcar char 21 | (conc 22 | (range (char ".") (char "9")) 23 | (range (char "A") (char "Z")) 24 | (range (char "a") (char "z")) ) ) 25 | (inc (& 63 (rd 1))) ) ) ) ) ) ) 26 | 27 | (de auth (Nm Pw Cls) 28 | (with (db 'nm (or Cls '+User) Nm) 29 | (and 30 | (: pw 0) 31 | (= @ (passwd Pw @)) 32 | This ) ) ) 33 | 34 | ### Login ### 35 | (de login (Nm Pw Cls) 36 | (ifn (setq *Login (auth Nm Pw Cls)) 37 | (msg *Pid " ? " Nm) 38 | (msg *Pid " * " (stamp) " " Nm) 39 | (tell 'hi *Pid Nm *Adr) 40 | (push1 '*Bye '(logout)) 41 | (when *Timeout 42 | (timeout (setq *Timeout `(* 3600 1000))) ) ) 43 | *Login ) 44 | 45 | (de logout () 46 | (when *Login 47 | (rollback) 48 | (off *Login) 49 | (tell 'hi *Pid) 50 | (msg *Pid " / " (stamp)) 51 | (when *Timeout 52 | (timeout (setq *Timeout `(* 300 1000))) ) ) ) 53 | 54 | (de hi (Pid Nm Adr) 55 | (if (and Nm (= Nm (; *Login nm)) (= Adr *Adr)) 56 | (bye) 57 | (hi2 Pid Nm) 58 | (tell 'hi2 *Pid (; *Login nm)) ) ) 59 | 60 | (de hi2 (Pid Nm) 61 | (if2 Nm (lup *Users Pid) 62 | (con @ Nm) 63 | (idx '*Users (cons Pid Nm) T) 64 | (idx '*Users @ NIL) ) ) 65 | 66 | 67 | ### Role ### 68 | (class +Role +Entity) 69 | 70 | (rel nm (+Need +Key +String)) # Role name 71 | (rel perm (+List +Symbol)) # Permission list 72 | (rel usr (+List +Joint) role (+User)) # Associated users 73 | 74 | (allow "@lib/role.l") 75 | 76 | (dm url> (Tab) 77 | (and (may RoleAdmin) (list "@lib/role.l" '*ID This)) ) 78 | 79 | 80 | ### User ### 81 | (class +User +Entity) 82 | 83 | (rel nm (+Need +Key +String)) # User name 84 | (rel pw (+Swap +String)) # Password 85 | (rel role (+Joint) usr (+Role)) # User role 86 | (rel nam (+String)) # Full Name 87 | (rel tel (+String)) # Phone 88 | (rel em (+String)) # E-Mail 89 | 90 | (allow "@lib/user.l") 91 | 92 | (dm url> (Tab) 93 | (and 94 | (or (may UserAdmin) (== *Login This)) 95 | (list "@lib/user.l" '*ID This) ) ) 96 | 97 | (dm gui> (This) 98 | ( 2 99 | ,"Full Name" (gui '(+E/R +TextField) '(nam : home obj) 40) 100 | ,"Phone" (gui '(+E/R +TelField) '(tel : home obj) 40) 101 | ,"E-Mail" (gui '(+E/R +MailField) '(em : home obj) 40) ) ) 102 | 103 | (dm login> ()) 104 | 105 | 106 | ### Permission management ### 107 | (de permission Lst 108 | (while Lst 109 | (queue '*Perms (car Lst)) 110 | (def (++ Lst) (++ Lst)) ) ) 111 | 112 | (de may Args 113 | (mmeq Args (; *Login role perm)) ) 114 | 115 | (de must Args 116 | (unless 117 | (if (cdr Args) 118 | (find 119 | '((X) 120 | (if (atom X) 121 | (memq X (; *Login role perm)) 122 | (eval X) ) ) 123 | @ ) 124 | *Login ) 125 | (forbidden (car Args)) ) ) 126 | 127 | ### GUI ### 128 | (de choUser (Dst) 129 | (choDlg Dst ,"Users" '(nm +User)) ) 130 | 131 | (de loginForm "Opt" 132 | (form NIL 133 | (when "Opt" 134 | (eval (car "Opt")) 135 | (----) ) 136 | ( 2 137 | ,"Name" (gui 'nm '(+Focus +Able +TextField) '(not *Login) 20) 138 | ,"Password" (gui 'pw '(+Able +PwField) '(not *Login) 20) ) 139 | (--) 140 | (gui '(+Button) '(if *Login ,"logout" ,"login") 141 | '(cond 142 | (*Login (post (logout))) 143 | ((login (val> (: home nm)) (val> (: home pw))) 144 | (post 145 | (clr> (: home pw)) 146 | (login> *Login) ) ) 147 | (T (error ,"Permission denied")) ) ) 148 | (when *Login 149 | ( 4) 150 | ( "bold green" 151 | (ht:Prin "'" (; *Login nm) ,"' logged in") ) ) 152 | (when "Opt" 153 | (----) 154 | (htPrin (cdr "Opt")) ) ) ) 155 | 156 | (class +PasswdField +E/R +Fmt +TextField) 157 | 158 | (dm T @ 159 | (pass super 160 | '(pw : home obj) 161 | '((V) (and V "****")) 162 | '((V) 163 | (if (= V "****") 164 | (: home obj pw 0) 165 | (passwd V (: home obj pw 0)) ) ) ) ) 166 | -------------------------------------------------------------------------------- /lib/app.l: -------------------------------------------------------------------------------- 1 | # 13apr23 Software Lab. Alexander Burger 2 | 3 | # Exit on error 4 | (de *Err 5 | (prinl *Pid " ! " (stamp) " [" *Adr " " (host *Adr) "] " *Agent) 6 | (for ("L" (trail T) "L") 7 | (cond 8 | ((pair (car "L")) 9 | (let "E" (++ "L") 10 | (println 11 | (if (getd (box? (car "E"))) 12 | (cons @ (cdr "E")) 13 | "E" ) ) ) ) 14 | ((== '"L" (car "L")) 15 | (setq "L" (cddr "L")) ) 16 | (T 17 | (space 3) 18 | (println (++ "L") (++ "L")) ) ) ) 19 | (println '====) 20 | (show This) 21 | (println '*Uri (pack *Uri)) 22 | (println '*Host (pack *Host)) 23 | (for "X" '(*Port *SesId *ConId *Tab *Gui *Btn *Get *ID) 24 | (println "X" (val "X")) ) 25 | (println '*PRG *PRG (val *PRG)) 26 | (rollback) ) 27 | 28 | # User identification 29 | (de user (Pid1 Pid2 Nm To) 30 | (nond 31 | (Pid1 (tell 'user *Pid)) 32 | (Pid2 33 | (tell 'user Pid1 *Pid (get *Login 'nm) 34 | (/ (- *Timeout (cadr (assoc -1 *Run))) 60000) ) ) 35 | ((<> *Pid Pid1) (println Pid2 Nm To)) ) ) 36 | 37 | # Timestamp 38 | (msg *Pid " + " (stamp)) 39 | (flush) 40 | 41 | # Extend 'app' function 42 | (conc (last app) 43 | '((msg *Pid " + " (stamp) " [" *Adr " " (host *Adr) (and *Cipher (pack " / " @)) "] " *Agent)) ) 44 | 45 | # Bye message 46 | (push '*Fork 47 | '(finish (and *SesId (msg *Pid " - " (stamp)))) ) 48 | -------------------------------------------------------------------------------- /lib/bash_completion: -------------------------------------------------------------------------------- 1 | # Bash completion for picolisp + pil 2 | # Alexander Burger 3 | 4 | _pil() 5 | { 6 | local -a ARGS 7 | local IFS=$'\n' 8 | 9 | for A in "${COMP_WORDS[@]:1:$((COMP_CWORD-1))}" 10 | do 11 | test "${A:0:1}" = "-" || ARGS[${#ARGS[@]}]="${A//\\ / }" 12 | done 13 | COMPREPLY=($(${COMP_WORDS[0]} ${ARGS[@]} /usr/lib/picolisp/lib/complete.l "${COMP_WORDS[$COMP_CWORD]}" -bye + 2>&1)) 14 | return 0 15 | } && 16 | complete -o nospace -F _pil picolisp && 17 | complete -o nospace -F _pil pil 18 | -------------------------------------------------------------------------------- /lib/canvas.l: -------------------------------------------------------------------------------- 1 | # 19sep23 Software Lab. Alexander Burger 2 | 3 | (allow "!jsDraw" ) 4 | (push1 '*JS (allow "@lib/plio.js") (allow "@lib/canvas.js")) 5 | 6 | # Draw (drawCanvas Id Dly [T]) 7 | # Click (drawCanvas Id Dly 1 X Y) 8 | # Double (drawCanvas Id Dly 2 X Y) 9 | # Start (drawCanvas Id Dly 0 X Y X2 Y2) 10 | # Move (drawCanvas Id Dly -1 X Y X2 Y2) 11 | (de jsDraw (Id Dly F X Y X2 Y2) 12 | (http1 "application/octet-stream" 0) 13 | (let Lst (drawCanvas Id Dly F X Y X2 Y2) 14 | (prinl "Content-Length: " (bytes Lst) "\r\n\r") 15 | (pr Lst) ) ) 16 | 17 | # Canvas Commands 18 | (for (Opc . L) 19 | (quote # In sync with "@lib/canvas.js" 20 | ### Functions ### 21 | (csFont Str) 22 | (csFillText Str X Y) 23 | (csStrokeLine X1 Y1 X2 Y2) 24 | (csClearRect X Y DX DY) 25 | (csStrokeRect X Y DX DY) 26 | (csFillRect X Y DX DY) 27 | (csBeginPath) 28 | (csClosePath) 29 | (csMoveTo X Y) 30 | (csLineTo X Y) 31 | (csBezierCurveTo X1 Y1 X2 Y2 X Y) 32 | (csQuadraticCurveTo X1 Y1 X2 Y2) 33 | (csLine X1 Y1 X2 Y2) 34 | (csRect X Y DX DY) 35 | (csArc X Y R A B F) 36 | (csStroke) 37 | (csFill) 38 | (csClip) 39 | (csDef Key DX DY Lst) 40 | (csDraw Key X Y) 41 | (csDrawDots DX DY Lst) 42 | (csDrawImage Img X Y Lst DX DY Key) 43 | (csTranslate X Y) 44 | (csRotate A) 45 | (csScale X Y) 46 | (csSave) 47 | (csRestore) 48 | ### Variables ### 49 | (csCursor Lst) 50 | (csFillStyle V) 51 | (csStrokeStyle V) 52 | (csGlobalAlpha V) 53 | (csLineWidth V) 54 | (csLineCap V) 55 | (csLineJoin V) 56 | (csMiterLimit V) 57 | (csGlobalCompositeOperation V) 58 | (csDelay N) 59 | (csPost) ) 60 | (def (car L) 61 | (list 62 | (cdr L) 63 | (list 'link 64 | (if (cdr L) 65 | (cons 'list Opc @) 66 | (list Opc) ) ) ) ) ) 67 | 68 | (de (Id DX DY Alt) 69 | (prin 70 | "" Alt "" ) ) 83 | 84 | (de (Id DX DY Dly Post) 85 | (unless (str? Id) 86 | (put Id 'home *Top) 87 | (setq Id (pack "$" Id)) ) 88 | ( Id DX DY) 89 | (if Post 90 | ( "Post = function() {drawCanvas('" Id "', " Dly ")}; Post()") 91 | ( "drawCanvas('" Id "', " Dly ")") ) ) 92 | 93 | ### Debug ### 94 | `*Dbg 95 | 96 | (noLint 'drawCanvas) 97 | -------------------------------------------------------------------------------- /lib/clang.l: -------------------------------------------------------------------------------- 1 | # 19may21 Software Lab. Alexander Burger 2 | 3 | (de clang (Nm L . Lst) 4 | (out (tmp Nm ".c") (here "/**/")) 5 | (apply call L "clang" "-o" (tmp Nm) 6 | "-fPIC" "-O" "-w" "-shared" (tmp Nm ".c")) 7 | (for L Lst 8 | (def (car L) 9 | (list 10 | (cadr L) 11 | (cons 'native (tmp Nm) (name (caddr L)) (cdddr L)) ) ) 12 | (when (== '@ (fin (cadr L))) 13 | (push (cdaar L) 'pass) ) ) ) 14 | -------------------------------------------------------------------------------- /lib/complete.l: -------------------------------------------------------------------------------- 1 | # 29dec20 Software Lab. Alexander Burger 2 | 3 | (if (opt) 4 | (let "Lst" (chop @) 5 | (if (= "-" (car "Lst")) 6 | (let "Pre" (++ "Lst") 7 | (when (member (car "Lst") '("\"" "'")) 8 | (setq "Pre" (++ "Lst")) ) 9 | (let "Str" (pack "Lst") 10 | (for "Sym" (all) 11 | (and 12 | (pre? "Str" "Sym") 13 | (getd "Sym") 14 | (prinl "Pre" "Sym" (and (= "-" "Pre") " ")) ) ) ) ) 15 | (let ("Path" (rot (split "Lst" "/")) "Str" (pack (car "Path"))) 16 | (setq "Path" (and (cdr "Path") (pack (glue "/" @) "/"))) 17 | (for "Sym" (dir "Path" T) 18 | (when (pre? "Str" "Sym") 19 | (prinl "Path" 20 | (replace (chop "Sym") " " "\\ ") 21 | (if (=T (car (info (pack "Path" "Sym")))) 22 | "/" 23 | " " ) ) ) ) ) ) ) 24 | (prinl '+) ) 25 | -------------------------------------------------------------------------------- /lib/dbgc.l: -------------------------------------------------------------------------------- 1 | # 04jun23 Software Lab. Alexander Burger 2 | 3 | ### DB Garbage Collection ### 4 | 5 | (private) (markData markExt) 6 | 7 | (de markExt (S) 8 | (unless (mark S T) 9 | (markData (val S)) 10 | (maps markData S) 11 | (wipe S) ) ) 12 | 13 | (de markData (X) 14 | (while (pair X) 15 | (markData (++ X)) ) 16 | (and (ext? X) (markExt X)) ) 17 | 18 | (let Cnt 0 19 | (dbSync) 20 | (markExt *DB) 21 | (for L *ExtDBs # ("path/" ) 22 | (let ((P N E) L Lck) 23 | (for I N 24 | (let (Fd (open (pack P (hax (dec I)))) (Cnt . Siz) (blk Fd 0)) 25 | (and (=1 I) (setq Lck Fd)) 26 | (for Blk (dec Cnt) 27 | (mapc markExt 28 | (fish ext? (ext E (blk Fd Blk Siz Lck))) ) ) 29 | (close Fd) ) ) ) ) 30 | (finally (mark 0) 31 | (for (F . @) (or *Dbs (2)) 32 | (for (S (seq F) S (seq S)) 33 | (unless (mark S) 34 | (inc 'Cnt) 35 | (and (isa '+Entity S) (zap> S)) 36 | (zap S) ) ) ) ) 37 | (when *Blob 38 | (use (@S @R F S) 39 | (let Pat (conc (chop *Blob) '(@S "." @R)) 40 | (in (list 'find *Blob "-type" "f") 41 | (while (setq F (line)) 42 | (when (match Pat F) 43 | (unless 44 | (and 45 | (setq S (extern (pack (delete "/" @S T)))) 46 | (get S (intern @R)) ) 47 | (inc 'Cnt) 48 | (%@ "unlink" NIL (pack F)) ) 49 | (wipe S) ) ) ) ) ) ) 50 | (commit) 51 | (gt0 Cnt) ) 52 | -------------------------------------------------------------------------------- /lib/frac.l: -------------------------------------------------------------------------------- 1 | # 22may20 Software Lab. Alexander Burger 2 | 3 | (symbols 'frac 'pico) 4 | 5 | (local) (gcd lcm f) 6 | 7 | (de gcd (A B) 8 | (until (=0 B) 9 | (let M (% A B) 10 | (setq A B B M) ) ) 11 | (abs A) ) 12 | 13 | (de lcm (A B) 14 | (*/ A B (gcd A B)) ) 15 | 16 | (de f (N D) 17 | (and (=0 D) (quit "frac/0" N)) 18 | (if (=0 N) 19 | (cons 0 1) 20 | (let G (gcd N D) 21 | (if (gt0 N) 22 | (cons (/ N G) (/ D G)) 23 | (cons (- (/ N G)) (- (/ D G))) ) ) ) ) 24 | 25 | (local) (fabs 1/f f+ f- f* f/ f** fcmp) 26 | 27 | (de fabs (A) 28 | (cons (abs (car A)) (cdr A)) ) 29 | 30 | (de 1/f (A) 31 | (and (=0 (car A)) (quit "frac/0" A)) 32 | (if (gt0 (car A)) 33 | (cons (cdr A) (car A)) 34 | (cons (- (cdr A)) (- (car A))) ) ) 35 | 36 | (de f+ (A B) 37 | (let D (lcm (cdr A) (cdr B)) 38 | (let N 39 | (+ 40 | (* (/ D (cdr A)) (car A)) 41 | (* (/ D (cdr B)) (car B)) ) 42 | (if (=0 N) 43 | (cons 0 1) 44 | (let G (gcd N D) 45 | (cons (/ N G) (/ D G)) ) ) ) ) ) 46 | 47 | (de f- (A B) 48 | (if B 49 | (f+ A (f- B)) 50 | (cons (- (car A)) (cdr A)) ) ) 51 | 52 | (de f* (A B) 53 | (let (G (gcd (car A) (cdr B)) H (gcd (car B) (cdr A))) 54 | (cons 55 | (* (/ (car A) G) (/ (car B) H)) 56 | (* (/ (cdr A) H) (/ (cdr B) G)) ) ) ) 57 | 58 | (de f/ (A B) 59 | (f* A (1/f B)) ) 60 | 61 | (de f** (A N) 62 | (if (ge0 N) 63 | (cons (** (car A) N) (** (cdr A) N)) 64 | (cons (** (cdr A) (- N)) (** (car A) (- N))) ) ) 65 | 66 | (de fcmp (A B) 67 | (if (gt0 (* (car A) (car B))) 68 | (let Q (f/ A B) 69 | (* 70 | (if (gt0 (car A)) 1 -1) 71 | (- (car Q) (cdr Q))) ) 72 | (- (car A) (car B)) ) ) 73 | 74 | (local) (f< f<= f> f>=) 75 | 76 | (de f< (A B) 77 | (lt0 (fcmp A B)) ) 78 | 79 | (de f<= (A B) 80 | (ge0 (fcmp B A)) ) 81 | 82 | (de f> (A B) 83 | (gt0 (fcmp A B)) ) 84 | 85 | (de f>= (A B) 86 | (ge0 (fcmp A B)) ) 87 | -------------------------------------------------------------------------------- /lib/gis.js: -------------------------------------------------------------------------------- 1 | /* 22nov21 Software Lab. Alexander Burger */ 2 | 3 | var Map; 4 | var Sources; 5 | 6 | function osm(id, lat, lon, zoom, click) { 7 | Map = new ol.Map( { 8 | target: id, 9 | view: new ol.View( { 10 | center: ol.proj.fromLonLat([lon/1000000-180, lat/1000000-90]), 11 | zoom: zoom 12 | } ), 13 | layers: [ 14 | new ol.layer.Tile({source: new ol.source.OSM()}), 15 | new ol.layer.Vector( { 16 | source: Sources = new ol.source.Vector({features: []}) 17 | } ) 18 | ] 19 | } ); 20 | Map.form = document.getElementById(id).parentNode; 21 | while (Map.form && Map.form.tagName != "FORM") 22 | Map.form = Map.form.parentNode; 23 | 24 | Map.on("pointermove", function (evt) { 25 | Map.getViewport().style.cursor = ""; 26 | Map.forEachFeatureAtPixel(evt.pixel, function (feature, layer) { 27 | if (feature.href) 28 | Map.getViewport().style.cursor = "pointer"; 29 | lisp(Map.form, "osmHover", feature.txt); 30 | } ) 31 | } ); 32 | 33 | Map.on("click", function(evt) { 34 | Map.forEachFeatureAtPixel(evt.pixel, function (feature, layer) { 35 | if (feature.href) { 36 | window.location.href = feature.href; 37 | return; 38 | } 39 | } ) 40 | if (click > 0) { 41 | var pt = ol.proj.toLonLat(evt.coordinate); 42 | lisp(Map.form, "osmClick", (pt[1] + 90) * 1000000, (pt[0] + 180) * 1000000); 43 | if (click > 1) 44 | window.location.reload(true); 45 | } 46 | } ); 47 | 48 | Map.on("moveend", function() { 49 | var view = Map.getView().calculateExtent(Map.getSize()); 50 | var a = ol.proj.toLonLat([view[0], view[1]]); 51 | var b = ol.proj.toLonLat([view[2], view[3]]); 52 | lisp(Map.form, "osmStat", 53 | (a[1] + 90) * 1000000, (a[0] + 180) * 1000000, 54 | (b[1] + 90) * 1000000, (b[0] + 180) * 1000000, 55 | Map.getView().getZoom() ); 56 | } ); 57 | } 58 | 59 | function poi(lat, lon, img, x, y, txt, dy, col, url, drag) { 60 | var feature = new ol.Feature( { 61 | geometry: new ol.geom.Point(ol.proj.fromLonLat([lon/1000000-180, lat/1000000-90])) 62 | } ); 63 | 64 | feature.setStyle( [ 65 | new ol.style.Style( { 66 | image: new ol.style.Icon( { 67 | src: img, 68 | anchor: [x, y] 69 | } ), 70 | text: new ol.style.Text( { 71 | text: txt, 72 | offsetY: dy, 73 | fill: new ol.style.Fill({color: col}) 74 | } ) 75 | } ) 76 | ] ); 77 | 78 | if (drag > 0) { 79 | Map.addInteraction(new ol.interaction.Translate( { 80 | features: new ol.Collection([feature]) 81 | } ) ); 82 | feature.on('change', function() { 83 | var pt = ol.proj.toLonLat(this.getGeometry().getCoordinates()); 84 | lisp(Map.form, "osmDrag", txt, (pt[1] + 90) * 1000000, (pt[0] + 180) * 1000000); 85 | if (drag > 1) 86 | window.location.reload(true); 87 | }, 88 | feature ); 89 | } 90 | feature.txt = txt; 91 | feature.href = decodeURIComponent(url); 92 | Sources.addFeature(feature); 93 | } 94 | 95 | function line(col, lat1, lon1, lat2, lon2) { 96 | var feature = new ol.Feature( { 97 | geometry: new ol.geom.LineString( [ 98 | ol.proj.fromLonLat([lon1/1000000-180, lat1/1000000-90]), 99 | ol.proj.fromLonLat([lon2/1000000-180, lat2/1000000-90]) ] ) 100 | } ); 101 | feature.setStyle( [ 102 | new ol.style.Style( { 103 | stroke: new ol.style.Stroke({color: col}) 104 | } ) 105 | ] ); 106 | Sources.addFeature(feature); 107 | } 108 | -------------------------------------------------------------------------------- /lib/gis.l: -------------------------------------------------------------------------------- 1 | # 09jul22 Software Lab. Alexander Burger 2 | 3 | (symbols 'gis 'pico) 4 | 5 | (push1 '*JS (allow "@lib/gis.js")) 6 | 7 | (local) (lat lon fmt) 8 | 9 | (de lat (Lat F) 10 | (dec 'Lat 90.0) 11 | (if F 12 | (format (*/ Lat 1000 1.0) 3) 13 | (format Lat `*Scl) ) ) 14 | 15 | (de lon (Lon F) 16 | (dec 'Lon 180.0) 17 | (if F 18 | (format (*/ Lon 1000 1.0) 3) 19 | (format Lon `*Scl) ) ) 20 | 21 | (de fmt (Lat Str Lon F) 22 | (when (or Lat Lon) 23 | (pack (lat Lat F) Str (lon Lon F)) ) ) 24 | 25 | # Short distance, assuming flat earth 26 | (local) distance 27 | 28 | (de distance (Lat1 Lon1 Lat2 Lon2) # [m] 29 | (let 30 | (DX (*/ (- Lon2 Lon1) 6371000 pi 180.0) 31 | DY (*/ (cos (*/ Lat1 pi 180.0)) (- Lat2 Lat1) 6371000 pi `(* 1.0 180.0)) ) 32 | (sqrt (+ (* DX DX) (* DY DY))) ) ) 33 | 34 | # Latitude Field 35 | (local) +LatField 36 | 37 | (class +LatField +Fmt +FixField) 38 | 39 | (dm T @ 40 | (pass super 41 | '((Num) (- Num 90.0)) 42 | '((Lat) (+ Lat 90.0)) 43 | `*Scl ) ) 44 | 45 | # Longitude Field 46 | (local) +LonField 47 | 48 | (class +LonField +Fmt +FixField) 49 | 50 | (dm T @ 51 | (pass super 52 | '((Num) (- Num 180.0)) 53 | '((Lon) (+ Lon 180.0)) 54 | `*Scl ) ) 55 | 56 | # Clickable position field 57 | (local) +LatLonField 58 | 59 | (class +LatLonField +TextField) 60 | 61 | (dm T (Msg . @) 62 | (=: msg Msg) 63 | (pass super) 64 | (=: able) ) 65 | 66 | (dm set> (X Dn) 67 | (=: obj (car X)) 68 | (=: lt (cadr X)) 69 | (=: ln (cddr X)) 70 | (super (fmt (: lt) ", " (: ln)) Dn) ) 71 | 72 | (dm js> () 73 | (if (try (: msg) (: obj) (: lt) (: ln)) 74 | (pack 75 | (fmt (: lt) ", " (: ln)) 76 | "&+" 77 | (ht:Fmt (sesId (mkUrl @))) ) 78 | (super) ) ) 79 | 80 | (dm val> () 81 | (cons (: obj) (: lt) (: ln)) ) 82 | 83 | (dm show> ("Var") 84 | (showFld 85 | (if (try (: msg) (: obj) (: lt) (: ln)) 86 | ( 87 | (fmt (: lt) ", " (: ln)) 88 | (mkUrl @) ) 89 | (super "Var") ) ) ) 90 | 91 | # OpenLayers / OpenStreetMap 92 | # (val *Osm) -> ((lat1 . lat2) (lon1 . lon2) . zoom) 93 | (local) (*Osm osmStat osmClick osmDrag ) 94 | 95 | (mapc allow '(osmStat osmClick osmDrag osmHover)) 96 | 97 | (de (Lat Lon Zoom Click Upd) 98 | (
'(map (id . map))) 99 | (when (val *Osm) 100 | (setq 101 | Lat (*/ (+ (caar @) (cdar @)) 2) 102 | Lon (*/ (+ (caadr @) (cdadr @)) 2) 103 | Zoom (cddr @) ) ) 104 | (with *Top 105 | (css "https://cdn.rawgit.com/openlayers/openlayers.github.io/master/en/v5.3.0/css/ol.css") 106 | (javascript "https://cdn.rawgit.com/openlayers/openlayers.github.io/master/en/v5.3.0/build/ol.js" 107 | "osm('map', " Lat ", " Lon ", " Zoom ", " 108 | (if2 Click (and Upd (: able)) 2 1 0 0) ")" ) 109 | (=: osmClick Click) ) ) 110 | 111 | (de osmStat (Lat1 Lon1 Lat2 Lon2 Zoom) 112 | (when *Osm 113 | (set @ 114 | (cons 115 | (cons Lat1 Lat2) 116 | (cons Lon1 Lon2) 117 | Zoom ) ) ) ) 118 | 119 | (de osmClick (Lat Lon) 120 | (with *Top 121 | (and (: osmClick) (@ Lat Lon)) ) ) 122 | 123 | (de osmDrag (Txt Lat Lon) 124 | (with *Top 125 | (and 126 | (: able) 127 | (assoc Txt (: osmDrag)) 128 | ((cdr @) Txt Lat Lon) ) ) ) 129 | 130 | (de osmHover (Txt) 131 | (with *Top 132 | (and 133 | (assoc Txt (: osmHover)) 134 | ((cdr @) Txt) ) ) ) 135 | 136 | (de (Lat Lon Img X Y Txt DY Col Url Drag Upd Hover) 137 | (with *Top 138 | ( 139 | "poi(" Lat ", " Lon ", '" (sesId Img) "', " X ", " Y ", '" 140 | (replace (chop Txt) "\\" "\\\\" "'" "\\'") 141 | "', " DY ", '" Col "', '" (and Url (sesId @)) "', " 142 | (if2 (and Drag (: able)) Upd 2 1 0 0) ")" ) 143 | (and Drag (push (:: osmDrag) (cons Txt @))) 144 | (and Hover (push (:: osmHover) (cons Txt @))) ) ) 145 | 146 | (de (Col Lat1 Lon1 Lat2 Lon2) 147 | (with *Top 148 | ( 149 | "line('" Col "', " Lat1 ", " Lon1 ", " Lat2 ", " Lon2 ")" ) ) ) 150 | 151 | # Google Maps 152 | (local) (google ) 153 | 154 | (de google (Ttl Lat Lon Zoom Tar) 155 | ( Ttl 156 | (pack "https://www.google.com/maps/@" (fmt Lat "," Lon) "," Zoom "z") 157 | Tar ) ) 158 | 159 | (de (Lat Lon DX DY) 160 | (prinl 161 | "" ) ) 165 | -------------------------------------------------------------------------------- /lib/heartbeat.l: -------------------------------------------------------------------------------- 1 | # 13apr23 Software Lab. Alexander Burger 2 | 3 | (ifn (info "fifo/beat") 4 | (de heartbeat ()) 5 | 6 | (de heartbeat @ 7 | (unless (assoc -54321 *Run) 8 | (task -54321 0 (heartbeat)) 9 | (finish (out "fifo/beat" (pr *Pid))) ) 10 | (out "fifo/beat" 11 | (pr 12 | (cons 13 | *Pid 14 | (+ (* 86400 (date T)) (time T) 300) # Busy period 5 minutes 15 | (rest) ) ) ) ) ) 16 | 17 | (de nobeat () 18 | (task -54321) ) 19 | -------------------------------------------------------------------------------- /lib/json.l: -------------------------------------------------------------------------------- 1 | # 01feb25 Software Lab. Alexander Burger 2 | 3 | (de checkJson (X Item) 4 | (unless (= X Item) 5 | (quit "Bad JSON" Item) ) ) 6 | 7 | (de parseJson (Str Arr) 8 | (let L (str Str "_") 9 | (recur () 10 | (case (++ L) 11 | ("{" 12 | (make 13 | (for (X (recurse) (not (= "}" X)) (recurse)) 14 | (checkJson ":" (recurse)) 15 | (link (cons (intern X) (recurse))) 16 | (T (= "}" (setq X (recurse)))) 17 | (checkJson "," X) ) ) ) 18 | ("[" 19 | (make 20 | (and Arr (link T)) # Array marker 21 | (for (X (recurse) (not (= "]" X)) (recurse)) 22 | (link X) 23 | (T (= "]" (setq X (recurse)))) 24 | (checkJson "," X) ) ) ) 25 | (T 26 | (let X @ 27 | (cond 28 | ((pair X) (pack X)) 29 | ((and (= "-" X) (format (car L))) 30 | (- (++ L)) ) 31 | ((and (num? X) (sub? (car L) "Ee")) 32 | (and 33 | (or (index "," (shift 'L)) (index "}" L)) 34 | (format (cut (dec @) 'L)) 35 | ((if (lt0 @) */ *) X (** 10 (abs @))) ) ) 36 | (T X) ) ) ) ) ) ) ) 37 | 38 | (de readJson (Arr) 39 | (case (read "_") 40 | ("{" 41 | (make 42 | (for (X (readJson Arr) (not (= "}" X)) (readJson Arr)) 43 | (checkJson ":" (readJson Arr)) 44 | (link (cons (intern X) (readJson Arr))) 45 | (T (= "}" (setq X (readJson Arr)))) 46 | (checkJson "," X) ) ) ) 47 | ("[" 48 | (make 49 | (and Arr (link T)) # Array marker 50 | (for (X (readJson Arr) (not (= "]" X)) (readJson Arr)) 51 | (link X) 52 | (T (= "]" (setq X (readJson Arr)))) 53 | (checkJson "," X) ) ) ) 54 | (T 55 | (let X @ 56 | (cond 57 | ((pair X) (pack X)) 58 | ((and (= "-" X) (format (peek))) 59 | (- (read)) ) 60 | ((and (num? X) (sub? (peek) "Ee")) 61 | (when (format (cdr (till ",}"))) 62 | ((if (lt0 @) */ *) X (** 10 (abs @))) ) ) 63 | (T X) ) ) ) ) ) 64 | 65 | (de packJson (Item F) 66 | (pack 67 | (make 68 | (recur (Item F) 69 | (cond 70 | ((atom Item) (link (if Item (sym @) "{}"))) 71 | ((=T (car Item)) 72 | (link "[") 73 | (map 74 | '((X) 75 | (recurse (car X)) 76 | (and (cdr X) (link ", ")) ) 77 | (cdr Item) ) 78 | (link "]") ) 79 | ((and (car Item) (atom @) (not F)) 80 | (link "\"" (sym (car Item)) "\": ") 81 | (recurse (cdr Item) T) ) 82 | (T 83 | (link "{") 84 | (map 85 | '((X) 86 | (recurse (car X)) 87 | (and (cdr X) (link ", ")) ) 88 | Item ) 89 | (link "}") ) ) ) ) ) ) 90 | 91 | (de printJson (Item F) 92 | (cond 93 | ((atom Item) (if Item (print @) (prin "{}"))) 94 | ((=T (car Item)) 95 | (prin "[") 96 | (map 97 | '((X) 98 | (printJson (car X)) 99 | (and (cdr X) (prin ", ")) ) 100 | (cdr Item) ) 101 | (prin "]") ) 102 | ((and (car Item) (atom @) (not F)) 103 | (prin "\"") 104 | (print (car Item)) 105 | (prin "\": ") 106 | (printJson (cdr Item) T) ) 107 | (T 108 | (prin "{") 109 | (map 110 | '((X) 111 | (printJson (car X)) 112 | (and (cdr X) (prin ", ")) ) 113 | Item ) 114 | (prin "}") ) ) ) 115 | -------------------------------------------------------------------------------- /lib/math.l: -------------------------------------------------------------------------------- 1 | # 14sep20 Software Lab. Alexander Burger 2 | 3 | (and (=0 *Scl) (scl 6)) # Default scale 6 4 | 5 | (setq # Global constants 6 | pi 3.1415926535897932 7 | pi/2 1.5707963267948966 8 | "Dbl1" (0 . 1.0) 9 | "Dbl2" (0 . 1.0) ) 10 | 11 | (de pow (X Y) 12 | (set "Dbl1" X "Dbl2" Y) 13 | (%@ "pow" 1.0 "Dbl1" "Dbl2") ) 14 | 15 | (de exp (X) 16 | (set "Dbl1" X) 17 | (%@ "exp" 1.0 "Dbl1") ) 18 | 19 | (de log (X) 20 | (when (gt0 (set "Dbl1" X)) 21 | (%@ "log" 1.0 "Dbl1") ) ) 22 | 23 | (de sin (A) 24 | (set "Dbl1" A) 25 | (%@ "sin" 1.0 "Dbl1") ) 26 | 27 | (de cos (A) 28 | (set "Dbl1" A) 29 | (%@ "cos" 1.0 "Dbl1") ) 30 | 31 | (de tan (A) 32 | (set "Dbl1" A) 33 | (%@ "tan" 1.0 "Dbl1") ) 34 | 35 | (de asin (A) 36 | (set "Dbl1" A) 37 | (%@ "asin" 1.0 "Dbl1") ) 38 | 39 | (de acos (A) 40 | (set "Dbl1" A) 41 | (%@ "acos" 1.0 "Dbl1") ) 42 | 43 | (de atan (A) 44 | (set "Dbl1" A) 45 | (%@ "atan" 1.0 "Dbl1") ) 46 | 47 | (de atan2 (X Y) 48 | (set "Dbl1" X "Dbl2" Y) 49 | (%@ "atan2" 1.0 "Dbl1" "Dbl2") ) 50 | -------------------------------------------------------------------------------- /lib/pilog.l: -------------------------------------------------------------------------------- 1 | # 30may25 Software Lab. Alexander Burger 2 | 3 | (private) (CL Q R L Prg) 4 | 5 | (de be CL 6 | (clause CL) ) 7 | 8 | (de clause (CL) 9 | (with (++ CL) 10 | (if (== *Rule This) 11 | (queue (:: T) CL) 12 | (=: T (list CL)) 13 | (setq *Rule This) ) 14 | (def This T (: T)) ) ) 15 | 16 | (de repeat () 17 | (conc (get *Rule T) (get *Rule T)) ) 18 | 19 | (de asserta (CL) 20 | (push (prop CL 1 T) (cdr CL)) ) 21 | 22 | (de assertz (CL) 23 | (queue (prop CL 1 T) (cdr CL)) ) 24 | 25 | (de retract (X) 26 | (if (sym? X) 27 | (put X T) 28 | (put (car X) T 29 | (delete (cdr X) (get (car X) T)) ) ) ) 30 | 31 | (de rules @ 32 | (while (args) 33 | (let S (next) 34 | (for ((N . L) (get S T) L) 35 | (prin N " (be ") 36 | (print S) 37 | (for X (++ L) 38 | (space) 39 | (print X) ) 40 | (prinl ")") 41 | (T (== L (get S T)) 42 | (println '(repeat)) ) ) 43 | S ) ) ) 44 | 45 | ### Pilog Interpreter ### 46 | (private) (Env Dbg *R) 47 | 48 | (de goal (CL . @) 49 | (let Env '(T) 50 | (while (args) 51 | (push 'Env 52 | (cons (cons 0 (next)) 1 (next)) ) ) 53 | (while (and CL (pat? (car CL))) 54 | (push 'Env 55 | (cons 56 | (cons 0 (++ CL)) 57 | (cons 1 (eval (++ CL))) ) ) ) 58 | (cons 59 | (cons 60 | (conc (list 1 (0) NIL CL NIL) Env) ) ) ) ) 61 | 62 | (de fail () 63 | (goal '((NIL))) ) 64 | 65 | (de pilog (CL . Prg) 66 | (for (Q (goal CL) (prove Q)) 67 | (bind @ (run Prg)) ) ) 68 | 69 | (de solve (CL . Prg) 70 | (make 71 | (if Prg 72 | (for (Q (goal CL) (prove Q)) 73 | (link (bind @ (run Prg))) ) 74 | (for (Q (goal CL) (prove Q)) 75 | (link @) ) ) ) ) 76 | 77 | (de query (Q Dbg) 78 | (use R 79 | (loop 80 | (NIL (prove Q Dbg)) 81 | (T (=T (setq R @)) T) 82 | (for X R 83 | (space) 84 | (print (car X)) 85 | (print '=) 86 | (print (cdr X)) ) 87 | (prinl) 88 | (T (= "\e" (key)) T) ) ) ) 89 | 90 | (de ? CL 91 | (let L 92 | (make 93 | (while (nor (pat? (car CL)) (lst? (car CL))) 94 | (link (++ CL)) ) ) 95 | (query (goal CL) L) ) ) 96 | 97 | ### Basic Rules ### 98 | (private) (_or _for) 99 | 100 | (be repeat) 101 | (repeat) 102 | 103 | (be true) 104 | 105 | (be not @P (1 @P) T (fail)) 106 | (be not @P) 107 | 108 | (be call @P (2 (cons @P))) 109 | 110 | (be or @L (^ @C (box @L)) (_or @C)) 111 | 112 | (be _or (@C) (3 (pop @C))) 113 | (be _or (@C) (^ @ (not (val @C))) T (fail)) 114 | (repeat) 115 | 116 | (be nil (@X) (^ @ (not @X))) 117 | 118 | 119 | (be equal (@X @X)) 120 | 121 | (be different (@X @X) T (fail)) 122 | (be different (@ @)) 123 | 124 | (be append (NIL @X @X)) 125 | (be append ((@A . @X) @Y (@A . @Z)) (append @X @Y @Z)) 126 | 127 | (be member (@X (@X . @))) 128 | (be member (@X (@ . @Y)) (member @X @Y)) 129 | 130 | (be delete (@A (@A . @Z) @Z)) 131 | (be delete (@A (@X . @Y) (@X . @Z)) 132 | (delete @A @Y @Z) ) 133 | 134 | (be permute ((@X) (@X))) 135 | (be permute (@L (@X . @Y)) 136 | (delete @X @L @D) 137 | (permute @D @Y) ) 138 | 139 | (be uniq (@B @X) 140 | (^ @ 141 | (not (idx @B (cons (hash @X) @X) T)) ) ) 142 | 143 | 144 | (be asserta (@C) (^ @ (asserta @C))) 145 | (be assertz (@C) (^ @ (assertz @C))) 146 | 147 | (be retract (@C) 148 | (2 (cons @C)) 149 | (^ @ (retract (list (car @C) (cdr @C)))) ) 150 | 151 | (be clause (@H @B) 152 | (^ @A (get @H T)) 153 | (member @B @A) ) 154 | 155 | (be show (@X) (^ @ (show @X))) 156 | 157 | (be for (@N @End) (for @N 1 @End 1)) 158 | (be for (@N @Beg @End) (for @N @Beg @End 1)) 159 | (be for (@N @Beg @End @Step) (equal @N @Beg)) 160 | (be for (@N @Beg @End @Step) 161 | (^ @I (box @Beg)) 162 | (_for @N @I @End @Step) ) 163 | 164 | (be _for (@N @I @End @Step) 165 | (^ @ 166 | (if (>= @End (val @I)) 167 | (> (inc @I @Step) @End) 168 | (> @End (dec @I @Step)) ) ) 169 | T 170 | (fail) ) 171 | 172 | (be _for (@N @I @End @Step) 173 | (^ @N (val @I)) ) 174 | 175 | (repeat) 176 | 177 | 178 | (private) (_lst _map) 179 | 180 | (be val (@V . @L) 181 | (^ @V (apply get @L)) 182 | T ) 183 | 184 | (be lst (@V . @L) 185 | (^ @Lst (box (apply get @L))) 186 | (_lst @V @Lst) ) 187 | 188 | (be _lst (@Val @Lst) (^ @ (not (val @Lst))) T (fail)) 189 | (be _lst (@Val @Lst) (^ @Val (pop @Lst))) 190 | (repeat) 191 | 192 | (be map (@V . @L) 193 | (^ @Lst (box (apply get @L))) 194 | (_map @V @Lst) ) 195 | 196 | (be _map (@Val @Lst) (^ @ (not (val @Lst))) T (fail)) 197 | (be _map (@Val @Lst) (^ @Val (prog1 (val @Lst) (pop @Lst)))) 198 | (repeat) 199 | -------------------------------------------------------------------------------- /lib/plio.js: -------------------------------------------------------------------------------- 1 | /* 22nov21 Software Lab. Alexander Burger */ 2 | 3 | function plio(lst) { 4 | var NIX = 0; 5 | var BEG = 1; 6 | var DOT = 2; 7 | var END = 3; 8 | 9 | var NUMBER = 0; 10 | var INTERN = 1; 11 | var TRANSIENT = 2; 12 | 13 | var PlioPos = 1; 14 | var PlioLst = lst; 15 | var PlioCnt, PlioMore; 16 | 17 | function byte() { 18 | if (PlioCnt == 0) { 19 | if (!PlioMore || (PlioCnt = PlioLst[PlioPos++]) == 0) 20 | return -1; 21 | PlioMore = PlioCnt == 255; 22 | } 23 | --PlioCnt; 24 | return PlioLst[PlioPos++]; 25 | } 26 | 27 | function expr(c) { 28 | if ((c & ~3) !== 0) { // Atom 29 | PlioMore = (PlioCnt = c >> 2) === 63; 30 | if ((c & 3) === NUMBER) { 31 | c = byte(); 32 | var n = c >> 1; 33 | var s = c & 1; 34 | var m = 128; 35 | while ((c = byte()) >= 0) { 36 | n += c * m; 37 | m *= 256; 38 | } 39 | return s == 0? n : -n; 40 | } 41 | var str = ""; // TRANSIENT 42 | while ((c = byte()) >= 0) { 43 | if ((c & 0x80) != 0) { 44 | if ((c & 0x20) == 0) 45 | c &= 0x1F; 46 | else 47 | c = (c & 0xF) << 6 | byte() & 0x3F; 48 | c = c << 6 | byte() & 0x3F; 49 | } 50 | str += String.fromCharCode(c); 51 | } 52 | return str; 53 | } 54 | if (c !== BEG) // NIX, DOT or END 55 | return null; 56 | var i = 0; 57 | var lst = new Array(); 58 | lst[0] = expr(PlioLst[PlioPos++]); 59 | while ((c = PlioLst[PlioPos++]) !== END && c !== DOT) 60 | lst[++i] = expr(c); 61 | return lst; 62 | } 63 | 64 | return expr(PlioLst[0]); 65 | } 66 | -------------------------------------------------------------------------------- /lib/replica.l: -------------------------------------------------------------------------------- 1 | # 17oct20 Software Lab. Alexander Burger 2 | 3 | # /bin/picolisp /lib.l @lib/replica.l [dbs1 ..] 4 | # /bin/ssl 443 '/!replica' 20 [60] 5 | 6 | (argv *Arg1 *KeyFile *Journal *Pool *Blob . *Dbs) 7 | (unless (info *KeyFile) 8 | (bye) ) 9 | 10 | (pool *Pool (mapcar format *Dbs) *Journal) 11 | (when (lock) 12 | (bye) ) 13 | 14 | (load "@lib/net.l" "@lib/misc.l" "@lib/http.l") 15 | 16 | (allow "!replica") 17 | 18 | (setq 19 | *Arg1 (format *Arg1) 20 | *Port (or (format (sys "PORT")) *Arg1) 21 | *SSLKey (in *KeyFile (line T)) 22 | *Replica (tmp 'replica) ) 23 | 24 | (de replicate (N) 25 | (and 26 | (out *Replica (echo N)) 27 | (= N (car (info *Replica))) 28 | (= "T" (prin (peek))) 29 | (flush) 30 | (char) 31 | (eof) ) ) 32 | 33 | (de replica () 34 | (when (= (line T) *SSLKey) 35 | (let? X (line T) 36 | (if (format X) 37 | (when (replicate @) # Journal 38 | (protect (journal *Replica)) ) 39 | (let Blob (pack *Blob X) # Blob 40 | (call 'mkdir "-p" (dirname Blob)) 41 | (and 42 | (format (line T)) 43 | (replicate @) 44 | (protect (call "mv" *Replica Blob)) ) ) ) ) ) ) 45 | 46 | (retire *Arg1) 47 | 48 | # Non-forking server 49 | (let P (port *Port) 50 | (loop 51 | (let S (listen P) 52 | (http S) 53 | (close S) ) ) ) 54 | -------------------------------------------------------------------------------- /lib/role.l: -------------------------------------------------------------------------------- 1 | # 18jul19 Software Lab. Alexander Burger 2 | 3 | (must "Role Administration" RoleAdmin) 4 | 5 | (menu ,"Role Administration" 6 | (idForm ,"Role" ,"Roles" 'nm '+Role T '(may Delete) '((: nm)) 7 | (gui '(+E/R +Cue +TextField) '(nm : home obj) ,"Role" 30 ,"Name") 8 | (gui '(+E/R +Fmt +Chart) '(perm : home obj) 9 | '((Val) (mapcar '((S) (list (memq S Val))) *Perms)) 10 | '((Lst) (filter '((S L) (and (car L) S)) *Perms Lst)) 11 | 1 ) 12 | ( NIL NIL NIL 13 | (for This *Perms 14 | ( NIL 15 | (ht:Prin (: 0 0)) 16 | (gui 1 '(+Checkbox)) ) ) ) 17 | (gui '(+/R +Chart) '(usr : home obj) 1 list) 18 | (
'chart ,"User" NIL 19 | (do 8 20 | ( (alternating) 21 | (gui 1 '(+Obj +TextField) '(nm +User)) ) ) ) 22 | (scroll 8 T) ) ) 23 | -------------------------------------------------------------------------------- /lib/sq.l: -------------------------------------------------------------------------------- 1 | # 04dec23 Software Lab. Alexander Burger 2 | 3 | # (select [var ..] cls [hook] [var val ..]) 4 | (de select Lst 5 | (let 6 | (Vars 7 | (make 8 | (until (pre? "+" (car Lst)) 9 | (unless Lst 10 | (quit "Missing class") ) 11 | (link (++ Lst)) ) ) 12 | Cls (++ Lst) 13 | Hook (and (ext? (car Lst)) (++ Lst)) ) 14 | (default Lst 15 | (list 16 | (or 17 | (and (sym? (car Vars)) (car Vars)) 18 | (recur (Cls) 19 | (or 20 | (and 21 | (find 22 | '((X) 23 | (isa '(+Need +index) (car (pair X))) ) 24 | (getl Cls) ) 25 | (; @ 1 var) ) 26 | (cdr 27 | (maxi caar 28 | (getl (get (or Hook *DB) Cls)) ) ) 29 | (pick recurse (type Cls)) ) ) ) ) ) 30 | (for 31 | (Q 32 | (apply search 33 | (make 34 | (loop 35 | (prog1 (++ Lst) 36 | (link 37 | (++ Lst) 38 | (list 39 | (make (link @ Cls) (and Hook (link Hook))) ) ) ) 40 | (NIL Lst) ) ) ) 41 | (search Q) ) 42 | (T 43 | (when (setq This (isa Cls @)) 44 | (ifn Vars 45 | (show This) 46 | (for X Vars 47 | (cond 48 | ((pair X) 49 | (printsp (eval X)) ) 50 | ((meta This X) 51 | (print> @ (get This X)) 52 | (space) ) 53 | (T (printsp (get This X))) ) ) 54 | (println This) ) 55 | (= "\e" (key)) ) 56 | This ) ) ) ) 57 | 58 | (dm (print> . +relation) (Val) 59 | (print Val) ) 60 | 61 | (dm (print> . +Number) (Val) 62 | (if (num? Val) 63 | (prin (format Val (: scl))) 64 | (print Val) ) ) 65 | 66 | (dm (print> . +Date) (Val) 67 | (print (if (num? Val) (datStr Val) Val)) ) 68 | -------------------------------------------------------------------------------- /lib/term.l: -------------------------------------------------------------------------------- 1 | # 29aug23 Software Lab. Alexander Burger 2 | 3 | (sysdefs "terminal") 4 | 5 | (local) (ULINE U-OFF REVERS) 6 | 7 | (de ULINE . "4") 8 | (de U-OFF . "24") 9 | (de REVERS . "7") 10 | 11 | (local) (RED GREEN BROWN BLUE PURPLE CYAN YELLOW) 12 | 13 | (de RED . "0;31") 14 | (de GREEN . "0;32") 15 | (de BROWN . "0;33") 16 | (de BLUE . "0;34") 17 | (de PURPLE . "0;35") 18 | (de CYAN . "0;36") 19 | (de YELLOW . "1;33") 20 | 21 | (local) (*AttrA *AttrU) 22 | 23 | (off *AttrA *AttrU) 24 | 25 | (local) (*Lines *Columns xterm getTerm setTerm getSize) 26 | 27 | (de xterm () 28 | (member (sys "TERM") '("xterm" "screen")) ) 29 | 30 | (de getTerm () 31 | (use Lst 32 | (and 33 | (=0 34 | (%@ "ioctl" 'I 1 TIOCGWINSZ 35 | '(Lst (`winsize W W W W)) ) ) 36 | Lst ) ) ) 37 | 38 | (de setTerm (Term Rows Cols DX DY) 39 | (sys "TERM" Term) 40 | (sys "LINES" Rows) 41 | (sys "COLUMNS" Cols) 42 | (%@ "ioctl" 'I 1 TIOCSWINSZ 43 | (cons NIL (`winsize) 44 | (cons Rows 2) # ws_row 45 | (cons Cols 2) # ws_col 46 | (cons DX 2) # ws_xpixel 47 | (cons DY 2) ) ) # ws_ypixel 48 | (%@ "rl_reset_terminal" 'I 0) ) 49 | 50 | (de getSize () 51 | (if (getTerm) 52 | (setq *Lines (car @) *Columns (cadr @)) 53 | (quit "Can't get terminal size") ) ) 54 | 55 | (local) (attr cup clreol hideCsr showCsr screen1 screen2) 56 | 57 | (de attr (A U) 58 | (if2 (<> A *AttrA) (<> U *AttrU) 59 | (prin "\e[" 60 | (or (setq *AttrA A) 0) 61 | ";" 62 | (if (setq *AttrU U) ULINE U-OFF) 63 | "m" ) 64 | (prin "\e[" (or (setq *AttrA A) 0) "m") 65 | (prin "\e[" (if (setq *AttrU U) ULINE U-OFF) "m") ) ) 66 | 67 | (de cup (Y X) 68 | (prin "\e[" Y ";" X "H") ) 69 | 70 | (de clreol () 71 | (prin "\e[0K") ) 72 | 73 | (de clear () 74 | (prin "\e[H\e[J") ) 75 | 76 | (de hideCsr () 77 | (prin "\e[?25l") ) 78 | 79 | (de showCsr () 80 | (prin "\e[?25h") ) 81 | 82 | (de screen1 () 83 | (if (xterm) 84 | (prin "\e[?1049l") 85 | (cup *Lines 1) ) 86 | (flush) ) 87 | 88 | (de screen2 () 89 | (and (xterm) (prin "\e[?1049h")) ) 90 | 91 | ### Debug ### 92 | `*Dbg 93 | 94 | (noLint 'RED) 95 | -------------------------------------------------------------------------------- /lib/test.l: -------------------------------------------------------------------------------- 1 | # 04jul21 Software Lab. Alexander Burger 2 | 3 | ### Unit Tests ### 4 | # Local usage: 5 | # ./pil lib/test.l -bye + 6 | 7 | # Global usage: 8 | # pil @lib/test.l -bye + 9 | 10 | (unless *Dbg 11 | (quit "Needs debug mode '+'") ) 12 | 13 | (setq 14 | *CMD (cmd) 15 | *PWD (in '(pwd) (line T)) ) 16 | 17 | (load 18 | "@test/src/main.l" 19 | "@test/src/apply.l" 20 | "@test/src/flow.l" 21 | "@test/src/sym.l" 22 | "@test/src/subr.l" 23 | "@test/src/big.l" 24 | "@test/src/io.l" 25 | "@test/src/db.l" 26 | "@test/src/net.l" 27 | "@test/src/ext.l" 28 | "@test/src/ht.l" ) 29 | 30 | (load "@test/lib.l") 31 | (load "@test/lib/db.l") 32 | (load "@test/lib/misc.l") 33 | 34 | (load "@test/lib/lint.l") 35 | 36 | (load "@test/lib/math.l") 37 | 38 | (msg 'OK) 39 | -------------------------------------------------------------------------------- /lib/user.l: -------------------------------------------------------------------------------- 1 | # 18oct21 Software Lab. Alexander Burger 2 | 3 | (must "User Administration" UserAdmin (== *Login *ID)) 4 | 5 | (menu ,"User Administration" 6 | (idForm ,"User" '(choUser) 'nm '+User 7 | '(or (may UserAdmin) (== *Login (: home obj))) 8 | '(or (may Delete) (== *Login (: home obj))) 9 | '((: nm) ) 10 | ( 2 11 | ,"Login Name" (gui '(+E/R +Cue +TextField) '(nm : home obj) ,"User" 30) 12 | ,"Password" 13 | (gui '(+Able +PasswdField) 14 | '(or (may Password) (== *Login (: home obj))) 15 | 30 ) 16 | ,"Role" 17 | (gui '(+Able +E/R +Obj +TextField) 18 | '(may RoleAdmin) 19 | '(role : home obj) 20 | '(nm +Role) 21 | T ) ) 22 | (--) 23 | (gui> (: obj) This) ) ) 24 | -------------------------------------------------------------------------------- /lib/vip/html.l: -------------------------------------------------------------------------------- 1 | # 29oct23 Software Lab. Alexander Burger 2 | 3 | # View HTML buffers 4 | (let? *Class (isa '+Buffer This) 5 | (dm view> (Win) 6 | (=: view T) 7 | (with Win 8 | (let 9 | (Y (- (: posY) 13) 10 | N (- (length (: buffer text)) 15) ) 11 | (scratch (tmp "html") 12 | (in (list "w3m" "-cols" *Columns (: buffer file)) 13 | (rdLines) ) ) 14 | (unless (: buffer view) 15 | (goto 1 (*/ Y (length (: buffer text)) N)) ) ) ) ) 16 | (dm save> (Win) 17 | (super Win) 18 | (when (: view) 19 | (view> This Win) ) ) ) 20 | -------------------------------------------------------------------------------- /lib/vip/load.l: -------------------------------------------------------------------------------- 1 | # 10dec24 Software Lab. Alexander Burger 2 | 3 | # View output of 'load'ing the file 4 | (let? *Class (isa '+Buffer This) 5 | (dm view> (Win) 6 | (=: view T) 7 | (with Win 8 | (scratch (tmp "xml") 9 | (pipe (load (: buffer file)) 10 | (rdLines) ) ) ) ) 11 | (dm save> (Win) 12 | (super Win) 13 | (when (: view) 14 | (view> This Win) ) ) ) 15 | -------------------------------------------------------------------------------- /lib/xhtml/area: -------------------------------------------------------------------------------- 1 | 3 | -------------------------------------------------------------------------------- /lib/xhtml/field: -------------------------------------------------------------------------------- 1 | 2 | -------------------------------------------------------------------------------- /lib/xhtml/grid: -------------------------------------------------------------------------------- 1 |
2 | 3 | ¦(run PRG)¦ 4 | 5 |
6 | -------------------------------------------------------------------------------- /lib/xhtml/html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | ¦(run PRG)¦ 6 | 7 | ¦(run PRG)¦ 8 | 9 | -------------------------------------------------------------------------------- /lib/xhtml/input: -------------------------------------------------------------------------------- 1 | 2 | -------------------------------------------------------------------------------- /lib/xhtml/layout: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/picolisp/pil21/6428739cc8979f5e63e84d016c0bc6201b7f8e70/lib/xhtml/layout -------------------------------------------------------------------------------- /lib/xhtml/menu: -------------------------------------------------------------------------------- 1 | <> 2 | 11 | <> 12 | -------------------------------------------------------------------------------- /lib/xhtml/select: -------------------------------------------------------------------------------- 1 | 2 | ¦(run (cdr PRG))¦ 3 | 4 | 5 | -------------------------------------------------------------------------------- /lib/xhtml/submit: -------------------------------------------------------------------------------- 1 | 2 | -------------------------------------------------------------------------------- /lib/xhtml/tab: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 |
¦(run PRG)¦¦(run PRG)¦
5 | -------------------------------------------------------------------------------- /lib/xhtml/table: -------------------------------------------------------------------------------- 1 | 2 | ¦(run PRG)¦ 3 | 4 | ¦(run PRG)¦ 5 | 6 | 7 | ¦(run PRG)¦ 8 | 9 | 10 | -------------------------------------------------------------------------------- /lib/xm.l: -------------------------------------------------------------------------------- 1 | # 09may25 Software Lab. Alexander Burger 2 | 3 | (local) (xml? xml body attr) 4 | (private) (_xml xmlEsc escXml) 5 | 6 | # Check or write header 7 | (de xml? (Flg) 8 | (if Flg 9 | (prinl "") 10 | (skip) 11 | (prog1 12 | (head '("<" "?" "x" "m" "l") (till ">")) 13 | (char) ) ) ) 14 | 15 | # Generate/Parse XML data 16 | (de xml (Lst N) 17 | (if Lst 18 | (let Tag (++ Lst) 19 | (space (default N 0)) 20 | (prin "<" Tag) 21 | (for X (++ Lst) 22 | (prin " " (car X) "=\"") 23 | (escXml (cdr X)) 24 | (prin "\"") ) 25 | (nond 26 | (Lst (prinl "/>")) 27 | ((or (cdr Lst) (pair (car Lst))) 28 | (prin ">") 29 | (escXml (car Lst)) 30 | (prinl "") ) 31 | (NIL 32 | (prinl ">") 33 | (for X Lst 34 | (if (pair X) 35 | (xml X (+ 3 N)) 36 | (space (+ 3 N)) 37 | (escXml X) 38 | (prinl) ) ) 39 | (space N) 40 | (prinl "") ) ) ) 41 | (skip) 42 | (unless (= "<" (char)) 43 | (quit "Bad XML") ) 44 | (_xml (till " /<>" T)) ) ) 45 | 46 | (de _xml (Tok) 47 | (use X 48 | (make 49 | (link (intern Tok)) 50 | (let L 51 | (make 52 | (loop 53 | (NIL (skip) (quit "XML parse error")) 54 | (T (member @ '`(chop "/>"))) 55 | (NIL (setq X (intern (till "=" T)))) 56 | (char) 57 | (unless (= "\"" (char)) 58 | (quit "XML parse error" X) ) 59 | (link (cons X (pack (xmlEsc (till "\""))))) 60 | (char) ) ) 61 | (if (= "/" (char)) 62 | (prog (char) (and L (link L))) 63 | (link L) 64 | (loop 65 | (NIL (skip) (quit "XML parse error" Tok)) 66 | (T (and (= "<" (setq X (char))) (= "/" (peek))) 67 | (char) 68 | (unless (= Tok (till " /<>" T)) 69 | (quit "Unbalanced XML" Tok) ) 70 | (char) ) 71 | (if (= "<" X) 72 | (and (_xml (till " /<>" T)) (link @)) 73 | (link 74 | (pack (xmlEsc (trim (cons X (till "\n<"))))) ) ) ) ) ) ) ) ) 75 | 76 | (de xmlEsc (L) 77 | (use (@X @Z) 78 | (make 79 | (while L 80 | (ifn (match '("&" @X ";" @Z) L) 81 | (link (++ L)) 82 | (link 83 | (cond 84 | ((= @X '`(chop "quot")) "\"") 85 | ((= @X '`(chop "amp")) "&") 86 | ((= @X '`(chop "lt")) "<") 87 | ((= @X '`(chop "gt")) ">") 88 | ((= @X '`(chop "apos")) "'") 89 | ((= "#" (car @X)) 90 | (char 91 | (if (= "x" (cadr @X)) 92 | (hex (cddr @X)) 93 | (format (cdr @X)) ) ) ) 94 | (T @X) ) ) 95 | (setq L @Z) ) ) ) ) ) 96 | 97 | (de escXml (X) 98 | (for C (chop X) 99 | (if (member C '`(chop "\"&<")) 100 | (prin "&#" (char C) ";") 101 | (prin C) ) ) ) 102 | 103 | 104 | # Access functions 105 | (de body @ 106 | (cdr (pass get)) ) 107 | 108 | (de attr (Lst Key . @) 109 | (while (args) 110 | (setq Lst (asoq Key Lst) Key (next)) ) 111 | (get Lst 2 Key) ) 112 | -------------------------------------------------------------------------------- /loc/AE.l: -------------------------------------------------------------------------------- 1 | (setq 2 | *Sep0 "." 3 | *Sep3 "," 4 | *CtryCode "971" 5 | *NatTrunkPrf '("0") 6 | *DateFmt '(@Y "-" @M "-" @D) 7 | *DayFmt '("Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday" "Sunday") 8 | *MonFmt '("January" "February" "March" "April" "May" "June" "July" "August" "September" "October" "November" "December") ) 9 | -------------------------------------------------------------------------------- /loc/AR.l: -------------------------------------------------------------------------------- 1 | (setq 2 | *Sep0 "," 3 | *Sep3 "." 4 | *CtryCode "54" 5 | *NatTrunkPrf '("0") 6 | *DateFmt '(@D "-" @M "-" @Y) 7 | *DayFmt '("Lunes" "Martes" "Miércoles" "Jueves" "Viernes" "Sábado" "Domingo") 8 | *MonFmt '("Enero" "Febrero" "Marzo" "Abril" "Mayo" "Junio" "Julio" "Agosto" "Septiembre" "Octubre" "Noviembre" "Diciembre") ) 9 | -------------------------------------------------------------------------------- /loc/CH.l: -------------------------------------------------------------------------------- 1 | (setq 2 | *Sep0 "." 3 | *Sep3 "'" 4 | *CtryCode "41" 5 | *NatTrunkPrf '("0") 6 | *DateFmt '(@D "." @M "." @Y) 7 | *DayFmt '("Montag" "Dienstag" "Mittwoch" "Donnerstag" "Freitag" "Samstag" "Sonntag") 8 | *MonFmt '("Januar" "Februar" "März" "April" "Mai" "Juni" "Juli" "August" "September" "Oktober" "November" "Dezember") ) 9 | -------------------------------------------------------------------------------- /loc/CKB.l: -------------------------------------------------------------------------------- 1 | (setq 2 | *Sep0 "." 3 | *Sep3 "," 4 | *CtryCode "964" 5 | *NatTrunkPrf '("0" "0") 6 | *DateFmt '(@Y "/" @M "/" @D) 7 | *DayFmt '("دووشەممە" "سێشەممە" "چوارشەممە" "پێنجشەممە" "هەینی" "شەممە" "یەکشەممە") 8 | *MonFmt '("کانوونی دووەم" "شوبات" "ئازار" "نیسان" "ئایار" "حوزەیران" "تەمموز" "ئاب" "ئەیلوول" "تشرینی یەکەم" "تشرینی دووەم" "کانوونی یەکەم") ) 9 | -------------------------------------------------------------------------------- /loc/CN.l: -------------------------------------------------------------------------------- 1 | (load "@loc/NIL.l") 2 | -------------------------------------------------------------------------------- /loc/DE.l: -------------------------------------------------------------------------------- 1 | (setq 2 | *Sep0 "," 3 | *Sep3 "." 4 | *CtryCode "49" 5 | *NatTrunkPrf '("0") 6 | *DateFmt '(@D "." @M "." @Y) 7 | *DayFmt '("Montag" "Dienstag" "Mittwoch" "Donnerstag" "Freitag" "Samstag" "Sonntag") 8 | *MonFmt '("Januar" "Februar" "März" "April" "Mai" "Juni" "Juli" "August" "September" "Oktober" "November" "Dezember") ) 9 | -------------------------------------------------------------------------------- /loc/ES.l: -------------------------------------------------------------------------------- 1 | (setq 2 | *Sep0 "," 3 | *Sep3 "." 4 | *CtryCode "34" 5 | *NatTrunkPrf NIL 6 | *DateFmt '(@D "/" @M "/" @Y) 7 | *DayFmt '("Lunes" "Martes" "Miércoles" "Jueves" "Viernes" "Sábado" "Domingo") 8 | *MonFmt '("Enero" "Febrero" "Marzo" "Abril" "Mayo" "Junio" "Julio" "Agosto" "Setiembre" "Octubre" "Noviembre" "Diciembre") ) 9 | -------------------------------------------------------------------------------- /loc/FR.l: -------------------------------------------------------------------------------- 1 | (setq 2 | *Sep0 "," 3 | *Sep3 "." 4 | *CtryCode "33" 5 | *NatTrunkPrf '("0") 6 | *DateFmt '(@D "/" @M "/" @Y) 7 | *DayFmt '("Lundi" "Mardi" "Mercredi" "Jeudi" "Vendredi" "Samedi" "Dimanche") 8 | *MonFmt '("Janvier" "Février" "Mars" "Avril" "Mai" "Juin" "Juillet" "Août" "Septembre" "Octobre" "Novembre" "Décembre") ) 9 | -------------------------------------------------------------------------------- /loc/GB.l: -------------------------------------------------------------------------------- 1 | (setq 2 | *Sep0 "." 3 | *Sep3 "," 4 | *CtryCode "44" 5 | *NatTrunkPrf '("0") 6 | *DateFmt '(@D "/" @M "/" @Y) 7 | *DayFmt '("Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday" "Sunday") 8 | *MonFmt '("January" "February" "March" "April" "May" "June" "July" "August" "September" "October" "November" "December") ) 9 | -------------------------------------------------------------------------------- /loc/GR.l: -------------------------------------------------------------------------------- 1 | (setq 2 | *Sep0 "," 3 | *Sep3 "." 4 | *CtryCode "30" 5 | *NatTrunkPrf NIL 6 | *DateFmt '(@D "/" @M "/" @Y) 7 | *DayFmt '("Δευτέρα" "Τρίτη" "Τετάρτη" "Πέμπτη" "Παρασκευή" "Σάββατο" "Κυριακή") 8 | *MonFmt '("Ιανουάριος" "Φεβρουάριος" "Μάρτιος" "Απρίλιος" "Μάϊος" "Ιούνιος" "Ιούλιος" "Αύγουστος" "Σεπτέμβριος" "Οκρώβριος" "Νοέμβριος" "Δεκέμβριος") ) 9 | -------------------------------------------------------------------------------- /loc/HR.l: -------------------------------------------------------------------------------- 1 | (load "@loc/NIL.l") 2 | -------------------------------------------------------------------------------- /loc/IT.l: -------------------------------------------------------------------------------- 1 | (load "@loc/NIL.l") 2 | -------------------------------------------------------------------------------- /loc/JP.l: -------------------------------------------------------------------------------- 1 | (setq 2 | *Sep0 "." 3 | *Sep3 "," 4 | *CtryCode "81" 5 | *NatTrunkPrf '("0") 6 | *DateFmt '(@Y "/" @M "/" @D) 7 | *DayFmt '("月曜日" "火曜日" "水曜日" "木曜日" "金曜日" "土曜日" "日曜日") 8 | *MonFmt '("一月" "二月" "三月" "四月" "五月" "六月" "七月" "八月" "九月" "十月" "十一月" "十二月") ) 9 | -------------------------------------------------------------------------------- /loc/NIL.l: -------------------------------------------------------------------------------- 1 | (setq # Default locale 2 | *Sep0 "." 3 | *Sep3 "," 4 | *CtryCode NIL 5 | *NatTrunkPrf NIL 6 | *DateFmt '(@Y "-" @M "-" @D) 7 | *DayFmt '("Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday" "Sunday") 8 | *MonFmt '("January" "February" "March" "April" "May" "June" "July" "August" "September" "October" "November" "December") ) 9 | -------------------------------------------------------------------------------- /loc/NO.l: -------------------------------------------------------------------------------- 1 | (setq 2 | *Sep0 "," 3 | *Sep3 "." 4 | *CtryCode "47" 5 | *NatTrunkPrf NIL 6 | *DateFmt '(@D "." @M "." @Y) 7 | *DayFmt '("mandag" "tirsdag" "onsdag" "torsdag" "fredag" "lørdag" "søndag") 8 | *MonFmt '("januar" "februar" "mars" "april" "mai" "juni" "juli" "august" "september" "oktober" "november" "desember") ) 9 | -------------------------------------------------------------------------------- /loc/RU.l: -------------------------------------------------------------------------------- 1 | (setq 2 | *Sep0 "," 3 | *Sep3 " " 4 | *CtryCode "7" 5 | *NatTrunkPrf '("8") 6 | *DateFmt '(@D "." @M "." @Y) 7 | *DayFmt '("Понедельник" "Вторник" "Среда" "Четверг" "Пятница" "Суббота" "Воскресенье") 8 | *MonFmt '("Январь" "Февраль" "Март" "Апрель" "Май" "Июнь" "Июль" "Август" "Сентябрь" "Октябрь" "Ноябрь" "Декабрь") ) 9 | -------------------------------------------------------------------------------- /loc/SE.l: -------------------------------------------------------------------------------- 1 | (setq 2 | *Sep0 "," 3 | *Sep3 " " 4 | *CtryCode "46" 5 | *NatTrunkPrf '("0") 6 | *DateFmt '(@D "." @M "." @Y) 7 | *DayFmt '("Måndag" "Tisdag" "Onsdag" "Torsdag" "Fredag" "Lördag" "Söndag") 8 | *MonFmt '("Januari" "Februari" "Mars" "April" "Maj" "juni" "Juli" "Augusti" "September" "Oktober" "November" "December") ) 9 | -------------------------------------------------------------------------------- /loc/TR.l: -------------------------------------------------------------------------------- 1 | (load "@loc/NIL.l") 2 | -------------------------------------------------------------------------------- /loc/UA.l: -------------------------------------------------------------------------------- 1 | (setq 2 | *Sep0 "," 3 | *Sep3 " " 4 | *CtryCode "380" 5 | *NatTrunkPrf '("0") 6 | *DateFmt '(@D "." @M "." @Y) 7 | *DayFmt '("Понеділок" "Вівторок" "Середа" "Четвер" "П’ятниця" "Субота" "Неділя") 8 | *MonFmt '("Січень" "Лютий" "Березень" "Квітень" "Травень" "Червень" "Липень" "Серпень" "Вересень" "Жовтень" "Листопад" "Грудень") ) 9 | -------------------------------------------------------------------------------- /loc/UK.l: -------------------------------------------------------------------------------- 1 | GB.l -------------------------------------------------------------------------------- /loc/US.l: -------------------------------------------------------------------------------- 1 | (setq 2 | *Sep0 "." 3 | *Sep3 "," 4 | *CtryCode "1" 5 | *NatTrunkPrf '("1") 6 | *DateFmt '(@M "/" @D "/" @Y) 7 | *DayFmt '("Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday" "Sunday") 8 | *MonFmt '("January" "February" "March" "April" "May" "June" "July" "August" "September" "October" "November" "December") ) 9 | -------------------------------------------------------------------------------- /loc/ar: -------------------------------------------------------------------------------- 1 | # 22nov21 Software Lab. Alexander Burger 2 | 3 | T "@loc/es" 4 | -------------------------------------------------------------------------------- /loc/ca: -------------------------------------------------------------------------------- 1 | # 28aug17abu 2 | # Arnau Figueras 3 | 4 | "Language" "Idioma" 5 | 6 | # lib/db.l 7 | "Boolean input expected" "S'espera l'ingrés de dades tipus booleà" 8 | "Numeric input expected" "S'espera l'ingrés de dades tipus numèric" 9 | "Symbolic type expected" "Se esperan datos del tipo simbólico" 10 | "String type expected" "S'esperen dades del tipus simbòlic" 11 | "Type error" "Error de teclejat" 12 | "Not unique" "No únic" 13 | "Input required" "Es requereix ingrés de dades" 14 | 15 | # lib/form.l 16 | "Cancel" "Cancel·lar" 17 | "Yes" "Sí" 18 | "No" "No" 19 | "Select" "Seleccionar" 20 | "Delete row?" "¿Borrar fila?" 21 | "Show" "Mostrar" 22 | "Bad date format" "El format de la data no és vàlid" 23 | "Bad time format" "El format de l’hora no és vàlid" 24 | "Bad phone number format" "El format del número de telèfon no és vàlid" 25 | "male" "home" 26 | "female" "dona" 27 | "New" "nou" 28 | "Edit" "Editar" 29 | "Save" "Guardar" 30 | "Done" "Acabar" 31 | "Currently edited by '@2' (@1)" "Actualmente editat per '@2' (@1)" 32 | "Search" "Buscar" 33 | "Reset" "Buidar/Netejar" 34 | "New/Copy" "Nou/Copiar" 35 | "Restore" "Restaurar" 36 | "Restore @1?" "¿Restaurar @1?" 37 | "Delete" "Esborrar" 38 | "Delete @1?" "¿Esborrar @1?" 39 | "Data not found" "No s’han trobat dades" 40 | "Undo" "Desfer" 41 | "Undo: '@1'" "Desfer: '@1'" 42 | "Redo" "Rehacer" 43 | "Redo: '@1'" "Desfer: '@1'" 44 | 45 | # General 46 | "login" "Entrar al sistema" 47 | "logout" "Sortir del sistema" 48 | "' logged in" "' ha ingressat al sistema" 49 | "Name" "Nom" 50 | "Login Name" "Nom d’usuari" 51 | "Full Name" "Nom complet" 52 | "Password" "Contrasenya" 53 | "Permission denied" "Permís denegat" 54 | "Permissions" "Permisos" 55 | "Role" "Rol" 56 | "Role Administration" "Administració de rols" 57 | "Roles" "Rols" 58 | "User" "Usuari" 59 | "User Administration" "Administració d’usuaris" 60 | "Users" "Usuaris" 61 | "Settings" "Configuració" 62 | "Phone" "Telèfon" 63 | 64 | # Tooltips 65 | "Open submenu" "Obrir submenú" 66 | "Close submenu" "Tancar submenú" 67 | "Next object of the same type" "Següent objecte del mateix tipus" 68 | "Find or create an object of the same type" "Buscar o crear objecte del mateix tipus" 69 | "Choose a suitable value" "Tria un valor adequat" 70 | "Adopt this value" "Selecciona aquest valor" 71 | "Go to first line" "Anar a la primera línia" 72 | "Scroll up one page" "Pujar una pàgina" 73 | "Scroll up one line" "Pujar una línia" 74 | "Scroll down one line" "Baixar una línia" 75 | "Scroll down one page" "Baixar una pàgina" 76 | "Go to last line" "Anar a l’última línia" 77 | "Insert empty row" "Insertar línia buida" 78 | "Delete row" "Esborrar línia" 79 | "Shift row up" "Moure línia amunt" 80 | "Clear all input fields" "Esborrar tots els camps" 81 | "Release exclusive write access for this object" "Alliberar accés exclusiu d’escriptura per a aquest objecte" 82 | "Gain exclusive write access for this object" "Reclamar accés exclusiu d’escriptura per a aquest objecte" 83 | "Start search" "Inicia la cerca" 84 | "Create new object" "Crear nou objecte" 85 | "Create a new copy of this object" "Crear nova còpia d'aquest objecte" 86 | "Mark this object as \"not deleted\"" "Marcar aquest objecte com \"no esborrat\"" 87 | "Mark this object as \"deleted\"" "Marcar aquest objecte com \"esborrat\"" 88 | "Update" "Actualitzar" 89 | -------------------------------------------------------------------------------- /loc/ch: -------------------------------------------------------------------------------- 1 | # 22nov21 Software Lab. Alexander Burger 2 | 3 | T "@loc/de" 4 | -------------------------------------------------------------------------------- /loc/ckb: -------------------------------------------------------------------------------- 1 | # 10jan22 2 | # Hunar Omar 3 | 4 | "Language" "زمان" 5 | 6 | # lib/db.l 7 | "Boolean input expected" "چاوەڕوانی تێچەی ڕاست یان هەڵە کرا" 8 | "Numeric input expected" "چاوەڕوانی تێچەی ژمارەیی کرا" 9 | "Symbolic type expected" "چاوەڕوانی تێچەی هێمایی کرا" 10 | "String type expected" "چاوەڕوانی جۆرێکی نووسینی کرا" 11 | "Type error" "هەڵە لە جۆردا" 12 | "Not unique" "بێهاوتا نییە" 13 | "Input required" "تێچەیەک پێویستە" 14 | 15 | # lib/form.l 16 | "Cancel" "وازهێنان" 17 | "Yes" "بەڵێ" 18 | "No" "نەخێر" 19 | "Select" "دیاریکردن" 20 | "Delete row?" "ڕیز بسڕدرێتەوە؟" 21 | "Show" "پیشاندان" 22 | "Bad date format" "شێوازی بەروار هەڵەیە" 23 | "Bad time format" "شێوازی کات هەڵەیە" 24 | "Bad phone number format" "شێوازی ژمارەی تەلەفۆن هەڵەیە" 25 | "male" "نێر" 26 | "female" "مێ" 27 | "New" "نوێ" 28 | "Edit" "دەستکاری" 29 | "Save" "هەڵگرتن" 30 | "Done" "تەواو" 31 | "Currently edited by '@2' (@1)" "وا دەستکاری دەکرێت لەلایەن '@2' (@1)" 32 | "Search" "گەڕان" 33 | "Reset" "دامەزراندنەوە" 34 | "New/Copy" "نوێ/لەبەرگرتنەوە" 35 | "Restore" "گەڕاندنەوە" 36 | "Restore @1?" "@1 بگەڕێندرێتەوە؟" 37 | "Delete" "سڕینەوە" 38 | "Delete @1?" "@1 بسڕدرێتەوە؟" 39 | "Data not found" "زانیاری نەدۆزرایەوە" 40 | "Undo" "گەڕانەوە" 41 | "Undo: '@1'" "گەڕانەوە: '@1'" 42 | "Redo" "نەگەڕانەوە" 43 | "Redo: '@1'" "نەگەڕانەوە: '@1'" 44 | 45 | # General 46 | "login" "چوونەژوورەوە" 47 | "logout" "چوونەدەرەوە" 48 | "' logged in" "' چووە ژوورەوە" 49 | "Name" "ناو" 50 | "Login Name" "ناوی چوونەژوورەوە" 51 | "Full Name" "ناوی تەواو" 52 | "Password" "تێپەڕەوشە" 53 | "Permission denied" "مۆڵەت ڕەتکرایەوە" 54 | "Permissions" "مۆڵەتەکان" 55 | "Role" "پلە" 56 | "Role Administration" "بەڕێوبەرایەتی پلە" 57 | "Roles" "پلەکان" 58 | "User" "بەکارهێنەر" 59 | "User Administration" "بەڕێوبەرایەتی بەکارهێنەر" 60 | "Users" "بەکارهێنەران" 61 | "Settings" "ڕێکخستن" 62 | "Phone" "تەلەفۆن" 63 | 64 | # Tooltips 65 | "Open submenu" "کردنەوەی پێڕستی دووەمی" 66 | "Close submenu" "داخستنی پێڕستی دووەمی" 67 | "Next object of the same type" "تەنی دواتری هەمان جۆر" 68 | "Find or create an object of the same type" "دۆزینەوە یان دروستکردنی تەنێکی نوێ لە هەمان جۆر" 69 | "Choose a suitable value" "نرخێکی گونجاو هەڵبژێرە" 70 | "Adopt this value" "هەڵگرتنەوەی ئەم نرخە" 71 | "Go to first line" "بڕۆ بۆ یەکەم دێڕ" 72 | "Scroll up one page" "پەڕەیەک بۆ سەرەوە" 73 | "Scroll up one line" "دێڕێک بۆ سەرەوە" 74 | "Scroll down one line" "دێڕێک بۆ خوارەوە" 75 | "Scroll down one page" "پەڕەیەک بۆ خوارەوە" 76 | "Go to last line" "ڕۆیشتن بۆ کۆتا دێڕ" 77 | "Insert empty row" "زیادکردنی ڕیزێکی بەتاڵ" 78 | "Delete row" "سڕینەوەی ڕیز" 79 | "Shift row up" "ڕیز ببە بەرەو سەر" 80 | "Clear all input fields" "سڕینەوەی هەموو خانە تێچەکان" 81 | "Release exclusive write access for this object" "لەدەستدانی مافی تایبەتیی نووسین بۆ ئەم تەنە" 82 | "Gain exclusive write access for this object" "دەستکەوتنی مافی تایبەتیی نووسین بۆ ئەم تەنە" 83 | "Start search" "دەستکردن بە گەڕان" 84 | "Create new object" "دروستکردنی تەنێکی نوێ" 85 | "Create a new copy of this object" "درووستکردنی لەبەرگیراوەیەکی نوێ بۆ ئەم تەنە" 86 | "Mark this object as \"not deleted\"" "ئەم تەنە وەک \"نەسڕاوە\" دیاریبکە" 87 | "Mark this object as \"deleted\"" "ئەم تەنە وەک \"سڕاوە\" دیاریبکە" 88 | "Update" "نوێکردنەوە" 89 | -------------------------------------------------------------------------------- /loc/cn: -------------------------------------------------------------------------------- 1 | # 22nov21 Software Lab. Alexander Burger 2 | 3 | -------------------------------------------------------------------------------- /loc/de: -------------------------------------------------------------------------------- 1 | # 22nov21 Software Lab. Alexander Burger 2 | 3 | "Language" "Sprache" 4 | 5 | # lib/db.l 6 | "Boolean input expected" "Boolean-Type erwartet" 7 | "Numeric input expected" "Zahleneingabe erforderlich" 8 | "Symbolic type expected" "Symbol-Type erwartet" 9 | "String type expected" "String-Type erwartet" 10 | "Type error" "Typ-Fehler" 11 | "Not unique" "Nicht eindeutig" 12 | "Input required" "Eingabe erforderlich" 13 | 14 | # lib/form.l 15 | "Cancel" "Abbruch" 16 | "Yes" "Ja" 17 | "No" "Nein" 18 | "Select" "Auswahl" 19 | "Delete row?" "Zeile löschen?" 20 | "Show" "Anzeigen" 21 | "Bad date format" "Falsches Datums-Format" 22 | "Bad time format" "Falsches Uhrzeit-Format" 23 | "Bad phone number format" "Falsches Telefonnummern-Format" 24 | "male" "männlich" 25 | "female" "weiblich" 26 | "New" "Neu" 27 | "Edit" "Bearbeiten" 28 | "Save" "Speichern" 29 | "Done" "Fertig" 30 | "Currently edited by '@2' (@1)" "Zur Zeit von '@2' (@1) bearbeitet" 31 | "Search" "Suchen" 32 | "Reset" "Zurücksetzen" 33 | "New/Copy" "Neu/Muster" 34 | "Restore" "Wiederherstellen" 35 | "Restore @1?" "@1 wiederherstellen?" 36 | "Delete" "Löschen" 37 | "Delete @1?" "@1 löschen?" 38 | "Data not found" "Daten nicht gefunden" 39 | "Undo" "Rückgängig" 40 | "Undo: '@1'" "Rückgängig: '@1'" 41 | "Redo" "Wiederherstellen" 42 | "Redo: '@1'" "Wiederherstellen: '@1'" 43 | 44 | # General 45 | "login" "anmelden" 46 | "logout" "abmelden" 47 | "' logged in" "' ist angemeldet" 48 | "Name" "Name" 49 | "Login Name" "Login-Name" 50 | "Full Name" "Vollständiger Name" 51 | "Password" "Passwort" 52 | "Permission denied" "Keine Berechtigung" 53 | "Permissions" "Berechtigungen" 54 | "Role" "Rolle" 55 | "Role Administration" "Rollenverwaltung" 56 | "Roles" "Rollen" 57 | "User" "Benutzer" 58 | "User Administration" "Benutzerverwaltung" 59 | "Users" "Benutzer" 60 | "Settings" "Einstellungen" 61 | "Phone" "Telefon" 62 | 63 | # Tooltips 64 | "Open submenu" "Untermenü öffnen" 65 | "Close submenu" "Untermenü schließen" 66 | "Next object of the same type" "Nächstes Objekt vom gleichen Typ" 67 | "Find or create an object of the same type" "Ein Objekt vom gleichen Typ suchen oder neu anlegen" 68 | "Choose a suitable value" "Einen passenden Wert auswählen" 69 | "Adopt this value" "Diesen Wert übernehmen" 70 | "Go to first line" "Zur ersten Zeile gehen" 71 | "Scroll up one page" "Eine Seite nach oben scrollen" 72 | "Scroll up one line" "Eine Zeile nach oben scrollen" 73 | "Scroll down one line" "Eine Zeile nach unten scrollen" 74 | "Scroll down one page" "Eine Seite nach unten scrollen" 75 | "Go to last line" "Zur letzten Zeile gehen" 76 | "Insert empty row" "Leerzeile einfügen" 77 | "Delete row" "Zeile löschen" 78 | "Shift row up" "Zeile nach oben schieben" 79 | "Clear all input fields" "Alle Eingabefelder löschen" 80 | "Release exclusive write access for this object" "Exklusiven Schreibzugriff auf dieses Objekt freigeben" 81 | "Gain exclusive write access for this object" "Exklusiven Schreibzugriff auf dieses Objekt erhalten" 82 | "Start search" "Suche starten" 83 | "Create new object" "Neues Objekt anlegen" 84 | "Create a new copy of this object" "Eine neue Kopie dieses Objektes anlegen" 85 | "Mark this object as \"not deleted\"" "Dieses Objekt als \"nicht gelöscht\" markieren" 86 | "Mark this object as \"deleted\"" "Dieses Objekt als \"gelöscht\" markieren" 87 | "Update" "Aktualisieren" 88 | -------------------------------------------------------------------------------- /loc/el: -------------------------------------------------------------------------------- 1 | # 23aug2016 2 | # Drakopoulos A. 3 | 4 | "Language" "Γλώσσα" 5 | 6 | # lib/db.l 7 | "Boolean input expected" "Αναμένονται δεδομένα λογικού τύπου" 8 | "Numeric input expected" "Αναμένονται δεδομένα αριθμητικού τύπου" 9 | "Symbolic type expected" "Αναμένονται δεδομένα συμβολικού τύπου" 10 | "String type expected" "Αναμένονται δεδομένα αλφαριθμητικού τύπου" 11 | "Type error" "Σφάλμα τύπου" 12 | "Not unique" "Δεν είναι μοναδικό" 13 | "Input required" "Απαιτείται είσοδος δεδομένων" 14 | 15 | # lib/form.l 16 | "Cancel" "Άκυρο" 17 | "Yes" "Ναί" 18 | "No" "Όχι" 19 | "Select" "Επιλέξτε" 20 | "Delete row?" "Διαγραφή σειράς;" 21 | "Show" "Εμφάνισε" 22 | "Bad date format" "Η μορφοποίηση τής ημερομηνίας δεν είναι έγκυρη" 23 | "Bad time format" "Η μορφοποίηση τής ώρας δεν είναι έγκυρη" 24 | "Bad phone number format" "Η μορφοποίηση τού αριθμού τηλεφώνου δεν είναι έγκυρη" 25 | "male" "άντρας" 26 | "female" "γυναίκα" 27 | "New" "Νέο" 28 | "Edit" "Διόρθωση" 29 | "Save" "Αποθήκευση" 30 | "Done" "Τερματισμός" 31 | "Currently edited by '@2' (@1)" "Πρόσφατα διορθωμένο από '@2' (@1)" 32 | "Search" "Αναζήτηση" 33 | "Reset" "Καθάρισε" 34 | "New/Copy" "Νέο/Αντιγραφή" 35 | "Restore" "Επαναφορά" 36 | "Restore @1?" "Επανάφερε @1?" 37 | "Delete" "Διαγραφή" 38 | "Delete @1?" "Διαγραφή @1?" 39 | "Data not found" "Δεν βρέθηκαν δεδομένα" 40 | 41 | # General 42 | "login" "Είσοδος στο σύστημα" 43 | "logout" "Έξοδος από το σύστημα" 44 | "' logged in" "' είσοδος στο σύστημα" 45 | "Name" "Όνομα" 46 | "Password" "Συνθηματικό" 47 | "Permission denied" "Άδεια απορρίφθηκε" 48 | "Permissions" "Άδειες" 49 | "Role" "Ρόλος" 50 | "Roles" "Ρόλοι" 51 | "User" "Χρήστης" 52 | "Users" "Χρήστες" 53 | "Settings" "Ρυθμίσεις" 54 | 55 | # Tooltips 56 | "Open submenu" "Άνοιξε υπομενού" 57 | "Close submenu" "Κλείσε υπομενού" 58 | "Next object of the same type" "Επόμενο αντικείμενο τού ίδιου τύπου" 59 | "Find or create an object of the same type" "Βρές ή δημιούργησε ένα αντικείμενο τού ίδιου τύπου" 60 | "Choose a suitable value" "Διάλεξε μια κατάλληλη τιμή" 61 | "Adopt this value" "Αποδέξου αυτή την τιμή" 62 | "Go to first line" "Πήγαινε στην πρώτη γραμμή" 63 | "Scroll up one page" "Πήγαινε πρός τα πάνω μια σελίδα" 64 | "Scroll up one line" "Πήγαινε προς τα πάνω μια γραμμή" 65 | "Scroll down one line" "Πήγαινε προς τα κάτω μια γραμμή" 66 | "Scroll down one page" "Πήγαινε προς τα κάτω μια σελίδα" 67 | "Go to last line" "Πήγαινε στην τελευταία γραμμή" 68 | "Insert empty row" "Τοποθέτησε κενή γραμμή" 69 | "Delete row" "Διάγραψε γραμμή" 70 | "Shift row up" "Μετακίνησε γραμμή προς τα πάνω" 71 | "Clear all input fields" "Καθάρισε όλα τα πεδία εισαγωγής" 72 | "Release exclusive write access for this object" "Απελευθέρωσε την αποκλειστική πρόσβαση εγγραφής για αυτό το αντικείμενο" 73 | "Gain exclusive write access for this object" "Απόκτησε αποκλειστική πρόσβαση εγγραφής για αυτό το αντικείμενο" 74 | "Start search" "Ξεκίνα αναζήτηση" 75 | "Create new object" "Δημιούργησε νέο αντικείμενο" 76 | "Create a new copy of this object" "Δημιούργησε νέο αντίγραφο αυτού τού αντικειμένου" 77 | "Mark this object as \"not deleted\"" "Σημάδεψε αυτό το αντικείμενο σαν \"μη διεγραμμένο\"" 78 | "Mark this object as \"deleted\"" "Σημάδεψε αυτό το αντικείμενο σαν \"διεγραμμένο\"" 79 | "Update" "Ενημέρωσε" 80 | -------------------------------------------------------------------------------- /loc/es: -------------------------------------------------------------------------------- 1 | # 28aug17abu 2 | # Armadillo 3 | # Manuel Cano 4 | 5 | "Language" "Idioma" 6 | 7 | # lib/db.l 8 | "Boolean input expected" "Se espera el ingreso de datos tipo buliano" 9 | "Numeric input expected" "Se espera el ingreso de datos tipo numérico" 10 | "Symbolic type expected" "Se esperan datos del tipo simbólico" 11 | "String type expected" "Se esperan datos del tipo String" 12 | "Type error" "Error de tipado" 13 | "Not unique" "No único" 14 | "Input required" "Se require ingreso de datos" 15 | 16 | # lib/form.l 17 | "Cancel" "Cancelar" 18 | "Yes" "Sí" 19 | "No" "No" 20 | "Select" "Seleccionar" 21 | "Delete row?" "¿Borrar fila?" 22 | "Show" "Mostrar" 23 | "Bad date format" "El formato de la fecha no es válido" 24 | "Bad time format" "El formato de la hora no es válido" 25 | "Bad phone number format" "El formato del número telefónico no es válido" 26 | "male" "hombre" 27 | "female" "mujer" 28 | "New" "Nuevo" 29 | "Edit" "Editar" 30 | "Save" "Guardar" 31 | "Done" "Terminar" 32 | "Currently edited by '@2' (@1)" "Actualmente editado por '@2' (@1)" 33 | "Search" "Buscar" 34 | "Reset" "Vaciar/Limpiar" 35 | "New/Copy" "Nuevo/Copiar" 36 | "Restore" "Restaurar" 37 | "Restore @1?" "¿Restaurar @1?" 38 | "Delete" "Borrar" 39 | "Delete @1?" "¿Borrar @1?" 40 | "Data not found" "No se encontraron datos" 41 | "Undo" "Deshacer" 42 | "Undo: '@1'" "Deshacer: '@1'" 43 | "Redo" "Rehacer" 44 | "Redo: '@1'" "Rehacer: '@1'" 45 | 46 | # General 47 | "login" "Ingresar al Sistema" 48 | "logout" "Salir del Sistema" 49 | "' logged in" "' ingresó al sistema" 50 | "Name" "Nombre" 51 | "Login Name" "Nombre de usuario" 52 | "Full Name" "Nombre Completo" 53 | "Password" "Contraseña" 54 | "Permission denied" "Permiso denegado" 55 | "Permissions" "Permisos" 56 | "Role" "Rol" 57 | "Role Administration" "Administración de roles" 58 | "Roles" "Roles" 59 | "User" "Usuario" 60 | "User Administration" "Administración de usuarios" 61 | "Users" "Usuarios" 62 | "Settings" "Configuración" 63 | "Phone" "Teléfono" 64 | 65 | # Tooltips 66 | "Open submenu" "Abrir submenu" 67 | "Close submenu" "Cerrar submenu" 68 | "Next object of the same type" "Siguiente objeto del mismo tipo" 69 | "Find or create an object of the same type" "Buscar o crear objeto del mismo tipo" 70 | "Choose a suitable value" "Elija un valor adecuado" 71 | "Adopt this value" "Seleccione este valor" 72 | "Go to first line" "Ir a la primera línea" 73 | "Scroll up one page" "Subir una página" 74 | "Scroll up one line" "Subir una línea" 75 | "Scroll down one line" "Bajar una línea" 76 | "Scroll down one page" "Bajar una página" 77 | "Go to last line" "Ir a la última línea" 78 | "Insert empty row" "Insertar línea vacia" 79 | "Delete row" "Borrar línea" 80 | "Shift row up" "Mover línea arriba" 81 | "Clear all input fields" "Borrar todos los campos" 82 | "Release exclusive write access for this object" "Liberar acceso exclusido en escritura para este objeto" 83 | "Gain exclusive write access for this object" "Reclamar acceso exclusivo en escritura para este objeto" 84 | "Start search" "Iniciar búsqueda" 85 | "Create new object" "Crear nuevo objeto" 86 | "Create a new copy of this object" "Crear nueva copia de este objeto" 87 | "Mark this object as \"not deleted\"" "Marcar este objeto como \"no borrado\"" 88 | "Mark this object as \"deleted\"" "Marcar este objeto como \"borrado\"" 89 | "Update" "Actualizar" 90 | -------------------------------------------------------------------------------- /loc/fr: -------------------------------------------------------------------------------- 1 | # 28aug17abu 2 | # Raman Gopalan 3 | 4 | "Language" "Langue" 5 | 6 | # lib/db.l 7 | "Boolean input expected" "Type booléen attendu" 8 | "Numeric input expected" "Type numérique attendu" 9 | "Symbolic type expected" "Type symbole attendu" 10 | "String type expected" "Type chaîne de caractères attendu" 11 | "Type error" "Erreur de type" 12 | "Not unique" "Non unique" 13 | "Input required" "Saisie requise" 14 | 15 | # lib/form.l 16 | "Cancel" "Annuler" 17 | "Yes" "Oui" 18 | "No" "Non" 19 | "Select" "Sélectionner" 20 | "Delete row?" "Supprimer la ligne?" 21 | "Show" "Montrer" 22 | "Bad date format" "Mauvais format de date" 23 | "Bad time format" "Mauvais format d'heure" 24 | "Bad phone number format" "Mauvais format de numéro de téléphone" 25 | "male" "mâle" 26 | "female" "femelle" 27 | "New" "Nouveau" 28 | "Edit" "Modifier" 29 | "Save" "Enregistrer" 30 | "Done" "Terminé" 31 | "Currently edited by '@2' (@1)" "Actuellement modifié par '@2' (@1)" 32 | "Search" "Chercher" 33 | "Reset" "Réinitialiser" 34 | "New/Copy" "Nouveau/Copie" 35 | "Restore" "Restaurer" 36 | "Restore @1?" "Restaurer @1?" 37 | "Delete" "Supprimer" 38 | "Delete @1?" "Supprimer @1?" 39 | "Data not found" "Données introuvables" 40 | "Undo" "Annuler" 41 | "Undo: '@1'" "Annuler: '@1'" 42 | "Redo" "Refaire" 43 | "Redo: '@1'" "Refaire: '@1'" 44 | 45 | # General 46 | "login" "se connecter" 47 | "logout" "se déconnecter" 48 | "' logged in" "' connecté" 49 | "Name" "Nom" 50 | "Login Name" "Identifiant" 51 | "Full Name" "Nom complet" 52 | "Password" "Mot de passe" 53 | "Permission denied" "Permission refusée" 54 | "Permissions" "Autorisations" 55 | "Role" "Rôle" 56 | "Role Administration" "Gestion des rôles" 57 | "Roles" "Rôles" 58 | "User" "Utilisateur" 59 | "User Administration" "Gestion des utilisateurs" 60 | "Users" "Utilisateurs" 61 | "Settings" "Paramètres" 62 | "Phone" "Téléphone" 63 | 64 | # Tooltips 65 | "Open submenu" "Ouvrir le sous-menu" 66 | "Close submenu" "Fermer le sous-menu" 67 | "Next object of the same type" "Objet suivant du même type" 68 | "Find or create an object of the same type" "Trouver ou créer un objet du même type" 69 | "Choose a suitable value" "Choisissez une valeur appropriée" 70 | "Adopt this value" "Adopter cette valeur" 71 | "Go to first line" "Aller à la première ligne" 72 | "Scroll up one page" "Défiler d'une page vers le haut" 73 | "Scroll up one line" "Défiler d'une ligne vers le haut" 74 | "Scroll down one line" "Défiler d'une ligne vers le bas" 75 | "Scroll down one page" "Défiler d'une page vers le bas" 76 | "Go to last line" "Aller à la dernière ligne" 77 | "Insert empty row" "Insérer une ligne vide" 78 | "Delete row" "Supprimer la ligne" 79 | "Shift row up" "Déplacer la ligne vers le haut" 80 | "Clear all input fields" "Effacer tous les champs de saisie" 81 | "Release exclusive write access for this object" "Libérer l'accès en écriture exclusif pour cet objet" 82 | "Gain exclusive write access for this object" "Obtenir un accès en écriture exclusif pour cet objet" 83 | "Start search" "Lancer la recherche" 84 | "Create new object" "Créer un nouvel objet" 85 | "Create a new copy of this object" "Créer une nouvelle copie de cet objet" 86 | "Mark this object as \"not deleted\"" "Marquer cet objet comme \"non supprimé\"" 87 | "Mark this object as \"deleted\"" "Marquer cet objet comme \"supprimé\"" 88 | "Update" "Mettre à jour" 89 | -------------------------------------------------------------------------------- /loc/gr: -------------------------------------------------------------------------------- 1 | el -------------------------------------------------------------------------------- /loc/hr: -------------------------------------------------------------------------------- 1 | # 22nov21 Software Lab. Alexander Burger 2 | 3 | -------------------------------------------------------------------------------- /loc/it: -------------------------------------------------------------------------------- 1 | # 22nov21 Software Lab. Alexander Burger 2 | 3 | -------------------------------------------------------------------------------- /loc/ja: -------------------------------------------------------------------------------- 1 | # 22nov21 Software Lab. Alexander Burger 2 | 3 | "Language" "言語" 4 | 5 | # lib/db.l 6 | "Boolean input expected" "Booleanタイプが必要" 7 | "Numeric input expected" "数値入力が必要" 8 | "Symbolic type expected" "Symbolicタイプが必要" 9 | "String type expected" "Stringタイプが必要" 10 | "Type error" "タイプエラー" 11 | "Not unique" "重複" 12 | "Input required" "入力が必要" 13 | 14 | # lib/form.l 15 | "Cancel" "キャンセル" 16 | "Yes" "はい" 17 | "No" "いいえ" 18 | "Select" "選択" 19 | "Delete row?" "行を消しますか？" 20 | "Show" "表示" 21 | "Bad date format" "日付が違います" 22 | "Bad time format" "時刻が違います" 23 | "Bad phone number format" "電話番号が違います" 24 | "male" "男性" 25 | "female" "女性" 26 | "New" "作成" 27 | "Edit" "編集" 28 | "Save" "保存" 29 | "Done" "終了" 30 | "Currently edited by '@2' (@1)" "現在'@2'(@1)が編集中です" 31 | "Search" "検索" 32 | "Reset" "リセット" 33 | "New/Copy" "作成/コピー" 34 | "Restore" "もとへ戻す" 35 | "Restore @1?" "@1もとへ戻しますか？" 36 | "Delete" "消去" 37 | "Delete @1?" "@1を消しますか？" 38 | "Data not found" "データが見つかりません" 39 | "Undo" "元に戻す" 40 | "Undo: '@1'" "元に戻す: '@1'" 41 | "Redo" "やり直す" 42 | "Redo: '@1'" "やり直す: '@1'" 43 | 44 | # General 45 | "login" "ログイン" 46 | "logout" "ログアウト" 47 | "' logged in" "' ログインしました" 48 | "Name" "名前" 49 | "Login Name" "ログイン名" 50 | "Full Name" "フルネーム" 51 | "Password" "パスワード" 52 | "Permission denied" "認証できません" 53 | "Permissions" "許可" 54 | "Role" "役割" 55 | "Role Administration" "役割管理" 56 | "Roles" "役割" 57 | "User" "ユーザー" 58 | "User Administration" "ユーザー管理" 59 | "Users" "ユーザー" 60 | "Settings" "設定" 61 | "Phone" "電話番号" 62 | 63 | # Tooltips 64 | "Open submenu" "サブメニューを開く" 65 | "Close submenu" "サブメニューを閉じる" 66 | "Next object of the same type" "次の同じタイプへ" 67 | "Find or create an object of the same type" "同じタイプを探す/新規" 68 | "Choose a suitable value" "適したバリューを選ぶ" 69 | "Adopt this value" "このバリューを採用する" 70 | "Go to first line" "最初の列にいく" 71 | "Scroll up one page" "一ページ上へスクロール" 72 | "Scroll up one line" "一行上へスクロール" 73 | "Scroll down one line" "一行下へスクロール" 74 | "Scroll down one page" "一ページ下へスクロール" 75 | "Go to last line" "最後の列にいく" 76 | "Insert empty row" "空の行挿入" 77 | "Delete row" "行を消す" 78 | "Shift row up" "行を上へ移す" 79 | "Clear all input fields" "全ての入力フィールドを消す" 80 | "Release exclusive write access for this object" "Release exclusive write access for this object" 81 | "Gain exclusive write access for this object" "Gain exclusive write access for this object" 82 | "Start search" "検索スタート" 83 | "Create new object" "オブジェクトを新規" 84 | "Create a new copy of this object" "このオブジェクトを新しくコピーする" 85 | "Mark this object as \"not deleted\"" "このオブジェクトを消さない状態にする" 86 | "Mark this object as \"deleted\"" "このオブジェクトを消された状態にする" 87 | "Update" "更新" 88 | -------------------------------------------------------------------------------- /loc/jp: -------------------------------------------------------------------------------- 1 | ja -------------------------------------------------------------------------------- /loc/no: -------------------------------------------------------------------------------- 1 | # 28aug17abu 2 | # Jon Kleiser 3 | 4 | "Language" "Språk" 5 | 6 | # lib/db.l 7 | "Boolean input expected" "Boolsk verdi forventet" 8 | "Numeric input expected" "Numerisk verdi forventet" 9 | "Symbolic type expected" "Symbol-type forventet" 10 | "String type expected" "Tekststreng forventet" 11 | "Type error" "Type-feil" 12 | "Not unique" "Ikke unik" 13 | "Input required" "Input-data påkrevet" 14 | 15 | # lib/form.l 16 | "Cancel" "Avbryt" 17 | "Yes" "Ja" 18 | "No" "Nei" 19 | "Select" "Velg" 20 | "Delete row?" "Slett rad?" 21 | "Show" "Vis" 22 | "Bad date format" "Ugyldig datoformat" 23 | "Bad time format" "Ugyldig tidsformat" 24 | "Bad phone number format" "Ugyldig telefonnummer-format" 25 | "male" "mannlig" 26 | "female" "kvinnelig" 27 | "New" "Ny" 28 | "Edit" "Rediger" 29 | "Save" "Lagre" 30 | "Done" "Ferdig" 31 | "Currently edited by '@2' (@1)" "Redigeres nå av '@2' (@1)" 32 | "Search" "Søk" 33 | "Reset" "Tilbakestill" 34 | "New/Copy" "Ny/Kopi" 35 | "Restore" "Gjenopprett" 36 | "Restore @1?" "Gjenopprette @1?" 37 | "Delete" "Slett" 38 | "Delete @1?" "Slett @1?" 39 | "Data not found" "Data ble ikke funnet" 40 | "Undo" "Angre" 41 | "Undo: '@1'" "Angre: '@1'" 42 | "Redo" "Utfør likevel" 43 | "Redo: '@1'" "Utfør likevel: '@1'" 44 | 45 | # General 46 | "login" "logg inn" 47 | "logout" "logg ut" 48 | "' logged in" "' er innlogget" 49 | "Name" "Navn" 50 | "Login Name" "Innloggingsnavn" 51 | "Full Name" "Fullt navn" 52 | "Password" "Passord" 53 | "Permission denied" "Ingen adgangsrett" 54 | "Permissions" "Adgangsrettigheter" 55 | "Role" "Rolle" 56 | "Role Administration" "Rolle-administrasjon" 57 | "Roles" "Roller" 58 | "User" "Bruker" 59 | "User Administration" "Bruker-administrasjon" 60 | "Users" "Brukere" 61 | "Settings" "Innstillinger" 62 | "Phone" "Telefon" 63 | 64 | # Tooltips 65 | "Open submenu" "Åpne undermeny" 66 | "Close submenu" "Lukk undermeny" 67 | "Next object of the same type" "Neste objekt av samme type" 68 | "Find or create an object of the same type" "Finn eller opprett et objekt av samme type" 69 | "Choose a suitable value" "Velg en passende verdi" 70 | "Adopt this value" "Overta denne verdien" 71 | "Go to first line" "Gå til første linje" 72 | "Scroll up one page" "Scroll opp en side" 73 | "Scroll up one line" "Scroll opp en linje" 74 | "Scroll down one line" "Scroll ned en linje" 75 | "Scroll down one page" "Scroll ned en side" 76 | "Go to last line" "Gå til siste linje" 77 | "Insert empty row" "Sett inn tom rad" 78 | "Delete row" "Slett rad" 79 | "Shift row up" "Forskyv en rad opp" 80 | "Clear all input fields" "Slett alle input-felter" 81 | "Release exclusive write access for this object" "Frigi eksklusiv skrivetilgang til dette objektet" 82 | "Gain exclusive write access for this object" "Innhent eksklusiv skrivetilgang til dette objektet" 83 | "Start search" "Start søk" 84 | "Create new object" "Opprett nytt objekt" 85 | "Create a new copy of this object" "Opprett ny kopi av dette objektet" 86 | "Mark this object as \"not deleted\"" "Merk dette objektet som \"ikke slettet\"" 87 | "Mark this object as \"deleted\"" "Merk dette objektet som \"slettet\"" 88 | "Update" "Oppdater" 89 | -------------------------------------------------------------------------------- /loc/ru: -------------------------------------------------------------------------------- 1 | # 17mar21abu 2 | # Mansur Mamkin 3 | # Mike Pechkin 4 | # Constantine Bytensky 5 | 6 | "Language" "Язык" 7 | 8 | # lib/db.l 9 | "Boolean input expected" "Ожидается булев тип" 10 | "Numeric input expected" "Ожидается числовой тип" 11 | "Symbolic type expected" "Ожидается символьный тип" 12 | "String type expected" "Ожидается строковый тип" 13 | "Type error" "Ошибка типа" 14 | "Not unique" "Не уникальный" 15 | "Input required" "Требуется ввод" 16 | 17 | # lib/form.l 18 | "Cancel" "Отменить" 19 | "Yes" "Да" 20 | "No" "Нет" 21 | "Select" "Выбрать" 22 | "Delete row?" "Удалить строку?" 23 | "Show" "Показать" 24 | "Bad date format" "Некорректный формат даты" 25 | "Bad time format" "Некорректный формат времени" 26 | "Bad phone number format" "Некорректный формат номера телефона" 27 | "male" "мужской" 28 | "female" "женский" 29 | "New" "Новый" 30 | "Edit" "Редактировать" 31 | "Save" "Сохранить" 32 | "Done" "Готово" 33 | "Currently edited by '@2' (@1)" "Редактируется пользователем «@2» (@1)" 34 | "Search" "Искать" 35 | "Reset" "Сбросить" 36 | "New/Copy" "Новый/копировать" 37 | "Restore" "Восстановить" 38 | "Restore @1?" "Восстановить @1?" 39 | "Delete" "Удалить" 40 | "Delete @1?" "Удалить @1?" 41 | "Data not found" "Данные не найдены" 42 | "Undo" "Отменить" 43 | "Undo: '@1'" "Отменить: «@1»" 44 | "Redo" "Повторить" 45 | "Redo: '@1'" "Повторить: «@1»" 46 | 47 | # General 48 | "login" "Войти" 49 | "logout" "Выйти" 50 | "' logged in" "' вошёл" 51 | "Name" "Имя" 52 | "Login Name" "Имя пользователя" 53 | "Full Name" "Полное имя" 54 | "Password" "Пароль" 55 | "Permission denied" "В доступе отказано" 56 | "Permissions" "Права доступа" 57 | "Role" "Роль" 58 | "Role Administration" "Управление ролями" 59 | "Roles" "Роли" 60 | "User" "Пользователь" 61 | "User Administration" "Управление пользователями" 62 | "Users" "Пользователи" 63 | "Settings" "Настройки" 64 | "Phone" "Телефон" 65 | 66 | # Tooltips 67 | "Open submenu" "Открыть подменю" 68 | "Close submenu" "Закрыть подменю" 69 | "Next object of the same type" "Следующий объект того же типа" 70 | "Find or create an object of the same type" "Найти или создать объект того же типа" 71 | "Choose a suitable value" "Выберите подходящее значение" 72 | "Adopt this value" "Принять это значение" 73 | "Go to first line" "Перейти к первой строке" 74 | "Scroll up one page" "Прокрутить вверх на одну страницу" 75 | "Scroll up one line" "Прокрутить вверх на одну строку" 76 | "Scroll down one line" "Прокрутить вниз на одну строку" 77 | "Scroll down one page" "Прокрутить вниз на одну страницу" 78 | "Go to last line" "Перейти к последней строке" 79 | "Insert empty row" "Вставить пустую строку" 80 | "Delete row" "Удалить строку" 81 | "Shift row up" "Сдвинуть строку вверх" 82 | "Clear all input fields" "Очистить все поля ввода" 83 | "Release exclusive write access for this object" "Освободить эксклюзивный доступ на запись этого объекта" 84 | "Gain exclusive write access for this object" "Получить эксклюзивный доступ на запись этого объекта" 85 | "Start search" "Начать поиск" 86 | "Create new object" "Создать новый объект" 87 | "Create a new copy of this object" "Создать новую копию этого объекта" 88 | "Mark this object as \"not deleted\"" "Отметить этот объект как «не удалённый»" 89 | "Mark this object as \"deleted\"" "Отметить этот объект как «удалённый»" 90 | "Update" "Обновить" 91 | -------------------------------------------------------------------------------- /loc/sv: -------------------------------------------------------------------------------- 1 | # 28aug17abu 2 | # Mattias Sundblad 3 | 4 | "Language" "Språk" 5 | 6 | # lib/db.l 7 | "Boolean input expected" "Boolskt värde förväntades" 8 | "Numeric input expected" "Numeriskt värde förväntades" 9 | "Symbolic type expected" "Symbol-typ förväntades" 10 | "String type expected" "Sträng förväntades" 11 | "Type error" "Felaktig typ" 12 | "Not unique" "Ej unikt värde" 13 | "Input required" "Obligatoriskt värde" 14 | 15 | # lib/form.l 16 | "Cancel" "Avbryt" 17 | "Yes" "Ja" 18 | "No" "Nej" 19 | "Select" "Välj" 20 | "Delete row?" "Radera rad?" 21 | "Show" "Visa" 22 | "Bad date format" "Ogiltigt datumformat" 23 | "Bad time format" "Ogiltigt tidsformat" 24 | "Bad phone number format" "Ogiltigt telefonnummerformat" 25 | "male" "Man" 26 | "female" "Kvinna" 27 | "New" "Ny" 28 | "Edit" "Redigera" 29 | "Save" "Spara" 30 | "Done" "Klar" 31 | "Currently edited by '@2' (@1)" "Redigeras nu av '@2' (@1)" 32 | "Search" "Sök" 33 | "Reset" "Återställ" 34 | "New/Copy" "Ny/Kopiera" 35 | "Restore" "Återställ" 36 | "Restore @1?" "Återställ @1?" 37 | "Delete" "Radera" 38 | "Delete @1?" "Radera @1?" 39 | "Data not found" "Ingen data hittades" 40 | "Undo" "Ångra" 41 | "Undo: '@1'" "Ångra: '@1'" 42 | "Redo" "Upprepa" 43 | "Redo: '@1'" "Upprepa: '@1'" 44 | 45 | # General 46 | "login" "Logga in" 47 | "logout" "Logga ut" 48 | "' logged in" "' är inloggad" 49 | "Name" "Namn" 50 | "Login Name" "Användarnamn" 51 | "Full Name" "För- och efternamn" 52 | "Password" "Lösenord" 53 | "Permission denied" "Ej behörig" 54 | "Permissions" "Behörigheter" 55 | "Role" "Roll" 56 | "Role Administration" "Rollhantering" 57 | "Roles" "Roller" 58 | "User" "Användare" 59 | "User Administration" "Användarhantering" 60 | "Users" "Användare" 61 | "Settings" "Inställningar" 62 | "Phone" "Telefon" 63 | 64 | # Tooltips 65 | "Open submenu" "Öppna undermeny" 66 | "Close submenu" "Stäng undermeny" 67 | "Next object of the same type" "Nästa objekt av samma typ" 68 | "Find or create an object of the same type" "Hitta eller skapa ett objekt av samma typ" 69 | "Choose a suitable value" "Välj ett värde" 70 | "Adopt this value" "Använd detta värde" 71 | "Go to first line" "Gå till första raden" 72 | "Scroll up one page" "Bläddra en sida framåt" 73 | "Scroll up one line" "Gå upp en rad" 74 | "Scroll down one line" "Gå ner en rad" 75 | "Scroll down one page" "Bläddra en sida bakåt" 76 | "Go to last line" "Gå till sista raden" 77 | "Insert empty row" "Infoga ny rad" 78 | "Delete row" "Radera raden" 79 | "Shift row up" "Flytta raden uppåt" 80 | "Clear all input fields" "Töm alla fält" 81 | "Release exclusive write access for this object" "Släpp lås för detta objekt" 82 | "Gain exclusive write access for this object" "Lås detta objekt" 83 | "Start search" "Sök" 84 | "Create new object" "Skapa nytt objekt" 85 | "Create a new copy of this object" "Skapa en kopia av detta objekt" 86 | "Mark this object as \"not deleted\"" "Markera detta objekt som \"ej raderat\"" 87 | "Mark this object as \"deleted\"" "Markera detta objekt som \"raderat\"" 88 | "Update" "Uppdatera" 89 | -------------------------------------------------------------------------------- /loc/tr: -------------------------------------------------------------------------------- 1 | # 22nov21 Software Lab. Alexander Burger 2 | 3 | -------------------------------------------------------------------------------- /loc/uk: -------------------------------------------------------------------------------- 1 | # 17mar21abu 2 | # Constantine Bytensky 3 | 4 | "Language" "Мова" 5 | 6 | # lib/db.l 7 | "Boolean input expected" "Очікується булевий тип" 8 | "Numeric input expected" "Очікується числовий тип" 9 | "Symbolic type expected" "Очікується символьний тип" 10 | "String type expected" "Очікується строковий тип" 11 | "Type error" "Помилка типу" 12 | "Not unique" "Не унікальний" 13 | "Input required" "Потребується введення" 14 | 15 | # lib/form.l 16 | "Cancel" "Відмінити" 17 | "Yes" "Так" 18 | "No" "Ні" 19 | "Select" "Вибрати" 20 | "Delete row?" "Видалити строку?" 21 | "Show" "Показати" 22 | "Bad date format" "Неправильний формат дати" 23 | "Bad time format" "Неправильний формат часу" 24 | "Bad phone number format" "Неправильний формат номера телефону" 25 | "male" "чоловіча" 26 | "female" "жіноча" 27 | "New" "Новий" 28 | "Edit" "Редагувати" 29 | "Save" "Зберегти" 30 | "Done" "Готово" 31 | "Currently edited by '@2' (@1)" "Редагується користувачем «@2» (@1)" 32 | "Search" "Шукати" 33 | "Reset" "Скинути" 34 | "New/Copy" "Новий/копіювати" 35 | "Restore" "Відновити" 36 | "Restore @1?" "Відновити @1?" 37 | "Delete" "Видалити" 38 | "Delete @1?" "Видалити @1?" 39 | "Data not found" "Дані не знайдені" 40 | "Undo" "Відмінити" 41 | "Undo: '@1'" "Відмінити: «@1»" 42 | "Redo" "Повторити" 43 | "Redo: '@1'" "Повторити: «@1»" 44 | 45 | # General 46 | "login" "Увійти" 47 | "logout" "Вийти" 48 | "' logged in" "' увійшов" 49 | "Name" "Ім’я" 50 | "Login Name" "Ім’я користувача" 51 | "Full Name" "Повне ім’я" 52 | "Password" "Пароль" 53 | "Permission denied" "У доступі відмовлено" 54 | "Permissions" "Права доступу" 55 | "Role" "Роль" 56 | "Role Administration" "Управління ролями" 57 | "Roles" "Ролі" 58 | "User" "Користувач" 59 | "User Administration" "Управління користувачами" 60 | "Users" "Користувачі" 61 | "Settings" "Налаштування" 62 | "Phone" "Телефон" 63 | 64 | # Tooltips 65 | "Open submenu" "Відкрити підменю" 66 | "Close submenu" "Закрити підменю" 67 | "Next object of the same type" "Наступний об’ект цього ж типу" 68 | "Find or create an object of the same type" "Знайти або створити об’ект цього ж типу" 69 | "Choose a suitable value" "Оберіть відповідне значення" 70 | "Adopt this value" "Прийняти це значення" 71 | "Go to first line" "Перейти до першого рядка" 72 | "Scroll up one page" "Прокрутити вгору на одну сторінку" 73 | "Scroll up one line" "Прокрутити вгору на один рядок" 74 | "Scroll down one line" "Прокрутити вниз на один рядок" 75 | "Scroll down one page" "Прокрутити вниз на одну сторінку" 76 | "Go to last line" "Перейти до останнього рядка" 77 | "Insert empty row" "Вставити пустий рядок" 78 | "Delete row" "Видалити рядок" 79 | "Shift row up" "Зсунути рядок вгору" 80 | "Clear all input fields" "Очистити усі поля введення" 81 | "Release exclusive write access for this object" "Звільнити ексклюзивний доступ на запис цього об’єкту" 82 | "Gain exclusive write access for this object" "Отримати ексклюзивний доступ на запис цього об’єкту" 83 | "Start search" "Почати пошук" 84 | "Create new object" "Створити новый об’єкт" 85 | "Create a new copy of this object" "Створити нову копію цього об’єкту" 86 | "Mark this object as \"not deleted\"" "Позначити цей об’єкт як «не видаленний»" 87 | "Mark this object as \"deleted\"" "Позначити цей об’єкт як «видаленний»" 88 | "Update" "Оновити" 89 | -------------------------------------------------------------------------------- /man/man1/picolisp.1: -------------------------------------------------------------------------------- 1 | .\" 26oct20abu 2 | .\" 3 | .TH PICOLISP 1 "" "" "User Commands" 4 | .SH NAME 5 | pil, picolisp \- a fast, lightweight Lisp interpreter 6 | .SH SYNOPSIS 7 | .B pil 8 | [arguments ...] [-] [arguments ...] [+] 9 | .br 10 | .B picolisp 11 | [arguments ...] [-] [arguments ...] [+] 12 | .SH DESCRIPTION 13 | .B PicoLisp 14 | is a Lisp interpreter with a small memory footprint, yet relatively high 15 | execution speed. It combines an elegant and powerful language with built-in 16 | database functionality. 17 | .P 18 | .B pil 19 | is the startup front-end for the interpreter. It takes care of starting the 20 | binary base system and loading a useful runtime environment. 21 | .P 22 | .B picolisp 23 | is just the bare interpreter binary. It is usually called in stand-alone 24 | scripts, using the she-bang notation in the first line, passing the minimal 25 | environment in 26 | .I lib.l 27 | and loading additional files as needed: 28 | .P 29 | .RS 30 | #!/usr/bin/picolisp /usr/lib/picolisp/lib.l 31 | .RE 32 | .RS 33 | (load "@ext.l" "myfiles/lib.l" "myfiles/foo.l") 34 | .RE 35 | .RS 36 | (do ... something ...) 37 | .RE 38 | .RS 39 | (bye) 40 | .RE 41 | .SH INVOCATION 42 | .B PicoLisp 43 | has no pre-defined command line flags; applications are free to define their 44 | own. Any built-in or user-level Lisp function can be invoked from the command 45 | line by prefixing it with a hyphen. Examples for built-in functions useful in 46 | this context are 47 | .B version 48 | (print the version number) or 49 | .B bye 50 | (exit the interpreter). Therefore, a minimal call to print the version number 51 | and then immediately exit the interpreter would be: 52 | .P 53 | .RS 54 | $ pil -version -bye 55 | .RE 56 | .P 57 | Any other argument (not starting with a hyphen) should be the name of a file to 58 | be loaded. If the first character of a path or file name is an at-mark, it 59 | will be substituted with the path to the installation directory. 60 | .P 61 | All arguments are evaluated from left to right, then an interactive 62 | .I read-eval-print 63 | loop is entered (with a colon as prompt). 64 | .P 65 | A single hyphen stops the evaluation of the rest of the command line, so that 66 | the remaining arguments may be processed under program control. 67 | .P 68 | If the very last command line argument is a single plus character, debugging 69 | mode is switched on at interpreter startup, before evaluating any of the command 70 | line arguments. A minimal interactive session is started with: 71 | .P 72 | .RS 73 | $ pil + 74 | .RE 75 | .P 76 | Here you can access the reference manual (expects the shell variable BROWSER to 77 | be set, defaults to "w3m") 78 | .P 79 | .RS 80 | : (doc) 81 | .RE 82 | .P 83 | and the online documentation for most functions, 84 | .P 85 | .RS 86 | : (doc 'vi) 87 | .RE 88 | .P 89 | or directly inspect their sources: 90 | .P 91 | .RS 92 | : (vi 'doc) 93 | .RE 94 | .P 95 | The interpreter can be terminated with 96 | .P 97 | .RS 98 | : (bye) 99 | .RE 100 | .P 101 | or by typing Ctrl-D. 102 | .SH FILES 103 | Runtime files are maintained in the ~/.pil directory: 104 | .IP ~/.pil/tmp// 105 | Process-local temporary directories 106 | .IP ~/.pil/rc 107 | Loaded after interpreter startup 108 | .IP ~/.pil/viprc 109 | Loaded by the Vip editor 110 | .SH BUGS 111 | .B PicoLisp 112 | doesn't try to protect you from every possible programming error ("You asked for 113 | it, you got it"). 114 | .SH AUTHOR 115 | Alexander Burger 116 | .SH RESOURCES 117 | .B Home page: 118 | http://home.picolisp.com 119 | .br 120 | .B Download: 121 | http://www.software-lab.de/down.html 122 | -------------------------------------------------------------------------------- /man/man1/pil.1: -------------------------------------------------------------------------------- 1 | .so man1/picolisp.1 2 | -------------------------------------------------------------------------------- /misc/bigtest: -------------------------------------------------------------------------------- 1 | #!bin/picolisp lib.l 2 | # 26may22abu 3 | # misc/bigtest 4 | 5 | (load "@lib/misc.l") 6 | 7 | (seed (car (argv))) 8 | 9 | # Random patterns: 10 | # cnt 11 | # xxx0000000000000000000000000xxxx0000000000000000000000000xxx 12 | # (| 7 (>> -28 15) (>> -57 7)) 13 | # 14 | # xxx1111111111111111111111111xxxx1111111111111111111111111xxx 15 | # 1FFFFFF0FFFFFF8 16 | # 17 | # 18 | # dig 19 | # xxx000000000000000000000000000xxxx000000000000000000000000000xxx 20 | # (| 7 (>> -30 15) (>> -61 7)) 21 | # 22 | # xxx111111111111111111111111111xxxx111111111111111111111111111xxx 23 | # 1FFFFFFC3FFFFFF8 24 | 25 | (de rnd () 26 | (let Big (| (rand 0 7) (>> -28 (rand 0 15)) (>> -57 (rand 0 7))) 27 | (when (rand T) 28 | (setq Big (| Big `(hex "1FFFFFF0FFFFFF8"))) ) 29 | (do (rand 0 2) 30 | (let Dig (| (rand 0 7) (>> -30 (rand 0 15)) (>> -61 (rand 0 7))) 31 | (when (rand T) 32 | (setq Dig (| Dig `(hex "1FFFFFFC3FFFFFF8"))) ) 33 | (setq Big (| Dig (>> -64 Big))) ) ) 34 | (if (rand T) Big (- Big)) ) ) 35 | 36 | 37 | (de test1 (S N1) 38 | (let (N (read) X (eval (list S N1))) 39 | (unless (= N X) 40 | (prinl "\n" N ": (" S " " N1 ") -> " X) 41 | (bye) ) ) ) 42 | 43 | (de test2 (S N1 N2) 44 | (let (N (read) X (eval (list S N1 N2))) 45 | (unless (= N X) 46 | (prinl "\n" N ": (" S " " N1 " " N2 ") -> " X) 47 | (bye) ) ) ) 48 | 49 | (de cmp2 (S N1 N2) 50 | (let (N (n0 (read)) X (eval (list S N1 N2))) 51 | (unless (== N X) 52 | (prinl "\n" N ": (" S " " N1 " " N2 ") -> " X) 53 | (bye) ) ) ) 54 | 55 | 56 | (sys "BC_LINE_LENGTH" "200") 57 | 58 | (pipe 59 | (out '("bc") 60 | (do 10000000 61 | (setq N1 (rnd)) 62 | (while (=0 (setq N2 (rnd)))) 63 | (prinl N1) 64 | (prinl N2) 65 | (prinl N1 " + " N2) 66 | (prinl N1 " + 1") 67 | (prinl N1 " + 1") 68 | (prinl N1 " - " N2) 69 | (prinl N1 " - 1") 70 | (prinl N1 " - 1") 71 | (prinl N1 " * " N2) 72 | (prinl N1 " * 2") 73 | (prinl N1 " % " N2) 74 | (prinl N1 " / " N2) 75 | (prinl N1 " / 2") 76 | (prinl N1 " >= " N2) 77 | (prinl N1 " > " N2) 78 | (prinl "sqrt(" (abs N1) ")") 79 | (at (0 . 1000) (wait 100)) ) ) 80 | (do 100 81 | (do 100000 82 | (setq 83 | N1 (read) 84 | N2 (read) ) 85 | (test2 '+ N1 N2) 86 | (test2 '+ N1 1) 87 | (test1 'inc N1) 88 | (test2 '- N1 N2) 89 | (test2 '- N1 1) 90 | (test1 'dec N1) 91 | (test2 '* N1 N2) 92 | (test2 '* N1 2) 93 | (test2 '% N1 N2) 94 | (test2 '/ N1 N2) 95 | (test2 '/ N1 2) 96 | (cmp2 '>= N1 N2) 97 | (cmp2 '> N1 N2) 98 | (test1 'sqrt (abs N1)) ) 99 | (prin ".") 100 | (flush) ) 101 | (prinl) ) 102 | 103 | (bye) 104 | -------------------------------------------------------------------------------- /misc/stress.l: -------------------------------------------------------------------------------- 1 | # 18oct20 Software Lab. Alexander Burger 2 | # Use: nice pil misc/stress.l -main -go -bye; rm db/test jnl db/test2 3 | 4 | (load "@lib/too.l") 5 | 6 | (class +A +Entity) 7 | (rel key (+Key +Number)) # Key 1 .. 999 8 | (rel dat (+Ref +Number)) # Data 1 .. 999 9 | 10 | (de rnd () 11 | (rand 1 999) ) 12 | 13 | (de modify (N) 14 | (do N 15 | (do (rand 10 40) 16 | (let K (rnd) 17 | (with (db 'key '+A K) 18 | (unless (= K (: key)) 19 | (quit "key mismatch" K) ) ) ) ) 20 | (dbSync) 21 | (let (D (rnd) X (db 'key '+A (rnd))) 22 | (inc *DB (- D (get X 'dat))) 23 | (put> X 'dat D) ) 24 | (commit 'upd) ) ) 25 | 26 | (de verify () 27 | (dbCheck) 28 | (let N 0 29 | (scan (tree 'dat '+A) 30 | '((K V) 31 | (unless (= (car K) (get V 'dat)) 32 | (quit "dat mismatch" K) ) 33 | (inc 'N (car K)) ) ) 34 | (unless (= N (val *DB)) 35 | (quit "val mismatch" (- N (val *DB))) ) ) ) 36 | 37 | (de main () 38 | (seed (in "/dev/urandom" (rd 8))) 39 | (call "mkdir" "-p" "db") 40 | (call "rm" "-f" "db/test" "jnl" "db/test2") 41 | (pool "db/test" NIL "jnl") 42 | (set *DB 0) 43 | (for K 999 44 | (let D (rnd) 45 | (new T '(+A) 'key K 'dat D) 46 | (inc *DB D) ) ) 47 | (commit) ) 48 | 49 | (de go () 50 | (do 12 51 | (do 99 52 | (rand) 53 | (unless (fork) 54 | (modify 999) 55 | (bye) ) ) 56 | (while (kids) 57 | (wait 999) ) 58 | (rollback) ) 59 | (verify) 60 | (pool "db/test2") 61 | (journal "jnl") 62 | (call "cmp" "db/test" "db/test2") ) 63 | -------------------------------------------------------------------------------- /pil: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | exec ${0%/*}/bin/picolisp ${0%/*}/lib.l @ext.l "$@" 3 | -------------------------------------------------------------------------------- /src/Makefile: -------------------------------------------------------------------------------- 1 | # 23dec24 Software Lab. Alexander Burger 2 | 3 | .SILENT: 4 | 5 | CC = clang 6 | PIL = ../pil # pil 7 | ASM = opt -O2 # llvm-as 8 | LLC = llc 9 | LINK = llvm-link 10 | SHARED = -shared 11 | STRIP = strip 12 | 13 | LLVM = $(shell llvm-config --version | cut -d. -f1) 14 | ifeq ($(shell test $(LLVM) -ge 15 -a $(LLVM) -lt 17; echo $$?), 0) 15 | ASM += -opaque-pointers 16 | endif 17 | 18 | OS = $(shell uname) 19 | CPU = $(shell uname -m) 20 | 21 | BIN = ../bin 22 | LIB = ../lib 23 | 24 | INC = lib/llvm.l vers.l defs.l glob.l dec.l 25 | SRC = main.l gc.l big.l sym.l io.l db.l apply.l flow.l subr.l 26 | 27 | all: $(LIB)/sysdefs $(BIN)/picolisp $(LIB)/ext.so $(LIB)/ht.so $(BIN)/balance $(BIN)/ssl $(BIN)/httpGate 28 | 29 | # System definitions 30 | $(LIB)/sysdefs: sysdefs.c 31 | $(CC) -w -D_OS='"$(OS)"' -D_CPU='"$(CPU)"' sysdefs.c && ./a.out > $(LIB)/sysdefs && rm ./a.out 32 | 33 | # Base system 34 | $(BIN)/picolisp: picolisp.bc 35 | mkdir -p $(BIN) $(LIB) 36 | $(LLC) picolisp.bc -relocation-model=pic -o picolisp.s 37 | $(CC) picolisp.s -o $(BIN)/picolisp -rdynamic -lc -lutil -lm -ldl `pkg-config --libs readline libffi` 38 | $(STRIP) $(BIN)/picolisp 39 | 40 | picolisp.bc: base.bc lib.bc 41 | $(LINK) -o picolisp.bc base.bc lib.bc 42 | 43 | base.bc: base.ll 44 | $(ASM) -o base.bc base.ll 45 | 46 | base.ll: $(INC) $(SRC) 47 | $(PIL) lib/llvm.l main.l -bye > base.ll 48 | mv base.map $(LIB)/map 49 | 50 | lib.bc: pico.h lib.c 51 | $(CC) -O3 -w -c -o lib.bc -D_OS='"$(OS)"' -D_CPU='"$(CPU)"' `pkg-config --cflags libffi` -emit-llvm lib.c 52 | 53 | # Extension libraries 54 | $(LIB)/ext.so: ext.bc 55 | $(LLC) ext.bc -relocation-model=pic -o ext.s 56 | $(CC) ext.s -o $(LIB)/ext.so $(SHARED) 57 | $(STRIP) $(LIB)/ext.so 58 | 59 | ext.bc: ext.ll 60 | $(ASM) -o ext.bc ext.ll 61 | 62 | ext.ll: $(INC) ext.l 63 | $(PIL) lib/llvm.l ext.l -bye > ext.ll 64 | 65 | $(LIB)/ht.so: ht.bc 66 | $(LLC) ht.bc -relocation-model=pic -o ht.s 67 | $(CC) ht.s -o $(LIB)/ht.so $(SHARED) 68 | $(STRIP) $(LIB)/ht.so 69 | 70 | ht.bc: ht.ll 71 | $(ASM) -o ht.bc ht.ll 72 | 73 | ht.ll: $(INC) ht.l 74 | $(PIL) lib/llvm.l ht.l -bye > ht.ll 75 | 76 | # Tools 77 | $(BIN)/balance: balance.c 78 | $(CC) -O3 -w -o $(BIN)/balance balance.c 79 | $(STRIP) $(BIN)/balance 80 | 81 | # Gate 82 | $(BIN)/ssl: ssl.c 83 | $(CC) -O3 -w -o $(BIN)/ssl ssl.c -lssl -lcrypto 84 | $(STRIP) $(BIN)/ssl 85 | 86 | $(BIN)/httpGate: httpGate.c 87 | $(CC) -O3 -w -o $(BIN)/httpGate httpGate.c -lssl -lcrypto 88 | $(STRIP) $(BIN)/httpGate 89 | 90 | # Clean up 91 | clean: 92 | rm -f *.ll *.bc *.s 93 | 94 | clean2: clean 95 | rm -f $(LIB)/sysdefs $(BIN)/balance $(BIN)/ssl $(BIN)/httpGate 96 | -------------------------------------------------------------------------------- /src/Makefile.macos: -------------------------------------------------------------------------------- 1 | # 23dec24 Software Lab. Alexander Burger 2 | 3 | CC = clang-19 4 | PIL = ../pil # pil 5 | ASM = opt -O2 # llvm-as 6 | LLC = llc 7 | LINK = llvm-link 8 | SHARED = -dynamiclib -undefined dynamic_lookup 9 | STRIP = true 10 | export PKG_CONFIG_PATH := $(HOMEBREW_PREFIX)/opt/readline/lib/pkgconfig:$(HOMEBREW_PREFIX)/opt/libffi/lib/pkgconfig:$(HOMEBREW_PREFIX)/opt/openssl/lib/pkgconfig 11 | 12 | LLVM = $(shell llvm-config --version | cut -d. -f1) 13 | ifeq ($(shell test $(LLVM) -ge 15 -a $(LLVM) -lt 17; echo $$?), 0) 14 | ASM += -opaque-pointers 15 | endif 16 | 17 | OS = $(shell uname) 18 | CPU = $(shell uname -m) 19 | 20 | BIN = ../bin 21 | LIB = ../lib 22 | 23 | INC = lib/llvm.l vers.l defs.l glob.l dec.l 24 | SRC = main.l gc.l big.l sym.l io.l db.l apply.l flow.l subr.l 25 | 26 | all: $(LIB)/sysdefs $(BIN)/picolisp $(LIB)/ext.so $(LIB)/ht.so $(BIN)/balance $(BIN)/ssl $(BIN)/httpGate 27 | 28 | # System definitions 29 | $(LIB)/sysdefs: sysdefs.c 30 | $(CC) -w -D_OS='"$(OS)"' -D_CPU='"$(CPU)"' sysdefs.c && ./a.out > $(LIB)/sysdefs && rm ./a.out 31 | 32 | # Base system 33 | $(BIN)/picolisp: picolisp.bc 34 | mkdir -p $(BIN) $(LIB) 35 | $(LLC) picolisp.bc -relocation-model=pic -o picolisp.s 36 | $(CC) picolisp.s -o $(BIN)/picolisp -rdynamic -lc -lutil -lm -ldl `pkg-config --libs readline libffi` 37 | $(STRIP) $(BIN)/picolisp 38 | 39 | picolisp.bc: base.bc lib.bc 40 | $(LINK) -o picolisp.bc base.bc lib.bc 41 | 42 | base.bc: base.ll 43 | $(ASM) -o base.bc base.ll 44 | 45 | base.ll: $(INC) $(SRC) 46 | $(PIL) lib/llvm.l main.l -bye > base.ll 47 | mv base.map $(LIB)/map 48 | 49 | lib.bc: pico.h lib.c 50 | $(CC) -O3 -w -c -o lib.bc -D_OS='"$(OS)"' -D_CPU='"$(CPU)"' `pkg-config --cflags libffi` `pkg-config --cflags readline` -emit-llvm lib.c 51 | 52 | # Extension libraries 53 | $(LIB)/ext.so: ext.bc 54 | $(LLC) ext.bc -relocation-model=pic -o ext.s 55 | $(CC) ext.s -o $(LIB)/ext.so $(SHARED) 56 | $(STRIP) $(LIB)/ext.so 57 | 58 | ext.bc: ext.ll 59 | $(ASM) -o ext.bc ext.ll 60 | 61 | ext.ll: $(INC) ext.l 62 | $(PIL) lib/llvm.l ext.l -bye > ext.ll 63 | 64 | $(LIB)/ht.so: ht.bc 65 | $(LLC) ht.bc -relocation-model=pic -o ht.s 66 | $(CC) ht.s -o $(LIB)/ht.so $(SHARED) 67 | $(STRIP) $(LIB)/ht.so 68 | 69 | ht.bc: ht.ll 70 | $(ASM) -o ht.bc ht.ll 71 | 72 | ht.ll: $(INC) ht.l 73 | $(PIL) lib/llvm.l ht.l -bye > ht.ll 74 | 75 | # Tools 76 | $(BIN)/balance: balance.c 77 | $(CC) -O3 -w -o $(BIN)/balance balance.c 78 | $(STRIP) $(BIN)/balance 79 | 80 | # Gate 81 | $(BIN)/ssl: ssl.c 82 | $(CC) -O3 -w -o $(BIN)/ssl ssl.c `pkg-config --cflags --libs openssl` 83 | $(STRIP) $(BIN)/ssl 84 | 85 | $(BIN)/httpGate: httpGate.c 86 | $(CC) -O3 -w -o $(BIN)/httpGate httpGate.c `pkg-config --cflags --libs openssl` 87 | $(STRIP) $(BIN)/httpGate 88 | 89 | # Clean up 90 | clean: 91 | rm -f *.ll *.bc *.s 92 | 93 | clean2: clean 94 | rm -f $(LIB)/sysdefs $(BIN)/balance $(BIN)/ssl $(BIN)/httpGate 95 | -------------------------------------------------------------------------------- /src/Makefile.openbsd: -------------------------------------------------------------------------------- 1 | # 29mar24 Software Lab. Alexander Burger 2 | 3 | #.SILENT: 4 | 5 | CC = clang-19 6 | PIL = ../pil # pil 7 | ASM = opt-19 -O3 # llvm-as 8 | LLC = llc-19 9 | LINK = llvm-link-19 10 | MAIN = -rdynamic -lc -lutil -lm -lereadline -L/usr/local/lib -lffi -lncursesw -Wl,-z,nobtcfi 11 | SHARED = -shared 12 | STRIP = strip 13 | 14 | LLVM = $(shell llvm-config-19 --version | cut -d. -f1) 15 | ifeq ($(shell test $(LLVM) -ge 15 -a $(LLVM) -lt 17; echo $$?), 0) 16 | ASM += -opaque-pointers 17 | endif 18 | 19 | OS = $(shell uname) 20 | CPU = $(shell uname -m) 21 | 22 | BIN = ../bin 23 | LIB = ../lib 24 | 25 | INC = lib/llvm.l vers.l defs.l glob.l dec.l 26 | SRC = main.l gc.l big.l sym.l io.l db.l apply.l flow.l subr.l 27 | 28 | all: $(LIB)/sysdefs $(BIN)/picolisp $(LIB)/ext.so $(LIB)/ht.so $(BIN)/balance $(BIN)/ssl $(BIN)/httpGate 29 | 30 | # System definitions 31 | $(LIB)/sysdefs: sysdefs.c 32 | $(CC) -w -D_OS='"$(OS)"' -D_CPU='"$(CPU)"' sysdefs.c && ./a.out > $(LIB)/sysdefs && rm ./a.out 33 | 34 | # Base system 35 | $(BIN)/picolisp: picolisp.bc 36 | mkdir -p $(BIN) $(LIB) 37 | $(LLC) picolisp.bc -relocation-model=pic -o picolisp.s 38 | $(CC) picolisp.s -o $(BIN)/picolisp $(MAIN) 39 | $(STRIP) $(BIN)/picolisp 40 | 41 | picolisp.bc: base.bc lib.bc 42 | $(LINK) -o picolisp.bc base.bc lib.bc 43 | 44 | base.bc: base.ll 45 | $(ASM) -o base.bc base.ll 46 | 47 | base.ll: $(INC) $(SRC) 48 | $(PIL) lib/llvm.l main.l -bye > base.ll 49 | mv base.map $(LIB)/map 50 | 51 | lib.bc: pico.h lib.c 52 | $(CC) -O3 -w -c -o lib.bc -D_OS='"$(OS)"' -D_CPU='"$(CPU)"' -I/usr/local/include -I/usr/local/include/ereadline -emit-llvm lib.c 53 | 54 | # Extension libraries 55 | $(LIB)/ext.so: ext.bc 56 | $(LLC) ext.bc -relocation-model=pic -o ext.s 57 | $(CC) ext.s -o $(LIB)/ext.so $(SHARED) 58 | $(STRIP) $(LIB)/ext.so 59 | 60 | ext.bc: ext.ll 61 | $(ASM) -o ext.bc ext.ll 62 | 63 | ext.ll: $(INC) ext.l 64 | $(PIL) lib/llvm.l ext.l -bye > ext.ll 65 | 66 | $(LIB)/ht.so: ht.bc 67 | $(LLC) ht.bc -relocation-model=pic -o ht.s 68 | $(CC) ht.s -o $(LIB)/ht.so $(SHARED) 69 | $(STRIP) $(LIB)/ht.so 70 | 71 | ht.bc: ht.ll 72 | $(ASM) -o ht.bc ht.ll 73 | 74 | ht.ll: $(INC) ht.l 75 | $(PIL) lib/llvm.l ht.l -bye > ht.ll 76 | 77 | # Tools 78 | $(BIN)/balance: balance.c 79 | $(CC) -O3 -w -o $(BIN)/balance balance.c 80 | $(STRIP) $(BIN)/balance 81 | 82 | # Gate 83 | $(BIN)/ssl: ssl.c 84 | $(CC) -O3 -w -o $(BIN)/ssl ssl.c -lssl -lcrypto 85 | $(STRIP) $(BIN)/ssl 86 | 87 | $(BIN)/httpGate: httpGate.c 88 | $(CC) -O3 -w -o $(BIN)/httpGate httpGate.c -lssl -lcrypto 89 | $(STRIP) $(BIN)/httpGate 90 | 91 | # Clean up 92 | clean: 93 | rm -f *.ll *.bc *.s 94 | 95 | clean2: clean 96 | rm -f $(LIB)/sysdefs $(BIN)/balance $(BIN)/ssl $(BIN)/httpGate 97 | -------------------------------------------------------------------------------- /src/balance.c: -------------------------------------------------------------------------------- 1 | /* balance.c 2 | * 06jul05abu 3 | */ 4 | 5 | #include 6 | #include 7 | #include 8 | #include 9 | #include 10 | #include 11 | #include 12 | 13 | int Len, Siz; 14 | char *Line, **Data; 15 | 16 | static void giveup(char *msg) { 17 | fprintf(stderr, "balance: %s\n", msg); 18 | exit(1); 19 | } 20 | 21 | static char *getLine(FILE *fp) { 22 | int i, c; 23 | char *s; 24 | 25 | i = 0; 26 | while ((c = getc_unlocked(fp)) != '\n') { 27 | if (c == EOF) 28 | return NULL; 29 | Line[i] = c; 30 | if (++i == Len && !(Line = realloc(Line, Len *= 2))) 31 | giveup("No memory"); 32 | } 33 | Line[i] = '\0'; 34 | if (!(s = strdup(Line))) 35 | giveup("No memory"); 36 | return s; 37 | } 38 | 39 | static void balance(char **data, int len) { 40 | if (len) { 41 | int n = (len + 1) / 2; 42 | char **p = data + n - 1; 43 | 44 | printf("%s\n", *p); 45 | balance(data, n - 1); 46 | balance(p + 1, len - n); 47 | } 48 | } 49 | 50 | // balance [- [ ..]] 51 | // balance [] 52 | int main(int ac, char *av[]) { 53 | int cnt; 54 | char *s; 55 | pid_t pid = 0; 56 | FILE *fp = stdin; 57 | 58 | if (ac > 1) { 59 | if (*av[1] == '-') { 60 | int pfd[2]; 61 | 62 | if (pipe(pfd) < 0) 63 | giveup("Pipe error\n"); 64 | if ((pid = fork()) == 0) { 65 | close(pfd[0]); 66 | if (pfd[1] != STDOUT_FILENO) 67 | dup2(pfd[1], STDOUT_FILENO), close(pfd[1]); 68 | execvp(av[1]+1, av+1); 69 | } 70 | if (pid < 0) 71 | giveup("Fork error\n"); 72 | close(pfd[1]); 73 | if (!(fp = fdopen(pfd[0], "r"))) 74 | giveup("Pipe open error\n"); 75 | } 76 | else if (!(fp = fopen(av[1], "r"))) 77 | giveup("File open error\n"); 78 | } 79 | Line = malloc(Len = 4096); 80 | Data = malloc((Siz = 4096) * sizeof(char*)); 81 | for (cnt = 0; s = getLine(fp); ++cnt) { 82 | if (cnt == Siz && !(Data = realloc(Data, (Siz *= 2) * sizeof(char*)))) 83 | giveup("No memory"); 84 | Data[cnt] = s; 85 | } 86 | if (pid) { 87 | fclose(fp); 88 | while (waitpid(pid, NULL, 0) < 0) 89 | if (errno != EINTR) 90 | giveup("Pipe close error\n"); 91 | } 92 | balance(Data, cnt); 93 | return 0; 94 | } 95 | -------------------------------------------------------------------------------- /src/defs.l: -------------------------------------------------------------------------------- 1 | # 28sep20 Software Lab. Alexander Burger 2 | 3 | (symbols '(llvm)) 4 | 5 | # Constants 6 | (local) (HEAP CELLS STACK TOP BUFSIZ DB1) 7 | 8 | (equ 9 | HEAP (*/ 1024 1024 8) # Heap size (number of pointers) 10 | CELLS (/ HEAP 2) # Number of cells in a heap (65536) 11 | STACK (* 64 1024) # Default coroutine stack size (64 kB) 12 | TOP (hex "110000") # Character top 13 | BUFSIZ 4096 # I/O buffer size 14 | DB1 (hex "1A") # Name of '{1}' 15 | 292MY (dec (** 2 63)) ) # 292 million years 16 | 17 | # PLIO Tokens 18 | (local) (NIX BEG DOT END NUMBER INTERN TRANSIENT EXTERN) 19 | 20 | (equ 21 | NIX 0 # NIL 22 | BEG 1 # Begin list 23 | DOT 2 # Dotted pair 24 | END 3 # End list 25 | NUMBER 0 # Number 26 | INTERN 1 # Internal symbol 27 | TRANSIENT 2 # Transient symbol 28 | EXTERN 3 ) # External symbol 29 | 30 | # DB-I/O 31 | (local) (BLK BLKSIZE BLKMASK BLKTAG) 32 | 33 | (equ 34 | BLK 6 # Block address size 35 | BLKSIZE 64 # DB block unit size 36 | BLKMASK -64 # Block address mask 37 | BLKTAG 63 ) # Block tag mask 38 | 39 | ## Sync src/lib.c 'gSignal' and src/glob.l '$Signal' 40 | (local) (SIGHUP SIGINT SIGUSR1 SIGUSR2 SIGPIPE SIGALRM SIGTERM SIGCHLD SIGCONT 41 | SIGSTOP SIGTSTP SIGTTIN SIGTTOU SIGWINCH SIGIO) 42 | 43 | (equ 44 | SIGHUP 1 45 | SIGINT 2 46 | SIGUSR1 3 47 | SIGUSR2 4 48 | SIGPIPE 5 49 | SIGALRM 6 50 | SIGTERM 7 51 | SIGCHLD 8 52 | SIGCONT 9 53 | SIGSTOP 10 54 | SIGTSTP 11 55 | SIGTTIN 12 56 | SIGTTOU 13 57 | SIGWINCH 14 58 | SIGIO 15 ) 59 | 60 | ## Sync src/lib.c 'gErrno' 61 | (local) (ENOENT EINTR EBADF EAGAIN EACCES EPIPE ECONNRESET) 62 | 63 | (equ 64 | ENOENT 1 # No such file or directory 65 | EINTR 2 # Interrupted system call 66 | EBADF 3 # Bad file number 67 | EAGAIN 4 # Try again 68 | EACCES 5 # Permission denied 69 | EPIPE 6 # Broken pipe 70 | ECONNRESET 7 ) # Connection reset by peer 71 | -------------------------------------------------------------------------------- /src/pico.h: -------------------------------------------------------------------------------- 1 | // 09apr22 Software Lab. Alexander Burger 2 | 3 | #include 4 | #include 5 | #include 6 | #include 7 | #include 8 | #include 9 | #include 10 | #include 11 | #include 12 | #include 13 | #include 14 | #include 15 | #include 16 | #include 17 | #include 18 | #include 19 | #include 20 | #include 21 | #include 22 | #include 23 | 24 | typedef void (*sighandler_t)(int); 25 | 26 | // Lisp data access 27 | typedef uint64_t any; 28 | 29 | #define cnt(x) ((x) & 2) 30 | #define num(x) ((x) & 6) 31 | #define sym(x) ((x) & 8) 32 | #define sign(x) ((x) & 8) 33 | #define atom(x) ((x) & 15) 34 | 35 | #define car(x) (*(uint64_t*)(x)) 36 | #define cdr(x) (*(uint64_t*)((x) + 8)) 37 | #define set(p,x) (*(uint64_t*)(p) = (x)) 38 | #define val(x) (*(uint64_t*)(x)) 39 | #define dig(x) ((x) - 4) 40 | #define big(x) ((x) + 4) 41 | #define tail(x) ((x) - 8) 42 | 43 | any name(any); 44 | any number(any); 45 | any length(any); 46 | any box64(any); 47 | 48 | extern uint64_t SymTab[]; 49 | #define Nil (0+1) 50 | // Sync src/glob.l 'T' 51 | #define T (17*2+1) 52 | #define N (18*2+1) 53 | #define C (19*2+1) 54 | #define S (20*2+1) 55 | #define B (21*2+1) 56 | #define I (22*2+1) 57 | #define P (23*2+1) 58 | #define W (24*2+1) 59 | 60 | uint64_t boxNum(uint64_t); 61 | int32_t bufSize(uint64_t); 62 | char *bufString(uint64_t, char*); 63 | uint64_t natBuf(uint64_t, char*); 64 | uint64_t natRetBuf(uint64_t, char**); 65 | 66 | void argErr(uint64_t, uint64_t) __attribute__ ((noreturn)); 67 | void err(uint64_t, uint64_t, char*, char*) __attribute__ ((noreturn)); 68 | -------------------------------------------------------------------------------- /src/sysdefs.c: -------------------------------------------------------------------------------- 1 | // 24apr22 Software Lab. Alexander Burger 2 | 3 | #include 4 | #include 5 | #include 6 | #include 7 | #include 8 | #include 9 | #include 10 | #include 11 | #include 12 | #include 13 | #include 14 | #include 15 | #include 16 | #include 17 | #include 18 | #include 19 | #include 20 | #include 21 | #include 22 | #include 23 | #include 24 | #include 25 | #include 26 | 27 | static void ttl(char *nm) { 28 | printf("\n[%s]\n", nm); 29 | } 30 | 31 | static void num(char *sym, long val) { 32 | printf("%s\t%ld\n", sym, val); 33 | } 34 | 35 | static void str(char *sym, char *val) { 36 | printf("%s\t\"%s\"\n", sym, val); 37 | } 38 | 39 | int main(void) { 40 | struct winsize term; 41 | struct sockaddr_in6 addr; 42 | struct addrinfo ai; 43 | 44 | printf("# %s\n", __VERSION__); 45 | printf("# %s\n", _OS); 46 | printf("# %s\n", _CPU); 47 | 48 | ttl("errno"); 49 | num("EINTR", EINTR); 50 | num("EAGAIN", EAGAIN); 51 | num("EACCES", EACCES); 52 | 53 | ttl("stdio"); 54 | num("BUFSIZ", BUFSIZ); 55 | 56 | ttl("unistd"); 57 | num("PIPE_BUF", PIPE_BUF); 58 | num("PATH_MAX", PATH_MAX); 59 | 60 | ttl("terminal"); 61 | num("TIOCGWINSZ", TIOCGWINSZ); 62 | num("TIOCSWINSZ", TIOCSWINSZ); 63 | num("winsize", sizeof(struct winsize)); 64 | num("ws_row", (char*)&term.ws_row - (char*)&term); 65 | num("ws_col", (char*)&term.ws_col - (char*)&term); 66 | 67 | ttl("networking"); 68 | num("SOCK_STREAM", SOCK_STREAM); 69 | num("SOCK_DGRAM", SOCK_DGRAM); 70 | num("AF_INET6", AF_INET6); 71 | num("SOL_SOCKET", SOL_SOCKET); 72 | num("SO_REUSEADDR", SO_REUSEADDR); 73 | num("IPPROTO_IPV6", IPPROTO_IPV6); 74 | num("IPV6_V6ONLY", IPV6_V6ONLY); 75 | num("INET6_ADDRSTRLEN", INET6_ADDRSTRLEN); 76 | num("sockaddr_in6", sizeof(struct sockaddr_in6)); 77 | num("sin6_family", (char*)&addr.sin6_family - (char*)&addr); 78 | num("sin6_addr", (char*)&addr.sin6_addr - (char*)&addr); 79 | num("sin6_port", (char*)&addr.sin6_port - (char*)&addr); 80 | num("NI_MAXHOST", NI_MAXHOST); 81 | num("NI_NAMEREQD", NI_NAMEREQD); 82 | num("addrinfo", sizeof(struct addrinfo)); 83 | num("ai_family", (char*)&ai.ai_family - (char*)&ai); 84 | num("ai_socktype", (char*)&ai.ai_socktype - (char*)&ai); 85 | num("socklen_t", sizeof(socklen_t)); 86 | num("ai_addrlen", (char*)&ai.ai_addrlen - (char*)&ai); 87 | num("ai_addr", (char*)&ai.ai_addr - (char*)&ai); 88 | num("ai_next", (char*)&ai.ai_next - (char*)&ai); 89 | num("AF_UNSPEC", AF_UNSPEC); 90 | 91 | return 0; 92 | } 93 | -------------------------------------------------------------------------------- /src/vers.l: -------------------------------------------------------------------------------- 1 | # 30may25 Software Lab. Alexander Burger 2 | 3 | (symbols '(llvm)) 4 | 5 | (local) *Version 6 | 7 | (pico~de *Version 25 5 30) 8 | -------------------------------------------------------------------------------- /test/lib.l: -------------------------------------------------------------------------------- 1 | # 23may25 Software Lab. Alexander Burger 2 | 3 | ### task ### 4 | (test (3 . 4) 5 | (let (*Run NIL *A NIL *B NIL) 6 | (task -10 0 (setq *A 3)) 7 | (task (port T 0 "TaskPort") (eval (udp @))) 8 | (udp "localhost" "TaskPort" '(setq *B 4)) 9 | (wait NIL (and *A *B)) 10 | (cons *A *B) ) ) 11 | 12 | 13 | ### timeout ### 14 | (test '((-1 3600000 (bye))) 15 | (let *Run NIL 16 | (timeout 3600000) 17 | *Run ) ) 18 | 19 | 20 | ### abort ### 21 | (test 6 (abort 2 (+ 1 2 3))) 22 | (test NIL (abort 2 (wait 4000))) 23 | 24 | 25 | ### macro ### 26 | (test 6 27 | (let (@A 1 @B 2 @C 3) 28 | (macro (* @A @B @C)) ) ) 29 | 30 | 31 | ### later ### 32 | (test '((@ . 1) (@ . 4) (@ . 9) (@ . 16) (@ . 25) (@ . 36)) 33 | (prog1 34 | (mapcan 35 | '((N) (later (cons) (cons *Pid (* N N)))) 36 | (1 2 3 4 5 6) ) 37 | (wait NIL (full @)) ) ) 38 | 39 | 40 | ### recur recurse ### 41 | (test 720 42 | (let N 6 43 | (recur (N) 44 | (if (=0 N) 45 | 1 46 | (* N (recurse (dec N))) ) ) ) ) 47 | 48 | 49 | ### curry ### 50 | (test '((N) (* 7 N)) 51 | ((quote (@X) (curry (@X) (N) (* @X N))) 7) ) 52 | (test 21 53 | (((quote (@X) (curry (@X) (N) (* @X N))) 7) 3) ) 54 | (test '((N) (job '((A . 1)) (+ A 7 N))) 55 | (let (A 1 @X 7) (curry (A @X) (N) (+ A @X N))) ) 56 | 57 | 58 | ### cache ### 59 | (let C NIL 60 | (test 0 (cache 'C 1234 0)) 61 | (test 7 (cache 'C 4321 7)) 62 | (test 7 (cache 'C 4321 8)) 63 | (inc (cache 'C 4321)) 64 | (test 8 (val (cache 'C 4321))) ) 65 | 66 | 67 | ### expr subr undef ### 68 | (let foo car 69 | (test 7 (foo (7))) 70 | (test T (== 'pass (caadr (expr 'foo)))) 71 | (test car (subr 'foo)) 72 | (test car (undef 'foo)) 73 | (test NIL (val 'foo)) ) 74 | 75 | 76 | ### redef ### 77 | (let foo inc 78 | (redef foo (N) (inc (foo N))) 79 | (test 3 (foo 1)) ) 80 | 81 | 82 | ### daemon patch ### 83 | (let foo car 84 | (daemon 'foo (msg 'daemon)) 85 | (test T (= '(msg 'daemon) (cadr (getd 'foo)))) 86 | (patch foo 'daemon 'patch) 87 | (test T (= '(msg 'patch) (cadr (getd 'foo)))) ) 88 | 89 | 90 | ### scl ### 91 | (scl 0) 92 | (test 123 (any "123.45")) 93 | (scl 1) 94 | (test (1235) (scl 1 (str "123.45"))) 95 | (test 1235 (any "123.45")) 96 | (scl 3) 97 | (test 123450 (any "123.45")) 98 | 99 | 100 | ### ** ### 101 | (test 32768 (** 2 15)) 102 | (test 1 (** 123 0)) 103 | (test 0 (** 3 -1)) 104 | 105 | 106 | ### accu ### 107 | (off Sum) 108 | 109 | (test '((a . 1)) (accu 'Sum 'a 1) Sum) 110 | (test '((a . 6)) (accu 'Sum 'a 5) Sum) 111 | (test '((22 . 100) (a . 6)) (accu 'Sum 22 100) Sum) 112 | 113 | (test '((b . 2) (a . 3)) 114 | (let L NIL (accu 'L 'a 2) (accu 'L 'b 2) (accu 'L 'a 1) L) ) 115 | 116 | 117 | ### script ### 118 | (out (tmp "script") 119 | (println '(pass * 7)) ) 120 | (test 42 (script (tmp "script") 2 3)) 121 | 122 | 123 | ### once ### 124 | (let N 0 125 | (test 1 126 | (once (inc 'N)) 127 | (once (inc 'N)) 128 | N ) ) 129 | 130 | 131 | ### rc ### 132 | (let F (tmp "rc") 133 | (rc F 'a 123) 134 | (rc F 'b "test" 'c (1 2 3)) 135 | (test '((c 1 2 3) (b . "test") (a . 123)) 136 | (in F (read)) ) 137 | (test 123 (rc F 'a)) 138 | (test "test" (rc F 'b)) 139 | (test (1 2 3) (rc F 'c)) ) 140 | 141 | 142 | ### acquire release ### 143 | (let F (tmp "sema") 144 | (test *Pid (acquire F)) 145 | (test T (acquire F)) 146 | (test *Pid (in F (rd))) 147 | (test NIL (release F)) 148 | (test NIL (in F (rd))) ) 149 | 150 | 151 | ### uniq ### 152 | (test (2 4 6 1 3 5) (uniq (2 4 6 1 2 3 4 5 6 1 3 5))) 153 | 154 | 155 | ### qsym ### 156 | (let "A" 1234 157 | (put '"A" 'a 1) 158 | (put '"A" 'b 2) 159 | (put '"A" 'f T) 160 | (test (1234 f (2 . b) (1 . a)) 161 | (qsym . "A") ) ) 162 | 163 | ### loc ### 164 | (let (X 'foo bar '((A B) (foo B A))) 165 | (test "foo" (zap 'foo)) 166 | (test "foo" (str? "foo")) 167 | (test T (== X (loc "foo" bar))) ) 168 | 169 | 170 | ### class ### 171 | (off "+A" "+B" "+C") 172 | (test '"+A" (class "+A" "+B" "+C")) 173 | (test '"+A" *Class) 174 | (test '("+B" "+C") "+A") 175 | 176 | 177 | ### object ### 178 | (off "Obj") 179 | (test '"Obj" 180 | (object '"Obj" '("+A" "+B" "+C") 'a 1 'b 2 'c 3) ) 181 | (test '((3 . c) (2 . b) (1 . a) (@X . *Dbg)) 182 | (getl '"Obj") ) 183 | 184 | 185 | ### extend var var: ### 186 | (test '"+B" (extend "+B")) 187 | (test T (== *Class '"+B")) 188 | 189 | (test 1 (var a . 1)) 190 | (test 2 (var (b . "+B") . 2)) 191 | (test '((2 . b) (1 . a)) (cdr (getl '"+B"))) 192 | 193 | (with '"Obj" 194 | (test 1 (var: a)) 195 | (test 2 (var: b)) ) 196 | -------------------------------------------------------------------------------- /test/lib/db.l: -------------------------------------------------------------------------------- 1 | # 21aug22 Software Lab. Alexander Burger 2 | 3 | ### +Joint ### 4 | (test T (pool (tmp "db"))) 5 | 6 | (class +A +Entity) 7 | (rel k (+Key +String)) 8 | (rel b (+List +Bag) 9 | ((+Joint) a (+B)) 10 | ((+Number)) ) 11 | 12 | (class +B +Entity) 13 | (rel k (+Key +String)) 14 | (rel a (+Joint) b (+A) list asoq) 15 | 16 | (let 17 | (A (new T '(+A) 'k "a") 18 | B (new T '(+B) 'k "b") 19 | C (new T '(+B) 'k "c") ) 20 | 21 | (test T (bool (has> A 'k "a"))) 22 | (test T (bool (has> B 'k "b"))) 23 | (test A (db 'k '+A "a")) 24 | (test B (db 'k '+B "b")) 25 | (test C (db 'k '+B "c")) 26 | 27 | (put> B 'a A) 28 | (test (list (list B)) (; A b)) 29 | (test A (; B a)) 30 | 31 | (test T (bool (has> A 'b B))) 32 | (test T (bool (has> A 'b (list B)))) 33 | (test T (bool (has> A 'b (list (list B))))) 34 | 35 | (test T (bool (has> B 'a A))) 36 | 37 | (put> B 'a NIL) 38 | (test NIL (; A b)) 39 | (test NIL (; B a)) 40 | 41 | (put> A 'b (list (list B 123))) 42 | (test (list (list B 123)) (; A b)) 43 | (test A (; B a)) 44 | 45 | (put> A 'b (list (list C 7))) 46 | (test (list (list C 7)) (; A b)) 47 | (test NIL (; B a)) 48 | (test A (; C a)) 49 | 50 | (put> A 'b NIL) 51 | (test NIL (; A b)) 52 | (test NIL (; B a)) ) 53 | 54 | (rollback) 55 | 56 | ### +Swap ### 57 | (class +C +Entity) 58 | (rel s (+Swap +String)) 59 | (rel l (+Swap +List +String)) 60 | (rel b (+List +Bag) 61 | ((+Number)) 62 | ((+Swap +String)) ) 63 | (rel c (+Swap +List +Bag) 64 | ((+Number)) 65 | ((+String)) ) 66 | 67 | (let A 68 | (new T '(+C) 69 | 's "a" 70 | 'l '("b" "c") 71 | 'b '((123 "def")) 72 | 'c '((123 "def")) ) 73 | 74 | (test T (bool (has> A 's "a"))) 75 | (test NIL (has> A 's "x")) 76 | (test T (bool (has> A 'l '("b" "c")))) 77 | (test NIL (has> A 'l '("b"))) 78 | (test NIL (has> A 'l '("c"))) 79 | (test NIL (has> A 'l '("x"))) 80 | (test T (bool (has> A 'b '((123 "def"))))) 81 | (test NIL (has> A 'b '((123)))) 82 | (test NIL (has> A 'b '(("def")))) 83 | (test T (bool (has> A 'c '((123 "def"))))) 84 | (test NIL (has> A 'c '((123)))) 85 | (test NIL (has> A 'c '(("def")))) 86 | 87 | (let S (; A l) 88 | (put> A 'l '("x")) 89 | (test S (; A l)) 90 | (test '("x") (; A l 0)) ) 91 | 92 | (let S (; A b 1 2) 93 | (put> A 'b (list (list 4 S))) 94 | (test S (; A b 1 2)) 95 | (test "def" (; A b 1 2 0)) 96 | (test 4 (; A b 1 1)) 97 | (put> A 'b '((7 "y"))) 98 | (test S (; A b 1 2)) 99 | (test 7 (; A b 1 1)) 100 | (test "y" (; A b 1 2 0)) ) ) 101 | 102 | (rollback) 103 | -------------------------------------------------------------------------------- /test/lib/lint.l: -------------------------------------------------------------------------------- 1 | # 06oct20 Software Lab. Alexander Burger 2 | 3 | ### noLint ### 4 | (let foo '(() (bar FreeVariable)) 5 | (use *NoLint 6 | (noLint 'bar) 7 | (noLint 'foo 'FreeVariable) 8 | (test NIL (lint 'foo)) ) ) 9 | 10 | 11 | ### lint ### 12 | (let foo '((R S T R) (let N 7 (bar X Y))) 13 | (test '((var T) (dup R) (def bar) (bnd Y X) (use N)) 14 | (lint 'foo) ) ) 15 | 16 | (let foo '(() (task -6000 0 X 7 (println N))) 17 | (test '((bnd N) (use X)) 18 | (lint 'foo) ) ) 19 | -------------------------------------------------------------------------------- /test/lib/math.l: -------------------------------------------------------------------------------- 1 | # 06oct20 Software Lab. Alexander Burger 2 | 3 | (scl 6) 4 | (load "@lib/math.l") 5 | 6 | ### pow ### 7 | (test 8.0 (pow 2.0 3.0)) 8 | (test 8.0 (pow 64.0 0.5)) 9 | 10 | ### exp ### 11 | (test 2.718282 (exp 1.0)) 12 | 13 | ### log ### 14 | (test 0.693147 (log 2.0)) 15 | 16 | ### sin ### 17 | (test 0.0 (sin 0.0)) 18 | (test 1.0 (sin (/ pi 2))) 19 | 20 | ### cos ### 21 | (test 1.0 (cos 0.0)) 22 | (test -1.0 (cos pi)) 23 | 24 | ### tan ### 25 | (test 0.0 (tan 0.0)) 26 | (test 0.0 (tan pi)) 27 | 28 | ### asin ### 29 | (test 0.0 (asin 0.0)) 30 | (test (/ pi 2) (asin 1.0)) 31 | 32 | ### acos ### 33 | (test 0.0 (acos 1.0)) 34 | (test pi (acos -1.0)) 35 | 36 | ### atan ### 37 | (test 0.0 (atan 0.0)) 38 | 39 | ### atan2 ### 40 | (test 0.0 (atan2 0.0 1.0)) 41 | (test (/ pi 2) (atan2 1.0 0.0)) 42 | -------------------------------------------------------------------------------- /test/lib/misc.l: -------------------------------------------------------------------------------- 1 | # 26may22 Software Lab. Alexander Burger 2 | 3 | ### locale ### 4 | (locale "DE" "de") 5 | (test "Ja" (val ,"Yes")) 6 | (locale) 7 | 8 | 9 | ### align ### 10 | (test " a" (align 4 'a)) 11 | (test " a" (align 4 "a")) 12 | (test "12 " (align -4 12)) 13 | (test " a 12 b" (align (4 4 4) "a" 12 "b")) 14 | 15 | 16 | ### center ### 17 | (test " 12" (center 4 12)) 18 | (test " a" (center 4 "a")) 19 | (test " a" (center 7 'a)) 20 | (test " a b c" (center (3 3 3) "a" "b" "c")) 21 | 22 | 23 | ### wrap ### 24 | (test "The quick brown fox\njumps over the lazy\ndog" 25 | (wrap 20 (chop "The quick brown fox jumps over the lazy dog")) ) 26 | (test "The\nquick\nbrown\nfox\njumps\nover the\nlazy dog" 27 | (wrap 8 (chop "The quick brown fox jumps over the lazy dog")) ) 28 | (test "The\nquick\nbrown\nfox\njumps\nover\nthe\nlazy\ndog" 29 | (wrap 2 (chop "The quick brown fox jumps over the lazy dog")) ) 30 | (test '("The" "quick" "brown" "fox" "jumps" "over the" "lazy dog") 31 | (wrap 8 "The quick brown fox jumps over the lazy dog") ) 32 | 33 | 34 | ### pad ### 35 | (test "00001" (pad 5 1)) 36 | (test "123456789" (pad 5 123456789)) 37 | 38 | 39 | ### bin ### 40 | (test "1001001" (bin (+ 64 8 1))) 41 | (test (+ 64 8 1) (bin "1001001")) 42 | (test "-110110" (bin -54)) 43 | (test -54 (bin "-110110")) 44 | 45 | 46 | ### oct ### 47 | (test "111" (oct (+ 64 8 1))) 48 | (test (+ 64 8 1) (oct "111")) 49 | (test "-66" (oct -54)) 50 | (test -54 (oct "-66")) 51 | 52 | 53 | ### hex ### 54 | (test "111" (hex (+ 256 16 1))) 55 | (test (+ 256 16 1) (hex "111")) 56 | (test "-FFFF" (hex -65535)) 57 | 58 | 59 | ### money ### 60 | (test "1,234,567.89" (money 123456789)) 61 | (test "1,234,567.89 EUR" (money 123456789 "EUR")) 62 | 63 | (locale "DE" "de") 64 | (test "1.234.567,89 EUR" (money 123456789 "EUR")) 65 | (locale) 66 | 67 | 68 | ### round ### 69 | (scl 4) 70 | (test "12.35" (round 123456 2)) 71 | (test "12.3456" (round 123456 6)) 72 | (test "12.346" (round 123456)) 73 | 74 | 75 | ### balance ### 76 | (test (5 (2 (1) 3 NIL 4) 7 (6) 8 NIL 9) 77 | (let I NIL (balance 'I (sort (1 4 2 5 3 6 7 9 8))) I) ) 78 | 79 | 80 | ### *Allow allowed allow ### 81 | (allowed ("app/") 82 | "start" "stop" "lib.css" "psh" ) 83 | (allow "myFoo") 84 | (allow "myDir/" T) 85 | 86 | (test '(("psh" ("lib.css" NIL "myFoo") "start" NIL "stop") "app/" "myDir/") 87 | *Allow ) 88 | 89 | (test '("lib.css" "myFoo" "psh" "start" "stop") 90 | (idx *Allow) ) 91 | 92 | (test '("app/" "myDir/") 93 | (cdr *Allow) ) 94 | 95 | 96 | ### telStr ### 97 | (test "+49 1234 5678-0" (telStr "49 1234 5678-0")) 98 | 99 | (locale "DE" "de") 100 | (test "01234 5678-0" (telStr "49 1234 5678-0")) 101 | (locale) 102 | 103 | 104 | ### expTel ### 105 | (test "49 1234 5678-0" (expTel "+49 1234 5678-0")) 106 | (test "49 1234 5678-0" (expTel "0049 1234 5678-0")) 107 | (test NIL (expTel "01234 5678-0")) 108 | 109 | (locale "DE" "de") 110 | (test "49 1234 5678-0" (expTel "01234 5678-0")) 111 | (locale) 112 | 113 | 114 | ### dat$ ### 115 | (test "20070601" (dat$ (date 2007 6 1))) 116 | (test "2007-06-01" (dat$ (date 2007 6 1) "-")) 117 | 118 | 119 | ### $dat ### 120 | (test 733134 ($dat "20070601")) 121 | (test 733134 ($dat "2007-06-01" "-")) 122 | 123 | 124 | ### datSym ### 125 | (test "01jun07" (datSym (date 2007 6 1))) 126 | 127 | 128 | ### datStr ### 129 | (test "2007-06-01" (datStr (date 2007 6 1))) 130 | 131 | (locale "DE" "de") 132 | (test "01.06.2007" (datStr (date 2007 6 1))) 133 | (test "01.06.07" (datStr (date 2007 6 1) T)) 134 | (locale) 135 | 136 | 137 | ### strDat ### 138 | (test 733134 (strDat "2007-06-01")) 139 | (test NIL (strDat "01.06.2007")) 140 | 141 | (locale "DE" "de") 142 | (test 733134 (strDat "01.06.2007")) 143 | (test 733134 (strDat "1.6.2007")) 144 | (locale) 145 | 146 | 147 | ### expDat ### 148 | (test 733133 (date 2007 5 31)) 149 | (test 733133 (expDat "31057")) 150 | (test 733133 (expDat "310507")) 151 | (test 733133 (expDat "2007-05-31")) 152 | (test 733133 (expDat "7-5-31")) 153 | 154 | (let D (date) 155 | (test D (expDat ".")) 156 | (test (inc D) (expDat "+1")) 157 | (test (dec D) (expDat "-1")) ) 158 | 159 | (locale "DE" "de") 160 | (test 733133 (expDat "31.5.7")) 161 | (locale) 162 | 163 | 164 | ### day ### 165 | (test "Friday" (day (date 2007 6 1))) 166 | 167 | (locale "DE" "de") 168 | (test "Freitag" (day (date 2007 6 1))) 169 | (test "Fr" 170 | (day (date 2007 6 1) '("Mo" "Tu" "We" "Th" "Fr" "Sa" "Su")) ) 171 | (locale) 172 | 173 | 174 | ### week ### 175 | (test 22 (week (date 2007 6 1))) 176 | 177 | 178 | ### ultimo ### 179 | (test (2007 1 31) (date (ultimo 2007 1))) 180 | (test (2007 2 28) (date (ultimo 2007 2))) 181 | (test (2004 2 29) (date (ultimo 2004 2))) 182 | (test (2000 2 29) (date (ultimo 2000 2))) 183 | (test (1900 2 28) (date (ultimo 1900 2))) 184 | 185 | 186 | ### tim$ ### 187 | (test "10:57" (tim$ (time 10 57 56))) 188 | (test "10:57:56" (tim$ (time 10 57 56) T)) 189 | 190 | 191 | ### $tim ### 192 | (test (10 57 56) (time ($tim "10:57:56"))) 193 | (test (10 57 0) (time ($tim "10:57"))) 194 | (test (10 0 0) (time ($tim "10"))) 195 | 196 | 197 | ### stamp ### 198 | (test "2007-06-01 10:57:56" 199 | (stamp (date 2007 6 1) (time 10 57 56)) ) 200 | 201 | 202 | ### chdir ### 203 | (let P (pwd) 204 | (chdir "/" 205 | (test "/" (pwd)) ) 206 | (test P *PWD) ) 207 | 208 | 209 | ### dirname basename ### 210 | (test "a/b/c/" (dirname "a/b/c/d")) 211 | (test "a/b/c/" (dirname "a/b/c/d/")) 212 | (test "d" (basename "a/b/c/d")) 213 | (test "d" (basename "a/b/c/d/")) 214 | -------------------------------------------------------------------------------- /test/src/apply.l: -------------------------------------------------------------------------------- 1 | # 01may22 Software Lab. Alexander Burger 2 | 3 | ### apply ### 4 | (test 6 (apply + (1 2 3))) 5 | (test 360 (apply * (5 6) 3 4)) 6 | (test 27 (apply '((X Y Z) (* X (+ Y Z))) (3 4 5))) 7 | (test (5 7 9) (apply mapcar '((1 2 3) (4 5 6)) +)) 8 | 9 | 10 | ### pass ### 11 | (test 24 ((quote (N . @) (* N (pass + 6))) 2 1 2 3)) 12 | 13 | 14 | ### fun ### 15 | (test '(NIL NIL NIL) 16 | (mapcar fun 17 | '(gt0 ((N) (bit? 1 N)) ((N) (> N 4))) 18 | -2 ) ) 19 | (test (2 NIL NIL) 20 | (mapcar fun 21 | '(gt0 ((N) (bit? 1 N)) ((N) (> N 4))) 22 | 2 ) ) 23 | (test (3 1 NIL) 24 | (mapcar fun 25 | '(gt0 ((N) (bit? 1 N)) ((N) (> N 4))) 26 | 3 ) ) 27 | (test (7 1 T) 28 | (mapcar fun 29 | '(gt0 ((N) (bit? 1 N)) ((N) (> N 4))) 30 | 7 ) ) 31 | 32 | 33 | ### maps ### 34 | (let L '((1 . a) (2 . b) flg) 35 | (test L (let X (box) (putl X (reverse L)) (make (maps link X)))) ) 36 | 37 | 38 | ### map ### 39 | (test '((1 2 3) (2 3) (3)) (make (map link (1 2 3)))) 40 | 41 | 42 | ### mapc ### 43 | (test (1 2 3) (make (mapc link (1 2 3)))) 44 | 45 | 46 | ### maplist ### 47 | (test '(((1 2 3) A B C) ((2 3) B C) ((3) C)) (maplist cons (1 2 3) '(A B C))) 48 | 49 | 50 | ### mapcar ### 51 | (test (5 7 9) (mapcar + (1 2 3) (4 5 6))) 52 | (test (26 38 52 68) (mapcar '((X Y) (+ X (* Y Y))) (1 2 3 4) (5 6 7 8))) 53 | 54 | 55 | ### mapcon ### 56 | (test (1 2 3 4 5 2 3 4 5 3 4 5 4 5 5) (mapcon copy (1 2 3 4 5))) 57 | 58 | 59 | ### mapcan ### 60 | (test '(c b a f e d i h g) (mapcan reverse '((a b c) (d e f) (g h i)))) 61 | 62 | 63 | ### filter ### 64 | (test (1 2 3) (filter num? (1 A 2 (B) 3 CDE))) 65 | 66 | 67 | ### extract ### 68 | (let (A NIL B 1 C NIL D 2 E NIL F 3) 69 | (test (1 2 3) 70 | (extract val '(A B C D E F)) ) 71 | (test (1 2 3) 72 | (extract val '(B D E F)) ) ) 73 | 74 | 75 | ### seek ### 76 | (test (12 19 22) (seek '((X) (> (car X) 9)) (1 5 8 12 19 22))) 77 | (let (A -1 B 2 C 3) 78 | (test '(B C) (seek '((L) (gt0 (val (car L)))) '(A B C))) 79 | (test 2 @@) ) 80 | 81 | 82 | ### find ### 83 | (test '(B) (find pair (1 A 2 (B) 3 CDE))) 84 | (test 4 (find > (1 2 3 4 5 6) (6 5 4 3 2 1))) 85 | (test 4 (find '((A B) (> A B)) (1 2 3 4 5 6) (6 5 4 3 2 1))) 86 | (let (A -1 B 2 C 3) 87 | (test 'B (find '((X) (gt0 (val X))) '(A B C))) 88 | (test 2 @@) ) 89 | 90 | 91 | ### pick ### 92 | (test "Hello" 93 | (pick '((X) (get X 'str)) 94 | (list (box) (prog1 (box) (put @ 'str "Hello")) (box)) ) ) 95 | 96 | 97 | ### fully ### 98 | (test T (fully gt0 (1 2 3))) 99 | (test NIL (fully gt0 (1 -2 3))) 100 | 101 | ### cnt ### 102 | (test 2 (cnt cdr '((1 . T) (2) (3 4) (5)))) 103 | 104 | 105 | ### sum ### 106 | (test 6 (sum val (list (box 1) (box) (box 2) (box 'a) (box 3)))) 107 | 108 | 109 | ### maxi mini ### 110 | (let (A 1 B 2 C 3) 111 | (test 'C (maxi val '(A B C))) 112 | (test 3 @@) 113 | (test 'A (mini val '(A B C))) 114 | (test 1 @@) 115 | (test '(A B C) (by val sort '(C A B))) ) 116 | 117 | 118 | ### fish ### 119 | (test (1 2 3) 120 | (fish gt0 '(a -2 (1 b (-3 c 2)) 3 d -1)) ) 121 | (test (-2 1 -3 -1) 122 | (fish < '(a -2 (1 b (-3 c 2)) 3 d -1) NIL 2) ) 123 | (test '(a b c d) 124 | (fish sym? '(a -2 (1 b (-3 c 2)) 3 d -1)) ) 125 | (test (3 7) 126 | (fish 127 | '((X) 128 | (if (and (pair X) (=1 (car X))) 129 | "skip" 130 | (gt0 X) ) ) 131 | '(a -2 (1 b (-3 c 2)) 3 d -1 7) 132 | "skip" ) ) 133 | (test '(b b) 134 | (fish == '(a 1 (b (3 b)) 3) NIL 'b) ) 135 | 136 | 137 | ### by ### 138 | (test '(A B C) 139 | (let (A 1 B 2 C 3) 140 | (by val sort '(C A B)) ) ) 141 | (test '((3 11 9 5 7 1) (6 2 4 10 12 8)) 142 | (by '((N) (bit? 1 N)) 143 | group 144 | (3 11 6 2 9 5 4 10 12 7 8 1) ) ) 145 | (test '(("x" "x" "x") ("y") ("z" "z")) 146 | (by name group '("x" "x" "y" "z" "x" "z")) ) 147 | (test '((123 "xyz") ((1 2) "XY") ("abcd" (1 2 3 4))) 148 | (by length group '(123 (1 2) "abcd" "xyz" (1 2 3 4) "XY")) ) 149 | -------------------------------------------------------------------------------- /test/src/big.l: -------------------------------------------------------------------------------- 1 | # 11may25 Software Lab. Alexander Burger 2 | 3 | ### format ### 4 | (scl 0) 5 | (test "123456789" (format 123456789)) 6 | (test "12346" (format 12345.6789)) 7 | (test "1234567.89" (format 123456789 2)) 8 | (test "1234567,89" (format 123456789 2 ",")) 9 | (test "1.234.567,89" (format 123456789 2 "," ".")) 10 | (test 123456789 (format "123456789")) 11 | (test 12345678900 (format "1234567.89" 4)) 12 | (test NIL (format "1.234.567,89")) 13 | (test 12345678900 (format "1234567,89" 4 ",")) 14 | (test NIL (format "1.234.567,89" 4 ",")) 15 | (test 12345678900 (format "1.234.567,89" 4 "," ".")) 16 | (test 123456 (format (1 "23" (4 5 6)))) 17 | 18 | 19 | ### + ### 20 | (test 6 (+ 1 2 3)) 21 | (test 0 (+ 1 2 -3)) 22 | (test NIL (+ NIL 7)) 23 | 24 | 25 | ### - ### 26 | (test -7 (- 7)) 27 | (test 7 (- -7)) 28 | (test 6 (- 7 2 -1)) 29 | (test NIL (- NIL 7)) 30 | 31 | 32 | ### inc ### 33 | (test 8 (inc 7)) 34 | (test -6 (inc -7)) 35 | (test 0 (inc -1)) 36 | (test 1 (inc 0)) 37 | (test (8 -6 0 1) (let L (7 -7 -1 0) (map inc L) L)) 38 | (test NIL (inc NIL)) 39 | (let N 0 40 | (test 1 (inc 'N)) 41 | (test 1 N) 42 | (test 8 (inc 'N 7)) 43 | (test 8 N) ) 44 | (let L (1 2 3 4) 45 | (test 3 (inc (cdr L))) 46 | (test (1 3 3 4) L) ) 47 | 48 | 49 | ### dec ### 50 | (test 7 (dec 8)) 51 | (test -8 (dec -7)) 52 | (test -1 (dec 0)) 53 | (test (7 -8 -1) (let L (8 -7 0) (map dec L) L)) 54 | (test NIL (dec NIL)) 55 | (let N 7 56 | (test 6 (dec 'N)) 57 | (test 6 N) 58 | (test 3 (dec 'N 3)) 59 | (test 3 N) ) 60 | 61 | 62 | ### * ### 63 | (test 6 (* 1 2 3)) 64 | (test -60 (* -5 3 2 2)) 65 | (test NIL (* NIL 7)) 66 | 67 | 68 | ### */ ### 69 | (test 6 (*/ 3 4 2)) 70 | (test -247 (*/ 1234 -2 10)) 71 | (test 17 (*/ 100 6)) 72 | (test NIL (*/ 3 4 NIL)) 73 | 74 | 75 | ### / ### 76 | (test 4 (/ 12 3)) 77 | (test -5 (/ 60 -3 2 2)) 78 | (test NIL (/ 10 NIL)) 79 | 80 | 81 | ### % ### 82 | (test 2 (% 17 5)) 83 | (test -2 (% -17 5)) 84 | (test 1 (% 5 2)) 85 | (test 5 (% 15 10)) 86 | (test 1 (% 15 10 2)) 87 | (test NIL (% NIL 7)) 88 | 89 | 90 | ### >> ### 91 | (test 4 (>> 1 8)) 92 | (test 2 (>> 3 16)) 93 | (test 128 (>> -3 16)) 94 | (test -32 (>> -1 -16)) 95 | (test 0 (>> 1 -1)) 96 | 97 | 98 | ### lt0 ### 99 | (test -2 (lt0 -2)) 100 | (test NIL (lt0 7)) 101 | (test NIL (lt0 0)) 102 | 103 | 104 | ### le0 ### 105 | (test -7 (le0 -7)) 106 | (test NIL (le0 2)) 107 | (test 0 (le0 0)) 108 | 109 | 110 | ### ge0 ### 111 | (test 7 (ge0 7)) 112 | (test NIL (ge0 -2)) 113 | (test 0 (ge0 0)) 114 | 115 | 116 | ### gt0 ### 117 | (test 7 (gt0 7)) 118 | (test NIL (gt0 -2)) 119 | (test NIL (gt0 0)) 120 | 121 | 122 | ### abs ### 123 | (test 7 (abs -7)) 124 | (test 7 (abs 7)) 125 | (test NIL (abs NIL)) 126 | 127 | 128 | ### bit? ### 129 | (test 7 (bit? 7 15 255)) 130 | (test NIL (bit? 1 2)) 131 | (test 1 (bit? 1 3)) 132 | (test 1 (bit? 1 -3)) 133 | (test 1 (bit? -1 3)) 134 | (test 1 (bit? -1 -3)) 135 | (test (hex "100000000000000000000") 136 | (bit? (hex "100000000000000000000") (hex "300000000000000000000")) ) 137 | 138 | 139 | ### & ### 140 | (test 2 (& 6 3)) 141 | (test 1 (& 7 3 1)) 142 | (test NIL (& 7 NIL)) 143 | (test 1 (& 1 3)) 144 | (test 1 (& 1 -3)) 145 | (test 1 (& -1 3)) 146 | (test 1 (& -1 -3)) 147 | (test (hex "100000000000000000000") 148 | (& (hex "100000000000000000000") (hex "300000000000000000000")) ) 149 | 150 | 151 | ### | ### 152 | (test 15 (| 1 2 4 8)) 153 | (test NIL (| NIL 1)) 154 | (test 3 (| 1 2)) 155 | (test 3 (| 1 -2)) 156 | (test 3 (| -1 2)) 157 | (test 3 (| -1 -2)) 158 | (test (hex "300000000000000000000") 159 | (| (hex "100000000000000000000") (hex "200000000000000000000")) ) 160 | 161 | 162 | ### x| ### 163 | (test 5 (x| 2 7)) 164 | (test 4 (x| 2 7 1)) 165 | (test NIL (x| NIL 1)) 166 | (test 3 (x| 1 2)) 167 | (test 3 (x| 1 -2)) 168 | (test 3 (x| -1 2)) 169 | (test 3 (x| -1 -2)) 170 | (test (hex "300000000000000000000") 171 | (x| (hex "100000000000000000000") (hex "200000000000000000000")) ) 172 | 173 | 174 | ### sqrt ### 175 | (test 8 (sqrt 64)) 176 | (test 4 (sqrt 21)) 177 | (test 5 (sqrt 21 T)) 178 | (test 31 (sqrt 1000)) 179 | (test 32 (sqrt 1000 T)) 180 | (test 458 (sqrt 2100 100)) 181 | (test 479 (sqrt 230000)) 182 | (test 480 (sqrt 2300 100)) 183 | (test 800 (sqrt 6400 100)) 184 | (test 100000000000000000000 185 | (sqrt 10000000000000000000000000000000000000000) ) 186 | (test NIL (sqrt NIL)) 187 | 188 | 189 | ### seed rand hash ### 190 | (test -417605464 (seed "init string")) 191 | (test -1061886707 (rand)) 192 | (test 822065436 (rand)) 193 | (test 5 (rand 3 9)) 194 | (test 3 (rand 3 9)) 195 | (test 1 (hash 0)) 196 | (test 723519 (hash 1)) 197 | (test 870326 (hash 7)) 198 | (test 528545 (hash 1234567)) 199 | (test 987436 (hash (1 "abc" X))) 200 | -------------------------------------------------------------------------------- /test/src/db.l: -------------------------------------------------------------------------------- 1 | # 21aug22 Software Lab. Alexander Burger 2 | 3 | (test T (pool (tmp "db") (2 3))) 4 | 5 | ### extern ### 6 | (test NIL (extern (box))) 7 | (test *DB (extern "1")) 8 | 9 | 10 | ### ext? ### 11 | (test *DB (ext? *DB)) 12 | (test NIL (ext? 'abc)) 13 | (test NIL (ext? "abc")) 14 | (test NIL (ext? 123)) 15 | 16 | 17 | ### touch ### 18 | (test *DB (touch *DB)) 19 | (rollback) 20 | 21 | 22 | ### id ### 23 | (test *DB (id 1)) 24 | (test 1 (id *DB)) 25 | (let I (id 3 4) 26 | (test (3 . 4) (id I T)) ) 27 | 28 | 29 | ### wipe ### 30 | (set *DB (1 2 3 4)) 31 | (put *DB 'a 1) 32 | (put *DB 'b 2) 33 | (test (1 2 3 4) (val *DB)) 34 | (test '((2 . b) (1 . a)) (getl *DB)) 35 | (wipe *DB) 36 | (test (1 2 3 4) (val *DB)) 37 | (test '((2 . b) (1 . a)) (getl *DB)) 38 | (rollback) 39 | 40 | 41 | ### lieu ### 42 | (test NIL (lieu *DB)) 43 | (test *DB (val *DB) (lieu *DB)) 44 | (rollback) 45 | 46 | 47 | ### commit rollback ### 48 | (let (X (new 1) Y (new 2)) 49 | (set X 1 Y 2) 50 | (commit) 51 | (test 1 (val X)) 52 | (test 2 (val Y)) 53 | (set X 111) 54 | (set Y 222) 55 | (test 111 (val X)) 56 | (test 222 (val Y)) 57 | (rollback) 58 | (test 1 (val X)) 59 | (test 2 (val Y)) ) 60 | 61 | 62 | ### mark ### 63 | (test NIL (mark *DB)) 64 | (test NIL (mark *DB T)) 65 | (test T (mark *DB)) 66 | (test T (mark *DB 0)) 67 | (test NIL (mark *DB)) 68 | 69 | 70 | ### dbck ### 71 | (test NIL (dbck)) 72 | 73 | (rollback) 74 | -------------------------------------------------------------------------------- /test/src/ext.l: -------------------------------------------------------------------------------- 1 | # 03apr23 Software Lab. Alexander Burger 2 | 3 | ### ext:Snx ### 4 | (test "PSLSFSNTSNNLSF" 5 | (ext:Snx "PicoLisp is not Common Lisp") ) 6 | (test "PSLSFSNT" 7 | (ext:Snx "PicoLisp is not Common Lisp" 8) ) 8 | 9 | 10 | ### ext:Base64 ### 11 | (test "TQ==" 12 | (pipe (ext:Base64 77) (line T)) ) 13 | (test "AQID" 14 | (pipe (ext:Base64 1 2 3) (line T)) ) 15 | (test '("A" "Q" "I" "D" "B" "A" "U" "G" "B" "w" "=" "=") 16 | (make 17 | (let L (1 2 3 4 5 6 7) 18 | (output (link @@) 19 | (while L 20 | (ext:Base64 (++ L) (++ L) (++ L)) ) ) ) ) ) 21 | 22 | (test (77) 23 | (pipe 24 | (prinl "TQ==") 25 | (make (while (ext:Base64) (link @))) ) ) 26 | (test (1 2 3) 27 | (pipe 28 | (prinl "AQID") 29 | (make (while (ext:Base64) (link @))) ) ) 30 | (test (1 2 3 4 5 6 7) 31 | (let L '("A" "Q" "I" "D" "B" "A" "U" "G" "B" "w" "=" "=") 32 | (make 33 | (input (++ L) 34 | (while (ext:Base64) (link @)) ) ) ) ) 35 | 36 | (let F (tmp "base64") 37 | (out F 38 | (pipe 39 | (prin "Polyfon zwitschernd aßen Mäxchens Vögel Rüben, Joghurt und Quark") 40 | (while (ext:Base64 (rd 1) (rd 1) (rd 1))) ) ) 41 | 42 | (test "UG9seWZvbiB6d2l0c2NoZXJuZCBhw59lbiBNw6R4Y2hlbnMgVsO2Z2VsIFLDvGJlbiwgSm9naHVydCB1bmQgUXVhcms=" 43 | (in F (line T)) ) 44 | 45 | (test "Polyfon zwitschernd aßen Mäxchens Vögel Rüben, Joghurt und Quark" 46 | (pipe 47 | (in F (while (ext:Base64) (wr @))) 48 | (line T) ) ) ) 49 | -------------------------------------------------------------------------------- /test/src/ht.l: -------------------------------------------------------------------------------- 1 | # 06oct20 Software Lab. Alexander Burger 2 | 3 | ### ht:Prin ### 4 | (test "1<2>3&äöü<i>ÄÖÜß" 5 | (pipe (ht:Prin "1<2>3&äöüÄÖÜß") (line T)) ) 6 | 7 | 8 | ### ht:Fmt ### 9 | (test "+123&abc&$def&-123&_+1_xyz_+7" 10 | (ht:Fmt 123 "abc" 'def '{123} (1 "xyz" 7)) ) 11 | 12 | 13 | ### ht:Pack ### 14 | (test "A+B%20C" 15 | (ht:Pack '("A" "+" "B" "%" "2" "0" "C")) ) 16 | (test "A+B C" 17 | (ht:Pack '("A" "+" "B" "%" "2" "0" "C") T) ) 18 | (test "a b>c" 19 | (ht:Pack '("a" "%" "2" "0" "b" "&" "g" "t" ";" "c") T) ) 20 | (test "a€z" 21 | (ht:Pack '("a" "&" "#" "8" "3" "6" "4" ";" "z")) ) 22 | (test "äöü" 23 | (ht:Pack '("%" "C" "3" "%" "A" "4" "%" "C" "3" "%" "B" "6" "%" "C" "3" "%" "B" "C") T) ) 24 | 25 | 26 | ### ht:Read ### 27 | (test NIL 28 | (pipe (prin "abcde") (ht:Read 0)) ) 29 | (test NIL 30 | (pipe (prin "abcde") (ht:Read 6)) ) 31 | (test NIL 32 | (pipe NIL (ht:Read 3)) ) 33 | (test NIL 34 | (pipe (prin "äö") (ht:Read 3)) ) 35 | (test '("ä" "ö") 36 | (pipe (prin "äö") (ht:Read 4)) ) 37 | (test '("a" "b" "c") 38 | (pipe (prin "abcde") (ht:Read 3)) ) 39 | (test '("ä" "ö" "ü") 40 | (pipe (prin "äöüxyz") (ht:Read 6)) ) 41 | 42 | 43 | ### ht:In ht:Out ### 44 | (test "Hello world" 45 | (pipe (ht:Out T (prinl "Hello world")) (ht:In T (line T))) ) 46 | -------------------------------------------------------------------------------- /test/src/io.l: -------------------------------------------------------------------------------- 1 | # 26may22 Software Lab. Alexander Burger 2 | 3 | ### path ### 4 | (test 'task (cadr (in (path "@lib.l") (read)))) 5 | (test (char "+") (char (path "+@"))) 6 | 7 | 8 | ### read ### 9 | (test (1 2 3) (~(1 2) 3)) 10 | (test (1 3) (~(1 . 2) 3)) 11 | (test (1 2 3 4) (1 ~(2 3) 4)) 12 | (test (1 2 4) (1 ~(2 . 3) 4)) 13 | (test (1 2 3) [1 2 3]) 14 | (test (1 2 3) (1 2 3] 15 | (test (1 2 3) (1 2 3)] 16 | (test (1 (2 3)) (1 (2 3] 17 | (test (quote 1 (2 (3))) '(1 (2 (3] 18 | (test (quote 1 (2 (3))) '[1 (2 (3]) 19 | (test (1 abc (d e f)) 20 | (pipe (prinl "(1 abc (d e f))") 21 | (read) ) ) 22 | (test '(abc "=" def_ghi "(" ("x" "y" "z") "+" "-" 123 ")") 23 | (pipe (prinl "abc = def_ghi(\"xyz\"+-123) # Comment") 24 | (make 25 | (while (read "_" "#") 26 | (link @) ) ) ) ) 27 | 28 | 29 | ### wait ### 30 | (let (*Run NIL *Cnt 0) 31 | (test (1 2 3 4 5 6 7) 32 | (make 33 | (task -10 0 (link (inc '*Cnt))) 34 | (wait NIL (>= *Cnt 7)) ) ) ) 35 | 36 | 37 | ### peek char ### 38 | (pipe (prin "ab") 39 | (test "a" (peek)) 40 | (test "a" (char)) 41 | (test "b" (peek)) 42 | (test "b" (char)) 43 | (test NIL (peek)) 44 | (test NIL (char)) ) 45 | (test "A" (char 65)) 46 | (test 65 (char "A")) 47 | 48 | 49 | ### skip ### 50 | (test "a" 51 | (pipe (prinl "# Comment\na") 52 | (skip "#") ) ) 53 | (test "#" 54 | (pipe (prinl "# Comment\na") 55 | (skip) ) ) 56 | 57 | 58 | ### eof ### 59 | (test T (pipe NIL (eof))) 60 | (test NIL (pipe (prin "a") (eof))) 61 | (test T (pipe (prin "a") (eof T) (eof))) 62 | 63 | 64 | ### from till ### 65 | (test "cd" 66 | (pipe (prin "ab.cd:ef") 67 | (from ".") 68 | (till ":" T) ) ) 69 | 70 | 71 | ### line ### 72 | (test '("a" "b" "c") 73 | (pipe (prin "abc\n") (line)) ) 74 | (test "abc" 75 | (pipe (prin "abc") (line T)) ) 76 | (test '("abc" "def") 77 | (pipe (prin "abc\ndef") 78 | (list (line T) (line T)) ) ) 79 | (test '("abc" "def") 80 | (pipe (prin "abc\rdef") 81 | (list (line T) (line T)) ) ) 82 | (test '("abc" "def") 83 | (pipe (prin "abc\r\ndef") 84 | (list (line T) (line T)) ) ) 85 | (test '("a" "bc" "def") 86 | (pipe (prin "abcdef") 87 | (line T 1 2 3) ) ) 88 | 89 | 90 | ### any ### 91 | (test '(a b c d) (any "(a b # Comment\nc d)")) 92 | (test "A String" (any "\"A String\"")) 93 | 94 | 95 | ### sym ### 96 | (test "(abc \"Hello\" 123)" 97 | (sym '(abc "Hello" 123)) ) 98 | 99 | 100 | ### str ### 101 | (test '(a (1 2) b) 102 | (str "a (1 2) b") ) 103 | (test '(a (1 2)) 104 | (str "a (1 2) # b") ) 105 | (test "a \"Hello\" DEF" 106 | (str '(a "Hello" DEF)) ) 107 | 108 | 109 | ### load ### 110 | (test 6 (load "-* 1 2 3")) 111 | 112 | 113 | ### in out err ### 114 | (out (tmp "file") 115 | (println 123) 116 | (println 'abc) 117 | (println '(d e f)) ) 118 | (in (tmp "file") 119 | (test 123 (read)) 120 | (in (tmp "file") 121 | (test 123 (read)) 122 | (test 'abc (in -1 (read))) ) 123 | (test '(d e f) (read)) ) 124 | 125 | (let Err (tmp "err") 126 | (test 1 (err Err (msg 1))) 127 | (test 2 (err (pack "+" Err) (msg 2))) 128 | (test "1\n2\n" (in Err (till NIL T))) ) 129 | 130 | 131 | ### input output ### 132 | (test "A" (input "A" (char))) 133 | (test '(+ 2 (* 3 4)) 134 | (let S (chop "(+ 2 (* 3 4))") (input (++ S) (read))) ) 135 | 136 | (test "(+ 2 (* 3 4))" 137 | (pack (make (output (link @@) (print '(+ 2 (* 3 4)))))) ) 138 | 139 | 140 | ### pipe ### 141 | (test 123 (pipe (println 123) (read))) 142 | (test "ABC DEF GHI" 143 | (pipe 144 | (out '(tr "[a-z]" "[A-Z]") (prinl "abc def ghi")) 145 | (line T) ) ) 146 | 147 | 148 | ### open close ### 149 | (let F (open (tmp "file")) 150 | (test 123 (in F (read))) 151 | (test 'abc (in F (read))) 152 | (test '(d e f) (in F (read))) 153 | (test F (close F)) ) 154 | 155 | 156 | ### echo ### 157 | (out (tmp "echo") 158 | (in (tmp "file") 159 | (echo) ) ) 160 | (in (tmp "echo") 161 | (test 123 (read)) 162 | (test 'abc (read)) 163 | (test '(d e f) (read)) ) 164 | (let F (tmp "file") 165 | (test "12" 166 | (pipe (in F (echo 2)) 167 | (line T) ) ) 168 | (test "23" 169 | (pipe (in F (echo 1 2)) 170 | (line T) ) ) ) 171 | 172 | 173 | ### prin prinl space print printsp println ### 174 | (out (tmp "prin") 175 | (prin 1) 176 | (prinl 2) 177 | (space) 178 | (print 3) 179 | (printsp 4) 180 | (println 5) ) 181 | (test (12 "\n" " " 34 5) 182 | (in (tmp "prin") 183 | (list (read) (char) (char) (read) (read)) ) ) 184 | 185 | 186 | ### flush rewind ### 187 | (out (tmp "prin") 188 | (prinl "abc") 189 | (flush) 190 | (test "abc" (in (tmp "prin") (line T))) 191 | (rewind) ) 192 | (out (tmp "prin") (prinl "def")) 193 | (test "def" (in (tmp "prin") (line T))) 194 | 195 | 196 | ### ext rd pr ### 197 | (let L (list (id 1 2) (cons (id 3 9) 'a) (cons (id 2 7) 'b)) 198 | (let L5 (list (id 6 2) (cons (id 8 9) 'a) (cons (id 7 7) 'b)) 199 | (out (tmp "ext") 200 | (ext 5 (pr L5)) ) 201 | (test L 202 | (in (tmp "ext") (rd)) ) 203 | (test L5 204 | (in (tmp "ext") (ext 5 (rd))) ) ) ) 205 | 206 | (pipe 207 | (for N 4096 208 | (pr N) ) 209 | (for N 4096 210 | (test N (rd)) ) ) 211 | (pipe 212 | (for C 4096 213 | (pr (char C)) ) 214 | (for C 4096 215 | (test C (char (rd))) ) ) 216 | (pipe 217 | (pr (7 "abc" (1 2 3) 'a)) 218 | (test (7 "abc" (1 2 3) 'a) (rd)) ) 219 | (test "def" 220 | (out (tmp "pr") 221 | (pr 'abc "EOF" 123 "def") ) ) 222 | (test '(abc "EOF" 123 "def") 223 | (in (tmp "pr") 224 | (make 225 | (use X 226 | (until (== "EOF" (setq X (rd "EOF"))) 227 | (link X) ) ) ) ) ) 228 | 229 | (let N 1 230 | (do 200 231 | (test N 232 | (pipe (pr N) (rd)) ) 233 | (test (- N) 234 | (pipe (pr (- N)) (rd)) ) 235 | (setq N (* 2 N)) 236 | (wait 10) ) ) 237 | 238 | ### wr ### 239 | (test 3 240 | (out (tmp "wr") 241 | (wr 1 2 3) ) ) 242 | (test (hex "010203") 243 | (in (tmp "wr") 244 | (rd 3) ) ) 245 | 246 | (for I 100 247 | (let (L (need I "01") N (hex (pack L))) 248 | (test N 249 | (pipe (apply wr (mapcar format L)) (rd I)) ) 250 | (wait 10) ) ) 251 | -------------------------------------------------------------------------------- /test/src/main.l: -------------------------------------------------------------------------------- 1 | # 13dec23 Software Lab. Alexander Burger 2 | 3 | ### Evaluation ### 4 | (test 2 5 | (when 1 6 | ('((N) N) (and 2)) 7 | @ ) ) 8 | 9 | ### alarm ### 10 | (let N 6 11 | (alarm 1 (inc 'N)) 12 | (test 6 N) 13 | (wait 2000) 14 | (test 7 N) 15 | (alarm 0) ) 16 | 17 | 18 | ### sigio ### 19 | (unless (member *OS '("SunOS" "OpenBSD" "Cygwin" "AIX" "HP-UX" "IRIX64")) 20 | (sigio (setq "SigSock" (port T 0 "SigPort")) 21 | (setq "SigVal" (udp "SigSock")) ) 22 | (udp "localhost" "SigPort" '(a b c)) 23 | (wait 200) 24 | (test '(a b c) "SigVal") 25 | (close "SigSock") ) 26 | 27 | 28 | ### kids ### 29 | (test 30 | (make 31 | (do 7 32 | (link (or (fork) (wait 2000) (bye))) ) ) 33 | (flip (kids)) ) 34 | 35 | ### protect ### 36 | (test NIL (pipe (prog (kill *Pid) (pr 7)) (rd))) 37 | (test 7 (pipe (protect (kill *Pid) (pr 7)) (rd))) 38 | 39 | 40 | ### quit ### 41 | (test "Quit" (catch '("Quit") (quit "Quit"))) 42 | 43 | 44 | ### byte ### 45 | (test (18 18) 46 | (let A (adr (81064793292668929)) # cnt 1200000000000012 47 | (list (byte A) (byte (+ A 7))) ) ) 48 | 49 | (test "ABC" 50 | (let P (native "@" "malloc" 'P 8) 51 | (byte P (char "A")) 52 | (byte (inc P) (char "B")) 53 | (byte (+ P 2) (char "C")) 54 | (byte (+ P 3) 0) 55 | (prog1 56 | (native "@" "strdup" 'S P) 57 | (native "@" "free" NIL P) ) ) ) 58 | 59 | 60 | ### adr ### 61 | (let (X (box 7) L (123)) 62 | (test 7 (val (adr (adr X)))) 63 | (test 123 (car (adr (adr L)))) ) 64 | 65 | ### env ### 66 | (setq *E (env)) 67 | (test NIL *E) 68 | 69 | (let (A 1 B 2) 70 | (setq *E (env)) ) 71 | (test '((A . 1) (B . 2)) *E) 72 | 73 | (let (A 1 B 2) 74 | (setq *E (env '(A B))) ) 75 | (test '((B . 2) (A . 1)) *E) 76 | 77 | (let (A 1 B 2) 78 | (setq *E (env 'X 7 '(A B (C . 3)) 'Y 8)) ) 79 | (test '((Y . 8) (C . 3) (B . 2) (A . 1) (X . 7)) *E) 80 | 81 | 82 | ### trail ### 83 | (when trail 84 | (let 85 | (F '((A B) (G (inc A) (dec B))) 86 | G '((X Y) (trail T)) ) 87 | (test '(@X (F 3 4) A 3 B 4 (G (inc A) (dec B)) X 4 Y 3) 88 | (F 3 4) ) ) ) 89 | 90 | ### up ### 91 | (test 1 92 | (let N 1 93 | ((quote (N) (up N)) 2) ) ) 94 | (test 7 95 | (let N 1 96 | ((quote (N) (up N 7)) 2) 97 | N ) ) 98 | 99 | 100 | ### sys ### 101 | (test "PicoLisp" (sys "TEST" "PicoLisp")) 102 | (test "PicoLisp" (sys "TEST")) 103 | 104 | 105 | ### args next arg rest #### 106 | (test '(T 1 3 (2 3 4)) 107 | (let foo '(@ (list (args) (next) (arg 2) (rest))) 108 | (foo 1 2 3 4) ) ) 109 | 110 | (test (7 NIL) 111 | ((quote @ (list (next) (next))) 7) ) 112 | 113 | 114 | ### usec ### 115 | (let U (usec) 116 | (wait 400) 117 | (test 4 (*/ (- (usec) U) 100000)) ) 118 | 119 | 120 | ### pwd ### 121 | (test *PWD (pwd)) 122 | 123 | 124 | ### cd ### 125 | (chdir "/" 126 | (test "/" (pwd)) ) 127 | 128 | 129 | ### info ### 130 | (test '(T . @) (info "@test")) 131 | (test (5 . @) 132 | (out (tmp "info") (prinl "info")) 133 | (info (tmp "info")) ) 134 | 135 | 136 | ### file ### 137 | (test (cons (tmp) "file" 1) 138 | (out (tmp "file") (println '(file))) 139 | (load (tmp "file")) ) 140 | 141 | 142 | ### dir ### 143 | (call "mkdir" "-p" (tmp "dir")) 144 | (out (tmp "dir/.abc")) 145 | (out (tmp "dir/a")) 146 | (out (tmp "dir/b")) 147 | (out (tmp "dir/c")) 148 | 149 | (test '("a" "b" "c") (sort (dir (tmp "dir")))) 150 | (test '("." ".." ".abc" "a" "b" "c") (sort (dir (tmp "dir") T))) 151 | 152 | 153 | ### cmd ### 154 | (cmd "test") 155 | (test "test" (cmd)) 156 | 157 | 158 | ### argv ### 159 | (test '("abc" "123") 160 | (pipe 161 | (call *CMD "-prog (println (argv)) (bye)" "abc" 123) 162 | (read) ) ) 163 | (test '("abc" "123") 164 | (pipe 165 | (call *CMD "-prog (argv A B) (println (list A B)) (bye)" "abc" 123) 166 | (read) ) ) 167 | 168 | 169 | ### opt ### 170 | (test '("abc" "123") 171 | (pipe 172 | (call *CMD "-prog (println (list (opt) (opt))) (bye)" "abc" 123) 173 | (read) ) ) 174 | (test "abc" 175 | (pipe 176 | (call *CMD "-de f () (println (opt))" "-f" "abc" "-bye") 177 | (read) ) ) 178 | 179 | 180 | ### date time ### 181 | (use (Dat1 Tim1 Dat2 Tim2 D1 T1 D2 T2) 182 | (until 183 | (= 184 | (setq Dat1 (date) Tim1 (time T)) 185 | (prog 186 | (setq 187 | Dat2 (date T) 188 | Tim2 (time T) 189 | D1 (in '(date "+%Y %m %d") (list (read) (read) (read))) 190 | T1 (in '(date "+%H %M %S") (list (read) (read) (read))) 191 | D2 (in '(date "-u" "+%Y %m %d") (list (read) (read) (read))) 192 | T2 (in '(date "-u" "+%H %M %S") (list (read) (read) (read))) ) 193 | (time) ) ) ) 194 | (test Tim1 (time T1)) 195 | (test Tim1 (apply time T1)) 196 | (test Tim2 (time T2)) 197 | (test Dat1 (date D1)) 198 | (test Dat1 (apply date D1)) 199 | (test Dat2 (date D2)) ) 200 | 201 | (test (2000 7 15) (date 730622)) 202 | (test 730622 (date 2000 7 15)) 203 | (test 730622 (date (2000 7 15))) 204 | (test NIL (date NIL)) 205 | 206 | (test (11 17 23) (time 40643)) 207 | (test 40643 (time 11 17 23)) 208 | (test 40643 (time (11 17 23))) 209 | (test NIL (time NIL)) 210 | -------------------------------------------------------------------------------- /test/src/net.l: -------------------------------------------------------------------------------- 1 | # 06oct20 Software Lab. Alexander Burger 2 | 3 | ### port listen connect ### 4 | (test '(a b c) 5 | (let P (port 0 "ListenPort") 6 | (unless (fork) 7 | (close P) 8 | (until (connect "localhost" "ListenPort") 9 | (wait 80) ) 10 | (out @ (pr '(a b c))) 11 | (bye) ) 12 | (prog1 13 | (in (listen P) (rd)) 14 | (close P) ) ) ) 15 | 16 | 17 | ### udp ### 18 | (test '(a b c) 19 | (let P (port T 0 "UdpPort") 20 | (if (fork) 21 | (udp P) 22 | (close P) 23 | (wait 400) 24 | (udp "localhost" "UdpPort" '(a b c)) 25 | (bye) ) ) ) 26 | -------------------------------------------------------------------------------- /vip: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | exec ${0%/*}/bin/picolisp ${0%/*}/lib.l @bin/vip "$@" 3 | --------------------------------------------------------------------------------