#!/bin/sh
exec ${0%/*}/bin/picolisp ${0%/*}/lib.l @bin/vip "$@"

# 04jun23 Software Lab. Alexander Burger
### name ###
(test "abc" (name 'abc))
(test "A123" (name '{A123}))
(let X (box)
   (test NIL (name X)) )
### sp? ###
(test T (sp? " \t\n"))
(test NIL (sp? " abc"))
(test NIL (sp? 123))
### pat? ###
(test `(char '@) (char (pat? '@)))
(test NIL (pat? "ABC"))
(test NIL (pat? 123))
### fun? ###
(test 1000000000 (fun? 1000000000))
(test NIL (fun? 12345678901234567890))
(test '(A B) (fun? '((A B) (* A B))))
(test NIL (fun? '((A B) (* A B) . C)))
(test NIL (fun? (1 2 3 4)))
(test NIL (fun? '((A 2 B) (* A B))))
(test T (fun? '(NIL (* 3 4))))
### getd ###
(test car (getd 'car))
(test '((File . @) (load File))
   (getd 'script) )
(test NIL (getd 1))
### all ###
(test '(test)
   (filter '((S) (= S "test")) (all)) )
### symbols nsp ###
(when symbols
   (test T (bool (pair pico)))
   (test '(pico) (symbols 'myLib 'pico)) )
(when symbols
   (one Foo)
   (test 'pico (nsp 'symbols))
   (test 'myLib (nsp 'Foo))
   (test '(myLib pico) (symbols 'pico)) )
(when symbols
   (test 1 myLib~Foo)
   (test NIL (nsp 'myLib~Foo)) )
### intern ###
(test car (val (intern (pack "c" "a" "r"))))
(test car (val (intern '("c" "a" "r"))))
### ==== ###
(setq *Sym "abc")
(test T (== *Sym "abc"))
(====)
(test NIL (== *Sym "abc"))
### box? ###
(let X (box)
   (test X (box? X)) )
(test NIL (box? 123))
(test NIL (box? 'a))
(test NIL (box? NIL))
### str? ###
(test NIL (str? 123))
(test NIL (str? '{A123}))
(test NIL (str? 'abc))
(test "abc" (str? "abc"))
### zap ###
(test "abc" (str? (zap 'abc)))
### chop ###
(test '("c" "a" "r") (chop 'car))
(test '("H" "e" "l" "l" "o") (chop "Hello"))
(test '("1" "2" "3") (chop 123))
(test (1 2 3) (chop (1 2 3)))
(test NIL (chop NIL))
### pack ###
(test "car is 1 symbol name"
   (pack 'car " is " 1 '(" symbol " name)) )
### glue ###
(test 1 (glue NIL 1))
(test "a" (glue NIL '(a)))
(test "ab" (glue NIL '(a b)))
(test "a,b" (glue "," '(a b)))
(test "a8b" (glue 8 '(a b)))
(test "a123b123c" (glue (1 2 3) '(a b c)))
### text ###
(test "abc XYZ def 123" (text "abc @1 def @2" 'XYZ 123))
(test "aXYZz" (text "a@3z" 1 2 '(X Y Z)))
(test "a@bc.de" (text "a@@bc.@1" "de"))
(test "10.11.12" (text "@A.@B.@C" 1 2 3 4 5 6 7 8 9 10 11 12))
(test "1 2 3 4 5 6 7 8 9 10 11 12"
   (text "@1 @2 @3 @4 @5 @6 @7 @8 @9 @A @B @C" 1 2 3 4 5 6 7 8 9 10 11 12) )
### pre? ###
(test "abcdefg" (pre? "" "abcdefg"))
(test NIL (pre? "abc" ""))
(test "abcdefg" (pre? "abc" "abcdefg"))
(test NIL (pre? "def" "abcdefg"))
(test "abcdefg" (pre? "" "abcdefg"))
(test "7fach" (pre? (+ 3 4) "7fach"))
### sub? ###
(test "abcdefg" (sub? "" "abcdefg"))
(test NIL (sub? "abc" ""))
(test "abcdefg" (sub? "cde" "abcdefg"))
(test "abcdefg" (sub? "def" "abcdefg"))
(test NIL (sub? "abb" "abcdefg"))
(test "abcdefg" (sub? "" "abcdefg"))
### val ###
(let L '(a b c)
   (test '(a b c) (val 'L))
   (test 'b (val (cdr L))) )
### set ###
(use L
   (test '(a b c) (set 'L '(a b c)))
   (test 999 (set (cdr L) 999))
   (test '(a 999 c) L) )
### setq ###
(use (A B)
   (test (123 123)
      (setq  A 123  B (list A A)) )
   (test 123 A)
   (test (123 123) B) )
### swap ###
(let (A 1  L (1 2 3))
   (test 1 (swap 'A 7))
   (test 7 (swap 'A 'xyz))
   (test 3 (swap (cddr L) A))
   (test (1 2 xyz) L) )
### xchg ###
(let (A 1  B 2  C '(a b c))
   (test 2 (xchg 'A C  'B (cdr C)))
   (test 'a A)
   (test 'b B)
   (test (1 2 c) C) )
### on off onOff zero one ###
(use (A B)
   (test T (on A B))
   (test T A)
   (test T B)
   (test NIL (off A))
   (test NIL A)
   (test NIL (onOff B))
   (test NIL B)
   (test T (onOff A B))
   (test T A)
   (test T B)
   (test 0 (zero A B))
   (test 0 A)
   (test 0 B)
   (test 1 (one A B))
   (test 1 A)
   (test 1 B) )
### default ###
(let (A NIL  B NIL)
   (test 2 (default A 1  B 2))
   (test A 1)
   (test B 2)
   (test 2 (default A 7  B 8))
   (test A 1)
   (test B 2) )
### push push1 pop ++ shift cut ###
(let L NIL
   (test 0 (push 'L 4 3 2 1 0))
   (test L (0 1 2 3 4))
   (test (1 2 3 4) (shift 'L))
   (test 0 (push1 'L 0))
   (test 1 (push1 'L 1))
   (test L (0 1 2 3 4))
   (test 0 (pop 'L))
   (test 1 (++ L))
   (test (2 3) (cut 2 'L))
   (test (4) L) )
### push1q ###
(let L NIL
   (test (2) (push1q 'L 'a (1) 'b (2)))
   (test (1) (push1q 'L 'b (1)))
   (test '((1) (2) b (1) a) L) )
### del ###
(let (L '((a b c) (d e f))  S (new))
   (put S 'lst L)
   (test '((a b c)) (del '(d e f) 'L))
   (test '(a b c) (del 'x L))
   (test '(a c) (del 'b L))
   (with S
      (test '((a b c)) (del '(d e f) (:: lst)))
      (test NIL (del '(a b c) (:: lst)))
      (test NIL (: lst)) ) )
(let L (1 1 2 3 1 2 3)
   (test (2 3 2 3) (del 1 'L T)) )
### queue ###
(let A NIL
   (test 1 (queue 'A 1))
   (test 2 (queue 'A 2))
   (test 3 (queue 'A 3))
   (test (1 2 3) A) )
### fifo ###
(let X NIL
   (test 1 (fifo 'X 1))
   (test 3 (fifo 'X 2 3))
   (test 1 (fifo 'X))
   (test 2 (fifo 'X))
   (test 3 (fifo 'X)) )
### rid ###
(let E (1 . 2)
   (test 2 (rid 'E 1)) )
(let E (1 2 3 2 4 . 2)
   (test (1 3 4) (rid 'E 2))
   (test (3 4) (rid 'E 1))
   (test (3) (rid 'E 4))
   (test (3) (rid 'E 7))
   (test NIL (rid 'E 3)) )
(let E NIL
   (fifo 'E 1 2 3 2 4 2)
   (test (2 1 2 3 2 4 . @Z) E)
   (test (4 1 3 . @Z) (rid 'E 2)) )
### idx lup ###
(let X NIL
   (test NIL (idx 'X 'd T))
   (test NIL (idx 'X (2 . f) T))
   (test NIL (idx 'X (3 . g) T))
   (test NIL (idx 'X '(a b c) T))
   (test NIL (idx 'X 17 T))
   (test NIL (idx 'X 'A T))
   (test '(d . @) (idx 'X 'd T))
   (test NIL (idx 'X T T))
   (test '(A) (idx 'X 'A))
   (test '(17 A d (2 . f) (3 . g) (a b c) T)
      (idx 'X) )
   (test (2 . f) (lup X 2))
   (test '((2 . f) (3 . g)) (lup X 1 4))
   (test '(17 . @) (idx 'X 17 NIL))
   (test '(A d (2 . f) (3 . g) (a b c) T)
      (idx 'X) )
   (off X)
   (for N '((4 . D) 3 (2 . B) Y (3 . C) Z (6 . F) 7 (7 . G) X (1 . A) T (5 . E) 5)
      (idx 'X N T) )
   (test '(3 5 7 X Y Z (1 . A) (2 . B) (3 . C) (4 . D) (5 . E) (6 . F) (7 . G) T)
      (idx 'X) )
   (test '((3 . C) (4 . D) (5 . E))
      (lup X 3 5) )
   (test '((1 . A) (2 . B) (3 . C) (4 . D) (5 . E) (6 . F) (7 . G))
         (lup X 0 9) ) )
### enum enum? ###
(let E NIL
   (for (I . S) '(a b c d e f g h i j k l m n o)
      (set (enum 'E I) S) )
   (test '(a (b (d (h) l) f (j) n) c (e (i) m) g (k) o)
      E )
   (test '(a b c d e f g h i j k l m n o)
      (make (for I 15 (link (val (enum 'E I))))) )
   (test NIL
      (enum 'E 0) )
   (test '((8 . h) (4 . d) (12 . l) (2 . b) (10 . j) (6 . f) (14 . n) (1 . a) (9 . i) (5 . e) (13 . m) (3 . c) (11 . k) (7 . g) (15 . o))
      (enum 'E) )
   (test '(g . @) (enum? E 7))
   (test NIL (enum? E 16)) )
(let G NIL
   (for I 4
      (for J 4
         (set (enum 'G I J) (* I J)) ) )
   (test (1 . @) (enum? G 1 1))
   (test (6 . @) (enum? G 2 3))
   (test (12 . @) (enum? G 3 4))
   (test NIL (enum? G 5))
   (test NIL (enum? G 1 5)) )
### put get prop ; =: : :: putl getl ###
(let (A (box)  B (box A)  C (box (cons A B)))
   (put B 'a A)
   (put C 'b B)
   (put A 'x 1)
   (put B 'a 'y 2)
   (put C 0 -1 'a 'z 3)
   (test '(NIL . p) (prop 'A 'p))
   (test 1 (get A 'x))
   (test 1 (; A x))
   (test 2 (with A (: y)))
   (test 2 (get A 'y))
   (test 2 (; A y))
   (test 2 (with B (: 0 y)))
   (test 2 (get B 0 'y))
   (test 2 (; B 0 y))
   (test 3 (with C (: b a z)))
   (test 3 (with C (: 0 1 z)))
   (test 3 (with C (: 0 -1 a z)))
   (test 3 (get C 0 1 'z))
   (test 3 (get C 0 -1 'a 'z))
   (test 3 (; C 0 -1 a z))
   (test 1 (push (prop 'A 'p) 1))
   (test 1 (with 'A (pop (:: p))))
   (test NIL (get 'A 'p))
   (test (3 . z) (prop C 0 -1 'a 'z))
   (test 9 (with C (=: 0 -1 a z (* 3 3))))
   (test (9 . z) (with C (:: 0 -1 a z)))
   (test (putl C 0 -1 'a '((1 . x) (2 . y))) (flip (getl C 'b 0))) )
(test NIL (get (1 2 3) 0))
(test 1 (get (1 2 3) 1))
(test 3 (get (1 2 3) 3))
(test NIL (get (1 2 3) 4))
(test (3) (get (1 2 3) -2))
(test 1 (get '((a (b . 1) (c . 2)) (d (e . 3) (f . 4))) 'a 'b))
(test 4 (get '((a (b . 1) (c . 2)) (d (e . 3) (f . 4))) 'd 'f))
### wipe ###
(let X (box (1 2 3 4))
   (put X 'a 1)
   (put X 'b 2)
   (test (1 2 3 4) (val X))
   (test '((2 . b) (1 . a)) (getl X))
   (wipe X)
   (test NIL (val X))
   (test NIL (getl X)) )
(setq "W" (1 2 3 4))
(put '"W" 'a 1)
(put '"W" 'b 2)
(test (1 2 3 4) "W")
(test '((2 . b) (1 . a)) (getl '"W"))
(wipe '"W")
(test NIL "W")
(test NIL (getl '"W"))
### meta ###
(let A '("B")
   (put '"B" 'a 123)
   (test 123 (meta 'A 'a)) )
### low? ###
(test "a" (low? "a"))
(test NIL (low? "A"))
(test NIL (low? 123))
(test NIL (low? "."))
### upp? ###
(test "A" (upp? "A"))
(test NIL (upp? "a"))
(test NIL (upp? 123))
(test NIL (upp? "."))
### lowc ###
(test "abc" (lowc "ABC"))
(test "äöü" (lowc "ÄÖÜ"))
(test "äöü" (lowc "äöü"))
(test 123 (lowc 123))
### uppc ###
(test "ABC" (uppc "abc"))
(test "ÄÖÜ" (uppc "äöü"))
(test "ÄÖÜ" (uppc "ÄÖÜ"))
(test 123 (lowc 123))
### fold ###
(test "1a2b3" (fold " 1A 2-b/3"))
(test "1a2" (fold " 1A 2-B/3" 3))

# 20jul22 Software Lab. Alexander Burger
### c[ad]*r ###
(let L '(1 2 3 4 5)
   (test 1 (car L))
   (test (2 3 4 5) (cdr L))
   (test 2 (cadr L))
   (test (3 4 5) (cddr L))
   (test 3 (caddr L))
   (test (4 5) (cdddr L))
   (test 4 (cadddr L))
   (test (5) (cddddr L)) )
(let L '((1 2 3) (4 5))
   (test 1 (caar L))
   (test (2 3) (cdar L))
   (test 2 (cadar L))
   (test (3) (cddar L))
   (test 4 (caadr L))
   (test (5) (cdadr L)) )
(let L '(((1 2)))
   (test 1 (caaar L))
   (test (2) (cdaar L)) )
### nth ###
(test '(b c d) (nth '(a b c d) 2))
(test '(c) (nth '(a (b c) d) 2 2))
### con ###
(let C (1 . a)
   (test '(b c d) (con C '(b c d)))
   (test (1 b c d) C) )
### cons ###
(test (1 . 2) (cons 1 2))
(test '(a b c d) (cons 'a '(b c d)))
(test '((a b) c d) (cons '(a b) '(c d)))
(test '(a b c . d) (cons 'a 'b 'c 'd))
### conc ###
(let (A (1 2 3)  B '(a b c))
   (test (1 2 3 a b c) (conc A B))
   (test (1 2 3 a b c) A) )
(test (1 2 3 4 5 6)
   (conc (1 2 3) NIL (4 5 6)) )
### circ ###
(let C (circ 'a 'b 'c)
   (test '(a b c . @) C)
   (test T (== C (cdddr C))) )
### rot ###
(test (4 1 2 3) (rot (1 2 3 4)))
(test (3 1 2 4 5 6) (rot (1 2 3 4 5 6) 3))
(test (3 1 2 . @Z) (rot (1 2 3 .)))
### list ###
(test (1 2 3 4) (list 1 2 3 4))
(test '(a (2 3) "OK") (list 'a (2 3) "OK"))
### need ###
(test '(NIL NIL NIL NIL NIL) (need 5))
(test '(NIL NIL a b c) (need 5 '(a b c)))
(test '(a b c NIL NIL) (need -5 '(a b c)))
(test '(" " " " a b c) (need 5 '(a b c) " "))
(test (0 0 0) (need 3 0))
### range ###
(test (1 2 3 4 5 6) (range 1 6))
(test (6 5 4 3 2 1) (range 6 1))
(test (-3 -2 -1 0 1 2 3) (range -3 3))
(test (3 1 -1 -3) (range 3 -3 2))
(test (-3 -2 -1) (range -3 -1))
### full ###
(test T (full (1 2 3)))
(test NIL (full (1 NIL 3)))
(test T (full 123))
### make made chain link yoke ###
(let (A 'a I 'i)
   (test '(x y z z a)
      (make
         (link (for A '(x y z) (link A)))
         (link A) ) )
   (test (-1 0 1 x 2 y 3 z i a)
      (make
         (made (cons 0 (box)))
         (for (I . A) '(x y z) (link I A))
         (test (0 1 x 2 y 3 z) (made))
         (made (cons -1 (made)))
         (link I A) ) )
   (test (1 2 3 4 5 6 7 8 9)
      (make (chain (1 2 3)) (chain (4 5 6) (7 8 9))) )
   (test '(a b c)
      (make (yoke 'b) (link 'c) (yoke 'a)) )
   (test '((x y z) (y z) (z) (z) a)
      (make (link (for (A '(x y z) A (cdr A)) (link A))) (link A)) )
   (test (1 (x y z) 2 (y z) 3 (z) (z) i a)
      (make (link (for ((I . A) '(x y z) A (cdr A)) (link I A))) (link I A)) ) )
### copy ###
(test T (=T (copy T)))
(let L (1 2 3)
   (test T (== L L))
   (test NIL (== L (copy L)))
   (test T (= L (copy L)))
   (test T (= (1 2 3) (copy L))) )
### mix ###
(test '(c d a b) (mix '(a b c d) 3 4 1 2))
(test '(a A d D) (mix '(a b c d) 1 'A 4 'D))
### append ###
(test '(a b c 1 2 3) (append '(a b c) (1 2 3)))
(test (1 2 3 . 4) (append (1) (2) (3) 4))
### delete ###
(test (1 3)
   (delete 2 (1 2 3)) )
(test '((1 2) (5 6) (3 4))
   (delete (3 4) '((1 2) (3 4) (5 6) (3 4))) )
(test (1 2 3 1 2 3)
   (delete 1 (1 1 2 3 1 2 3)) )
(test (2 3 2 3)
   (delete 1 (1 1 2 3 1 2 3) T) )
### delq ###
(test '(a c)
   (delq 'b '(a b c)) )
(test (1 (2) 3)
   (delq (2) (1 (2) 3)) )
(test '(a b c a b c)
   (delq 'a '(a a b c a b c)) )
(test '(b c b c)
   (delq 'a '(a a b c a b c) T) )
### replace ###
(test '(A b b A) (replace '(a b b a) 'a 'A))
(test '(a B B a) (replace '(a b b a) 'b 'B))
(test '(B A A B) (replace '(a b b a) 'a 'B 'b 'A))
### insert ###
(test '(a b 777 c d e) (insert 3 '(a b c d e) 777))
(test (777 a b c d e) (insert 1 '(a b c d e) 777))
(test '(a b c d e 777) (insert 9 '(a b c d e) 777))
### remove ###
(test '(a b d e) (remove 3 '(a b c d e)))
(test '(b c d e) (remove 1 '(a b c d e)))
(test '(a b c d e) (remove 9 '(a b c d e)))
### place ###
(test (7) (place 1 NIL 7))
(test (7 2 3) (place -1 (1 2 3) 7))
(test '(a b 777 d e) (place 3 '(a b c d e) 777))
(test (777 b c d e) (place 1 '(a b c d e) 777))
(test '(a b c d e 777) (place 9 '(a b c d e) 777))
### strip ###
(test 123 (strip 123))
(test '(a) (strip '''(a)))
(test '(a b c) (strip (quote quote a b c)))
### split ###
(test '((1) (2 b) (c 4 d 5) (6))
   (split (1 a 2 b 3 c 4 d 5 e 6) 'e 3 'a) )
(test '("The" "quick" "brown" "fox")
   (mapcar pack (split (chop "The quick brown fox") " ")) )
### reverse ###
(test (4 3 2 1) (reverse (1 2 3 4)))
(test NIL (reverse NIL))
### flip ###
(test (4 3 2 1) (flip (1 2 3 4)))
(test (3 2 1 4 5 6) (flip (1 2 3 4 5 6) 3))
(test NIL (flip NIL))
### trim ###
(test (1 NIL 2) (trim (1 NIL 2 NIL NIL)))
(test '(a b) (trim '(a b " " " ")))
### clip ###
(test (1 NIL 2) (clip '(NIL 1 NIL 2 NIL)))
(test '(a " " b) (clip '(" " a " " b " ")))
### head ###
(test '(a b c) (head 3 '(a b c d e f)))
(test NIL (head NIL '(a b c d e f)))
(test NIL (head 0 '(a b c d e f)))
(test '(a b c d e f) (head 10 '(a b c d e f)))
(test '(a b c d) (head -2 '(a b c d e f)))
(test '(a b c) (head '(a b c) '(a b c d e f)))
### tail ###
(test '(d e f) (tail 3 '(a b c d e f)))
(test '(c d e f) (tail -2 '(a b c d e f)))
(test NIL (tail NIL '(a b c d e f)))
(test NIL (tail 0 '(a b c d e f)))
(test '(a b c d e f) (tail 10 '(a b c d e f)))
(test '(d e f) (tail '(d e f) '(a b c d e f)))
### stem ###
(test '("g" "h" "i") (stem (chop "abc/def\\ghi") "/" "\\"))
(test '("g" "h" "i") (stem (chop "abc/def\\ghi") "\\" "/"))
### fin ###
(test 'a (fin 'a))
(test 'b (fin '(a . b)))
(test 'c (fin '(a b . c)))
(test NIL (fin '(a b c)))
### last ###
(test 4 (last (1 2 3 4)))
(test '(d e f) (last '((a b) c (d e f))))
### == ###
(test T (== 'a 'a))
(test T (== 'NIL NIL (val NIL) (car NIL) (cdr NIL)))
(test NIL (== (1 2 3) (1 2 3)))
### n== ###
(test NIL (n== 'a 'a))
(test T (n== (1) (1)))
### = ###
(test T (= 6 (* 1 2 3)))
(test T (= "a" "a"))
(test T (== "a" "a"))
(test T (= (1 (2) 3) (1 (2) 3)))
(test T (= (1 . (2 3 .)) (1 . (2 3 .))))
(test T (= (1 .) (1 .)))
### <> ###
(test T (<> 'a 'b))
(test T (<> 'a 'b 'b))
(test NIL (<> 'a 'a 'a))
### =0 ###
(test 0 (=0 (- 6 3 2 1)))
(test NIL (=0 'a))
### =1 ###
(test 1 (=1 (- 6 3 2)))
(test NIL (=0 'a))
### =T ###
(test NIL (=T 0))
(test NIL (=T "T"))
(test T (=T T))
### n0 ###
(test NIL (n0 (- 6 3 2 1)))
(test T (n0 'a))
### nT ###
(test T (nT 0))
(test T (nT "T"))
(test NIL (nT T))
### < ###
(test T (< 3 4))
(test T (< 'a 'b 'c))
(test T (< 999 'a))
(test T (< NIL 7 'x (1) T))
### <= ###
(test T (<= 3 3))
(test T (<= 1 2 3))
(test T (<= "abc" "abc" "def"))
### > ###
(test T (> 4 3))
(test T (> 'A 999))
(test T (> T (1) 'x 7 NIL))
(test T (> (1 1 .) (1 .)))
### >= ###
(test T (>= 'A 999))
(test T (>= 3 2 2 1))
### max ###
(test 'z (max 2 'a 'z 9))
(test (5) (max (5) (2 3) 'X))
### min ###
(test 2 (min 2 'a 'z 9))
(test 'X (min (5) (2 3) 'X))
### atom ###
(test T (atom 123))
(test T (atom 'a))
(test T (atom NIL))
(test NIL (atom (123)))
### pair ###
(test NIL (pair NIL))
(test (1 . 2) (pair (1 . 2)))
(test (1 2 3) (pair (1 2 3)))
### circ? ###
(test NIL (circ? 'a))
(test NIL (circ? (1 2 3)))
(test (2 3 . @) (circ? (1 . (2 3 .))))
### lst? ###
(test T (lst? NIL))
(test NIL (lst? T))
(test T (lst? (1 . 2)))
(test T (lst? (1 2 3)))
### num? ###
(test 123 (num? 123))
(test NIL (num? 'abc))
(test NIL (num? (1 2 3)))
### sym? ###
(test T (sym? 'a))
(test T (sym? NIL))
(test NIL (sym? 123))
(test NIL (sym? '(a b)))
### flg? ###
(test T (flg? T))
(test T (flg? NIL))
(test NIL (flg? 0))
(test T (flg? (= 3 3)))
(test T (flg? (= 3 4)))
(test NIL (flg? (+ 3 4)))
### member ###
(test (3 4 5 6) (member 3 (1 2 3 4 5 6)))
(test (3 . @) (member 3 (1 2 3 4 5 6 .)))
(test NIL (member 9 (1 2 3 4 5 6)))
(test NIL (member 9 (1 2 3 4 5 6 .)))
(test '((d e f) (g h i))
   (member '(d e f) '((a b c) (d e f) (g h i))) )
### memq ###
(test '(c d e f) (memq 'c '(a b c d e f)))
(test '(c . @) (memq 'c '(a b c d e f .)))
(test NIL (memq (2) '((1) (2) (3))))
(test NIL (memq (2) '((1) (2) (3) .)))
(test 'c (memq 'c '(a b . c)))
(test '(b c a . @Z) (memq 'b '(a b c .)))
(test NIL (memq 'd '(a b c .)))
### mmeq ###
(test NIL (mmeq '(a b c) '(d e f)))
(test '(b x) (mmeq '(a b c) '(d b x)))
### sect ###
(test (3 4) (sect (1 2 3 4) (3 4 5 6)))
(test (1 2 3) (sect (1 2 3) (1 2 3)))
(test NIL (sect (1 2 3) (4 5 6)))
### diff ###
(test (1 3 5) (diff (1 2 3 4 5) (2 4)))
(test (1 2 3) (diff (1 2 3) NIL))
(test NIL (diff (1 2 3) (1 2 3)))
### index ###
(test 3 (index 'c '(a b c d e f)))
(test NIL (index 'z '(a b c d e f)))
(test 3 (index '(5 6) '((1 2) (3 4) (5 6) (7 8))))
### offset ###
(test 3 (offset '(c d e f) '(a b c d e f)))
(test NIL (offset '(c d e) '(a b c d e f)))
### prior ###
(let (L (1 2 3 4 5 6)  X (cdddr L))
   (test NIL (prior L L))
   (test NIL (prior NIL L))
   (test (3 4 5 6) (prior X L)) )
### length ###
(test 3 (length "abc"))
(test 3 (length "äbc"))
(test 3 (length 123))
(test 3 (length (1 (2) 3)))
(test T (length (1 2 3 .)))
(test T (length (1 . (2 3 .))))
### size ###
(test 3 (size "abc"))
(test 4 (size "äbc"))
(test 1 (size 127))
(test 2 (size 128))
(test 4 (size (1 (2) 3)))
(test 3 (size (1 2 3 .)))
(test 8 (size '((1 2 3) (4 5 6))))
(test 6 (size '((1 2 .) (4 5 .))))
(test 3 (size (1 . (2 3 .))))
### bytes ###
(test 4 (bytes "abc"))
(test 5 (bytes "äbc"))
(test 9 (bytes "abcdefgh"))
(test 2 (bytes 127))
(test 3 (bytes 128))
(test 10 (bytes (101 (102) 103)))
(test 9 (bytes (101 102 103 .)))
(let (L (7 "abc" (1 2 3) 'a)  F (tmp "bytes"))
   (out F (pr L))
   (test (bytes L) (car (info F))) )
### assoc ###
(test '("b" . 7)
   (assoc "b" '((999 1 2 3) ("b" . 7) ("ok" "Hello"))) )
(test '("b" . 7)
   (assoc "b" '((999 1 2 3) ("b" . 7) ("ok" "Hello") .)) )
(test (999 1 2 3)
   (assoc 999 '((999 1 2 3) ("b" . 7) ("ok" "Hello"))) )
(test NIL
   (assoc 'u '((999 1 2 3) ("b" . 7) ("ok" "Hello"))) )
(test NIL
   (assoc 'u '((999 1 2 3) ("b" . 7) ("ok" "Hello") .)) )
### rassoc ###
(test '("b" . 7)
   (rassoc 7 '((999 1 2 3) ("b" . 7) ("ok" "Hello"))) )
(test '("b" . 7)
   (rassoc 7 '((999 1 2 3) ("b" . 7) ("ok" "Hello") .)) )
(test (999 1 2 3)
   (rassoc (1 2 3) '((999 1 2 3) ("b" . 7) ("ok" "Hello"))) )
(test NIL
   (rassoc 'u '((999 1 2 3) ("b" . 7) ("ok" "Hello"))) )
(test NIL
   (rassoc 'u '((999 1 2 3) ("b" . 7) ("ok" "Hello") .)) )
### asoq ###
(test NIL
   (asoq (9) '(((9) 1 2 3) (b . 7) ("ok" "Hello"))) )
(test NIL
   (asoq (9) '(((9) 1 2 3) (b . 7) ("ok" "Hello") .)) )
(test '(b . 7)
   (asoq 'b '(((9) 1 2 3) (b . 7) ("ok" "Hello"))) )
(test '(b . 7)
   (asoq 'b '(((9) 1 2 3) (b . 7) ("ok" "Hello") .)) )
### rasoq ###
(test '(2 . b)
   (rasoq 'b '((1 . a) (2 . b) (3 . c))) )
(test '(2 . b)
   (rasoq 'b '((1 . a) (2 . b) (3 . c) .)) )
(test NIL
   (rasoq "b" '((1 . a) (2 . b) (3 . c))) )
(test NIL
   (rasoq "b" '((1 . a) (2 . b) (3 . c) .)) )
### rank ###
(test NIL
   (rank 0 '((1 . a) (100 . b) (1000 . c))) )
(test (1 . a)
   (rank 50 '((1 . a) (100 . b) (1000 . c))) )
(test (100 . b)
   (rank 100 '((1 . a) (100 . b) (1000 . c))) )
(test (100 . b)
   (rank 300 '((1 . a) (100 . b) (1000 . c))) )
(test (1000 . c)
   (rank 9999 '((1 . a) (100 . b) (1000 . c))) )
(test (100 . b)
   (rank 50 '((1000 . a) (100 . b) (1 . c)) T) )
### match ###
(use (@A @B @X @Y @Z)
   (test T
      (match '(@A is @B) '(This is a test)) )
   (test '(This) @A)
   (test '(a test) @B)
   (test T
      (match '(@X (d @Y) @Z) '((a b c) (d (e f) g) h i)) )
   (test '((a b c)) @X)
   (test '((e f) g) @Y)
   (test '(h i) @Z) )
### fill ###
(let (@X 1234  @Y (1 2 3 4))
   (test 1234 (fill '@X))
   (test '(a b (c 1234) (((1 2 3 4) . d) e))
      (fill '(a b (c @X) ((@Y . d) e))) ) )
(test (1 a b c 9)
   (fill (1 ^(list 'a 'b 'c) 9)) )
(test (1 5 7)
   (fill (1 ^(+ 2 3) 7)) )
(let X 2 (test (1 2 3) (fill (1 X 3) 'X)))
(let X 2 (test (1 2 3) (fill (1 X 3) '(X))))
(test (1 (a (7 . 2) c) 3)
   (fill (1 (a (b . 2) c) 3) 'b 7) )
(test (1 (a (b . 123) c) 3)
   (fill (1 (a (b . 2) c) 3) 2 123) )
### prove ###
(test T
   (prove (goal '((equal 3 3)))) )
(test '((@X . 3))
   (prove (goal '((equal 3 @X)))) )
(test NIL
   (prove (goal '((equal 3 4)))) )
### -> ###
(test '((@A . 3) (@B . 7))
   (prove (goal '(@A 3 (^ @B (+ 4 (-> @A)))))) )
(test '((@A . 3) (@B . 7))
   (prove (goal '(@A 3 (^ @B (+ 4 @A))))) )
(test '((@A . 3) (@B . 4) (@N . 12))
   (prove (goal '(@A 3 @B 4 (^ @N (* @A @B))))) )
### unify ###
(test '((@A ((NIL . @C) 0 . @C) ((NIL . @B) 0 . @B) T))
   (prove (goal '((^ @A (unify '(@B @C)))))) )
### not/1 call/1 or/2 nil/1 uniq/2 ###
(test NIL
   (prove (goal '(@A 3 @B 3 (not (equal @A @B))))) )
(test '((@A . 3) (@B . 4))
   (prove (goal '(@A 3 @B 4 (not (equal @A @B))))) )
(test '((@A 1 2 3) (@X 4 5 6))
   (prove (goal '(@A (1 2 3) (call append @A @X (1 2 3 4 5 6))))) )
(test '((@X . 7))
   (prove (goal '((or ((equal 3 @X) (equal @X 4)) ((equal 7 @X) (equal @X 7)))))) )
(test '((@X)) (prove (goal '(@X NIL (nil @X)))))
(test '(a b c d)
   (solve '((^ @B (box)) (lst @X (a b c b c d)) (uniq @B @X)) @X) )
### asserta/1 assertz/1 retract/1 ###
(test T
   (prove
      (goal
         (quote
            (asserta (a (2)))
            (assertz (a (3)))
            (asserta (a (1))) ) ) ) )
(test '(((1)) ((2)) ((3)))
   (get 'a T) )
(test T
   (prove (goal '((retract (a 2))))) )
(test '(((1)) ((3)))
   (get 'a T) )
### clause/2 ###
(test T
   (prove (goal '((clause append ((NIL @X @X)))))) )
(test '((@C (NIL @X @X)))
   (prove (goal '((clause append @C)))) )
### for/2 for/3 for/4 ###
(test '(((@I . 1)) ((@I . 2)) ((@I . 3)))
   (solve '((for @I 3))) )
(test '(((@I . 3)) ((@I . 4)) ((@I . 5)) ((@I . 6)) ((@I . 7)))
   (solve '((for @I 3 7))) )
(test '(((@I . 7)) ((@I . 5)) ((@I . 3)))
   (solve '((for @I 7 3 2))) )
### group ###
(test '((1 a b c) (2 d e f))
   (group '((1 . a) (1 . b) (1 . c) (2 . d) (2 . e) (2 . f))) )
### sort ###
(test '(NIL 1 2 3 4 a b c d (1 2 3) (a b c) (x y z) T)
   (sort '(a 3 1 (1 2 3) d b 4 T NIL (a b c) (x y z) c 2)) )
(test '(T (x y z) (a b c) (1 2 3) d c b a 4 3 2 1 NIL)
   (sort '(a 3 1 (1 2 3) d b 4 T NIL (a b c) (x y z) c 2) >) )

# 06oct20 Software Lab. Alexander Burger
### port listen connect ###
(test '(a b c)
   (let P (port 0 "ListenPort")
      (unless (fork)
         (close P)
         (until (connect "localhost" "ListenPort")
            (wait 80) )
         (out @ (pr '(a b c)))
         (bye) )
      (prog1
         (in (listen P) (rd))
         (close P) ) ) )
### udp ###
(test '(a b c)
   (let P (port T 0 "UdpPort")
      (if (fork)
         (udp P)
         (close P)
         (wait 400)
         (udp "localhost" "UdpPort" '(a b c))
         (bye) ) ) )

# 13dec23 Software Lab. Alexander Burger
### Evaluation ###
(test 2
   (when 1
      ('((N) N) (and 2))
      @ ) )
### alarm ###
(let N 6
   (alarm 1 (inc 'N))
   (test 6 N)
   (wait 2000)
   (test 7 N)
   (alarm 0) )
### sigio ###
(unless (member *OS '("SunOS" "OpenBSD" "Cygwin" "AIX" "HP-UX" "IRIX64"))
   (sigio (setq "SigSock" (port T 0 "SigPort"))
      (setq "SigVal" (udp "SigSock")) )
   (udp "localhost" "SigPort" '(a b c))
   (wait 200)
   (test '(a b c) "SigVal")
   (close "SigSock") )
### kids ###
(test
   (make
      (do 7
         (link (or (fork) (wait 2000) (bye))) ) )
   (flip (kids)) )
### protect ###
(test NIL (pipe (prog (kill *Pid) (pr 7)) (rd)))
(test 7 (pipe (protect (kill *Pid) (pr 7)) (rd)))
### quit ###
(test "Quit" (catch '("Quit") (quit "Quit")))
### byte ###
(test (18 18)
   (let A (adr (81064793292668929))  # cnt 1200000000000012
      (list (byte A) (byte (+ A 7))) ) )
(test "ABC"
   (let P (native "@" "malloc" 'P 8)
      (byte P (char "A"))
      (byte (inc P) (char "B"))
      (byte (+ P 2) (char "C"))
      (byte (+ P 3) 0)
      (prog1
         (native "@" "strdup" 'S P)
         (native "@" "free" NIL P) ) ) )
### adr ###
(let (X (box 7)  L (123))
   (test 7 (val (adr (adr X))))
   (test 123 (car (adr (adr L)))) )
### env ###
(setq *E (env))
(test NIL *E)
(let (A 1 B 2)
   (setq *E (env)) )
(test '((A . 1) (B . 2)) *E)
(let (A 1 B 2)
   (setq *E (env '(A B))) )
(test '((B . 2) (A . 1)) *E)
(let (A 1 B 2)
   (setq *E (env 'X 7 '(A B (C . 3)) 'Y 8)) )
(test '((Y . 8) (C . 3) (B . 2) (A . 1) (X . 7)) *E)
### trail ###
(when trail
   (let
      (F '((A B) (G (inc A) (dec B)))
         G '((X Y) (trail T)) )
      (test '(@X (F 3 4) A 3 B 4 (G (inc A) (dec B)) X 4 Y 3)
         (F 3 4) ) ) )
### up ###
(test 1
   (let N 1
      ((quote (N) (up N)) 2) ) )
(test 7
   (let N 1
      ((quote (N) (up N 7)) 2)
      N ) )
### sys ###
(test "PicoLisp" (sys "TEST" "PicoLisp"))
(test "PicoLisp" (sys "TEST"))
### args next arg rest ####
(test '(T 1 3 (2 3 4))
   (let foo '(@ (list (args) (next) (arg 2) (rest)))
      (foo 1 2 3 4) ) )
(test (7 NIL)
   ((quote @ (list (next) (next))) 7) )
### usec ###
(let U (usec)
   (wait 400)
   (test 4 (*/ (- (usec) U) 100000)) )
### pwd ###
(test *PWD (pwd))
### cd ###
(chdir "/"
   (test "/" (pwd)) )
### info ###
(test '(T . @) (info "@test"))
(test (5 . @)
   (out (tmp "info") (prinl "info"))
   (info (tmp "info")) )
### file ###
(test (cons (tmp) "file" 1)
   (out (tmp "file") (println '(file)))
   (load (tmp "file")) )
### dir ###
(call "mkdir" "-p" (tmp "dir"))
(out (tmp "dir/.abc"))
(out (tmp "dir/a"))
(out (tmp "dir/b"))
(out (tmp "dir/c"))
(test '("a" "b" "c") (sort (dir (tmp "dir"))))
(test '("." ".." ".abc" "a" "b" "c") (sort (dir (tmp "dir") T)))
### cmd ###
(cmd "test")
(test "test" (cmd))
### argv ###
(test '("abc" "123")
   (pipe
      (call *CMD "-prog (println (argv)) (bye)" "abc" 123)
      (read) ) )
(test '("abc" "123")
   (pipe
      (call *CMD "-prog (argv A B) (println (list A B)) (bye)" "abc" 123)
      (read) ) )
### opt ###
(test '("abc" "123")
   (pipe
      (call *CMD "-prog (println (list (opt) (opt))) (bye)" "abc" 123)
      (read) ) )
(test "abc"
   (pipe
      (call *CMD "-de f () (println (opt))" "-f" "abc" "-bye")
      (read) ) )
### date time ###
(use (Dat1 Tim1 Dat2 Tim2 D1 T1 D2 T2)
   (until
      (=
         (setq Dat1 (date)  Tim1 (time T))
         (prog
            (setq
               Dat2 (date T)
               Tim2 (time T)
               D1 (in '(date "+%Y %m %d") (list (read) (read) (read)))
               T1 (in '(date "+%H %M %S") (list (read) (read) (read)))
               D2 (in '(date "-u" "+%Y %m %d") (list (read) (read) (read)))
               T2 (in '(date "-u" "+%H %M %S") (list (read) (read) (read))) )
            (time) ) ) )
   (test Tim1 (time T1))
   (test Tim1 (apply time T1))
   (test Tim2 (time T2))
   (test Dat1 (date D1))
   (test Dat1 (apply date D1))
   (test Dat2 (date D2)) )
(test (2000 7 15) (date 730622))
(test 730622 (date 2000 7 15))
(test 730622 (date (2000 7 15)))
(test NIL (date NIL))
(test (11 17 23) (time 40643))
(test 40643 (time 11 17 23))
(test 40643 (time (11 17 23)))
(test NIL (time NIL))

# 26may22 Software Lab. Alexander Burger
### path ###
(test 'task (cadr (in (path "@lib.l") (read))))
(test (char "+") (char (path "+@")))
### read ###
(test (1 2 3) (~(1 2) 3))
(test (1 3) (~(1 . 2) 3))
(test (1 2 3 4) (1 ~(2 3) 4))
(test (1 2 4) (1 ~(2 . 3) 4))
(test (1 2 3) [1 2 3])
(test (1 2 3) (1 2 3]
(test (1 2 3) (1 2 3)]
(test (1 (2 3)) (1 (2 3]
(test (quote 1 (2 (3))) '(1 (2 (3]
(test (quote 1 (2 (3))) '[1 (2 (3])
(test (1 abc (d e f))
   (pipe (prinl "(1 abc (d e f))")
      (read) ) )
(test '(abc "=" def_ghi "(" ("x" "y" "z") "+" "-" 123 ")")
   (pipe (prinl "abc = def_ghi(\"xyz\"+-123) # Comment")
      (make
         (while (read "_" "#")
            (link @) ) ) ) )
### wait ###
(let (*Run NIL  *Cnt 0)
   (test (1 2 3 4 5 6 7)
      (make
         (task -10 0  (link (inc '*Cnt)))
         (wait NIL (>= *Cnt 7)) ) ) )
### peek char ###
(pipe (prin "ab")
   (test "a" (peek))
   (test "a" (char))
   (test "b" (peek))
   (test "b" (char))
   (test NIL (peek))
   (test NIL (char)) )
(test "A" (char 65))
(test 65 (char "A"))
### skip ###
(test "a"
   (pipe (prinl "# Comment\na")
      (skip "#") ) )
(test "#"
   (pipe (prinl "# Comment\na")
      (skip) ) )
### eof ###
(test T (pipe NIL (eof)))
(test NIL (pipe (prin "a") (eof)))
(test T (pipe (prin "a") (eof T) (eof)))
### from till ###
(test "cd"
   (pipe (prin "ab.cd:ef")
      (from ".")
      (till ":" T) ) )
### line ###
(test '("a" "b" "c")
   (pipe (prin "abc\n") (line)) )
(test "abc"
   (pipe (prin "abc") (line T)) )
(test '("abc" "def")
   (pipe (prin "abc\ndef")
      (list (line T) (line T)) ) )
(test '("abc" "def")
   (pipe (prin "abc\rdef")
      (list (line T) (line T)) ) )
(test '("abc" "def")
   (pipe (prin "abc\r\ndef")
      (list (line T) (line T)) ) )
(test '("a" "bc" "def")
   (pipe (prin "abcdef")
      (line T 1 2 3) ) )
### any ###
(test '(a b c d) (any "(a b # Comment\nc d)"))
(test "A String" (any "\"A String\""))
### sym ###
(test "(abc \"Hello\" 123)"
   (sym '(abc "Hello" 123)) )
### str ###
(test '(a (1 2) b)
   (str "a (1 2) b") )
(test '(a (1 2))
   (str "a (1 2) # b") )
(test "a \"Hello\" DEF"
   (str '(a "Hello" DEF)) )
### load ###
(test 6 (load "-* 1 2 3"))
### in out err ###
(out (tmp "file")
   (println 123)
   (println 'abc)
   (println '(d e f)) )
(in (tmp "file")
   (test 123 (read))
   (in (tmp "file")
      (test 123 (read))
      (test 'abc (in -1 (read))) )
   (test '(d e f) (read)) )
(let Err (tmp "err")
   (test 1 (err Err (msg 1)))
   (test 2 (err (pack "+" Err) (msg 2)))
   (test "1\n2\n" (in Err (till NIL T))) )
### input output ###
(test "A" (input "A" (char)))
(test '(+ 2 (* 3 4))
   (let S (chop "(+ 2 (* 3 4))") (input (++ S) (read))) )
(test "(+ 2 (* 3 4))"
   (pack (make (output (link @@) (print '(+ 2 (* 3 4)))))) )
### pipe ###
(test 123 (pipe (println 123) (read)))
(test "ABC DEF GHI"
   (pipe
      (out '(tr "[a-z]" "[A-Z]") (prinl "abc def ghi"))
      (line T) ) )
### open close ###
(let F (open (tmp "file"))
   (test 123 (in F (read)))
   (test 'abc (in F (read)))
   (test '(d e f) (in F (read)))
   (test F (close F)) )
### echo ###
(out (tmp "echo")
   (in (tmp "file")
      (echo) ) )
(in (tmp "echo")
   (test 123 (read))
   (test 'abc (read))
   (test '(d e f) (read)) )
(let F (tmp "file")
   (test "12"
      (pipe (in F (echo 2))
         (line T) ) )
   (test "23"
      (pipe (in F (echo 1 2))
         (line T) ) ) )
### prin prinl space print printsp println ###
(out (tmp "prin")
   (prin 1)
   (prinl 2)
   (space)
   (print 3)
   (printsp 4)
   (println 5) )
(test (12 "\n" " " 34 5)
   (in (tmp "prin")
      (list (read) (char) (char) (read) (read)) ) )
### flush rewind ###
(out (tmp "prin")
   (prinl "abc")
   (flush)
   (test "abc" (in (tmp "prin") (line T)))
   (rewind) )
(out (tmp "prin") (prinl "def"))
(test "def" (in (tmp "prin") (line T)))
### ext rd pr ###
(let L (list (id 1 2) (cons (id 3 9) 'a) (cons (id 2 7) 'b))
   (let L5 (list (id 6 2) (cons (id 8 9) 'a) (cons (id 7 7) 'b))
      (out (tmp "ext")
         (ext 5 (pr L5)) )
      (test L
         (in (tmp "ext") (rd)) )
      (test L5
         (in (tmp "ext") (ext 5 (rd))) ) ) )
(pipe
   (for N 4096
      (pr N) )
   (for N 4096
      (test N (rd)) ) )
(pipe
   (for C 4096
      (pr (char C)) )
   (for C 4096
      (test C (char (rd))) ) )
(pipe
   (pr (7 "abc" (1 2 3) 'a))
   (test (7 "abc" (1 2 3) 'a) (rd)) )
(test "def"
   (out (tmp "pr")
      (pr 'abc "EOF" 123 "def") ) )
(test '(abc "EOF" 123 "def")
   (in (tmp "pr")
      (make
         (use X
            (until (== "EOF" (setq X (rd "EOF")))
               (link X) ) ) ) ) )
(let N 1
   (do 200
      (test N
         (pipe (pr N) (rd)) )
      (test (- N)
         (pipe (pr (- N)) (rd)) )
      (setq N (* 2 N))
      (wait 10) ) )
### wr ###
(test 3
   (out (tmp "wr")
      (wr 1 2 3) ) )
(test (hex "010203")
   (in (tmp "wr")
      (rd 3) ) )
(for I 100
   (let (L (need I "01")  N (hex (pack L)))
      (test N
         (pipe (apply wr (mapcar format L)) (rd I)) )
      (wait 10) ) )

# 06oct20 Software Lab. Alexander Burger
### ht:Prin ###
(test "1<2>3&äöü<i>ÄÖÜß"
   (pipe (ht:Prin "1<2>3&äöü<i>ÄÖÜß") (line T)) )
### ht:Fmt ###
(test "+123&abc&$def&-123&_+1_xyz_+7"
   (ht:Fmt 123 "abc" 'def '{123} (1 "xyz" 7)) )
### ht:Pack ###
(test "A+B%20C"
   (ht:Pack '("A" "+" "B" "%" "2" "0" "C")) )
(test "A+B C"
   (ht:Pack '("A" "+" "B" "%" "2" "0" "C") T) )
(test "a b>c"
   (ht:Pack '("a" "%" "2" "0" "b" "&" "g" "t" ";" "c") T) )
(test "a€z"
   (ht:Pack '("a" "&" "#" "8" "3" "6" "4" ";" "z")) )
(test "äöü"
   (ht:Pack '("%" "C" "3" "%" "A" "4" "%" "C" "3" "%" "B" "6" "%" "C" "3" "%" "B" "C") T) )
### ht:Read ###
(test NIL
   (pipe (prin "abcde") (ht:Read 0)) )
(test NIL
   (pipe (prin "abcde") (ht:Read 6)) )
(test NIL
   (pipe NIL (ht:Read 3)) )
(test NIL
   (pipe (prin "äö") (ht:Read 3)) )
(test '("ä" "ö")
   (pipe (prin "äö") (ht:Read 4)) )
(test '("a" "b" "c")
   (pipe (prin "abcde") (ht:Read 3)) )
(test '("ä" "ö" "ü")
   (pipe (prin "äöüxyz") (ht:Read 6)) )
### ht:In ht:Out ###
(test "Hello world"
   (pipe (ht:Out T (prinl "Hello world")) (ht:In T (line T))) )

# 14dec20 Software Lab. Alexander Burger
### quote ###
(test (1 2 3) (quote 1 2 3))
### as ###
(test NIL (as (= 3 4) A B C))
(test '(A B C) (as (= 3 3) A B C))
### lit ###
(test 123 (lit 123))
(test NIL (lit NIL))
(test T (lit T))
(test (1) (lit '(1)))
(test ''"abc" (lit "abc"))
(test ''a (lit 'a))
(test (1 2 3) (lit '(1 2 3)))
(test ''(a b c) (lit '(a b c)))
### eval ###
(test 6 (eval (list '+ 1 2 3)))
(let (X 'Y  Y 7)
   (test 7 (eval X)) )
(when 3
   ((quote (N)
         (when 2
            (test 1 N)
            (test 2 (eval '@ 1))
            (test 3 (eval '@ 2)) ) )
      1 ) )
### run ###
(test 6 (run (list (list '+ 1 2 3))))
(test 5
   (when 2
      ((quote (N)
            (and 1 (run '((+ N @)) 1)) )
         3 ) ) )
### def ###
(test '"a"
   (def '"a" '((X Y) (* X (+ X Y)))) )
(test '((X Y) (* X (+ X Y)))
   "a" )
### de ###
(test '"b"
   (de "b" (X Y) (* X (+ X Y))) )
(test '((X Y) (* X (+ X Y)))
   "b" )
### dm ###
(off "+Cls" "+A")
(class "+Cls" "+A")
(test '"foo>"
   (dm "foo>" (X Y)
      (* X (+ X Y)) ) )
(test '"foo>"
   (dm ("foo>" . "+Cls") (X Y)
      (* X (+ X Y)) ) )
(test '(("foo>" (X Y) (* X (+ X Y))) "+A")
   "+Cls" )
### box ###
(let X (box '(A B C))
   (test X (box? X))
   (test '(A B C) (val X)) )
### new type isa method meth send try ###
(let X (new '("+Cls"))
   (test X (box? X))
   (test 21 ("foo>" X 3 4))
   (test '("+Cls") (type X))
   (test X (isa '"+Cls" X))
   (test NIL (isa '(A B C) X))
   (test '((X Y) (* X (+ X Y)))
      (method '"foo>" X) )
   (test meth "foo>")
   (test 21 (send '"foo>" X 3 4))
   (test NIL (try '"bar>" X))
   (test 21 (try '"foo>" X 3 4)) )
### super ###
(off "+Sub")
(class "+Sub" "+Cls")
(dm ("foo>" . "+Sub") (X Y)
   (super X Y) )
(let X (new '("+Sub"))
   (test 21 ("foo>" X 3 4)) )
### super ###
(off "+Pref")
(class "+Pref")
(dm ("foo>" . "+Pref") (X Y)
   (extra X Y) )
(let X (new '("+Pref" "+Sub"))
   (test 21 ("foo>" X 3 4)) )
### with ###
(let X (box)
   (put X 'a 1)
   (put X 'b 2)
   (test (1 2)
      (with X (list (: a) (: b))) ) )
### bind ###
(let X 123
   (test "Hello"
      (bind 'X
         (setq X "Hello")
         X ) )
   (test (3 4 12)
      (bind '((X . 3) (Y . 4))
         (list X Y (* X Y)) ) ) )
### job ###
(off "tst")
(de "tst" ()
   (job '((A . 0) (B . 0))
      (cons (inc 'A) (inc 'B 2)) ) )
(test (1 . 2) ("tst"))
(test (2 . 4) ("tst"))
(test (3 . 6) ("tst"))
### let let? use ###
(let N 1
   (test NIL (let? N NIL N))
   (test 7 (let? N 7 N))
   (use N
      (setq N 2)
      (let N 3
         (test 3 N) )
      (test 2 N) )
   (test 1 N) )
(let N 1
   (use (N)
      (setq N 2)
      (let (N 3)
         (test 3 N) )
      (test 2 N) )
   (test 1 N) )
(test (1 2 (3) 4)
   (let (A 1  (B . C) (2 3)  D 4)
      (list A B C D) ) )
(test (1 (2 3) 4 (7 8 9))
   (let (((A . B) (C) . D) '((1 2 3) (4 5 6) 7 8 9))
      (list A B C D) ) )
(test (1 8)
   (let (((A . NIL) NIL NIL D) '((1 2 3) (4 5 6) 7 8 9))
      (list A D) ) )
### and ###
(test 7 (and T 123 7))
(test NIL (and NIL 123))
### or ###
(test NIL (or NIL))
(test 7 (or NIL 7 123))
### nand ###
(test NIL (nand T 123 7))
(test T (nand NIL 123))
### nor ###
(test T (nor NIL))
(test NIL (nor NIL 7 123))
### xor ###
(test T (xor T NIL))
(test T (xor NIL T))
(test NIL (xor NIL NIL))
(test NIL (xor T T))
### bool ###
(test T (bool 'a))
(test T (bool 123))
(test NIL (bool NIL))
### not ###
(test T (not NIL))
(test NIL (not T))
(test NIL (not 'a))
### nil ###
(test NIL (nil (+ 1 2 3)))
### t ###
(test T (t (+ 1 2 3)))
### prog ###
(let N 7
   (test 3
      (prog (dec 'N) (dec 'N) (dec 'N) (dec 'N) N) ) )
### prog1 prog2 ###
(test 1 (prog1 1 2 3))
(test 2 (prog2 1 2 3))
### if ###
(test 1 (if (= 3 3) 1 2))
(test 2 (if (= 3 4) 1 2))
### if2 ###
(test 'both
   (if2 T T 'both 'first 'second 'none) )
(test 'first
   (if2 T NIL 'both 'first 'second 'none) )
(test 'second
   (if2 NIL T 'both 'first 'second 'none) )
(test 'none
   (if2 NIL NIL 'both 'first 'second 'none) )
(test 4 (if2 3 4 @))
(test 7 (and 7 (if2 @ @ @)))
(test 7 (and 7 (if2 @ NIL 1 @)))
(test 7 (and 7 (if2 NIL @ 1 2 @)))
### ifn ###
(test 2 (ifn (= 3 3) 1 2))
(test 1 (ifn (= 3 4) 1 2))
### when ###
(test 7 (when (= 3 3) 7))
(test NIL (when (= 3 4) 7))
### unless ###
(test NIL (unless (= 3 3) 7))
(test 7 (unless (= 3 4) 7))
### cond ###
(test 1 (cond ((= 3 3) 1) (T 2)))
(test 2 (cond ((= 3 4) 1) (T 2)))
### nond ###
(test 2 (nond ((= 3 3) 1) (NIL 2)))
(test 1 (nond ((= 3 4) 1) (NIL 2)))
(test (1 . a)
   (nond ((num? 'a) (cons 1 'a)) (NIL (cons 2 @))) )
(test (2 . 7)
   (nond ((num? 7) (cons 1 7)) (NIL (cons 2 @))) )
### case ###
(test 1 (case 'a (a 1) ((b c) 2) (T 3)))
(test 2 (case 'b (a 1) ((b c) 2) (T 3)))
(test 2 (case '"b" (a 1) ((b c) 2) (T 3)))
(test 2 (case 'c (a 1) ((b c) 2) (T 3)))
(test 2 (case "c" (a 1) ((b c) 2) (T 3)))
(test 3 (case 'd (a 1) ((b c) 2) (T 3)))
(test 3 (casq 'a ("a" 1) (("b" "c") 2) (T 3)))
(test 3 (casq 'b ("a" 1) (("b" "c") 2) (T 3)))
(test 2 (casq '"b" ("a" 1) (("b" "c") 2) (T 3)))
(test 2 (casq '"c" ("a" 1) (("b" "c") 2) (T 3)))
(test 3 (casq 'b (a 1) ("b" 2) ((a b c) 3) (c 4)))
### state ###
(off "tst")
(de "tst" ()
   (job '((Cnt . 4))
      (state '(start)
         (start 'run
            (link 'start) )
         (run (and (gt0 (dec 'Cnt)) 'run)
            (link 'run) )
         (run 'stop
            (link 'run) )
         (stop 'start
            (setq Cnt 4)
            (link 'stop) ) ) ) )
(test '(start run run run run stop  start run run run run stop)
   (make (do 12 ("tst"))) )
(test '(start run run)
   (make (do 3 ("tst"))) )
### while ###
(test (1 2 3 4 5 6 7)
   (make
      (let N 0
         (while (>= 7 (inc 'N))
            (link N) ) ) ) )
### until ###
(test (1 2 3 4 5 6 7)
   (make
      (let N 0
         (until (> (inc 'N) 7)
            (link N) ) ) ) )
### loop ###
(test (1 2 3 4 5 6 7)
   (make
      (let N 1
         (loop
            (link N)
            (T (> (inc 'N) 7)) ) ) ) )
(test (1 2 3 4 5 6 7)
   (make
      (let N 1
         (loop
            (link N)
            (NIL (>= 7 (inc 'N))) ) ) ) )
(test
   '(a . 3)
   (loop (T NIL (cons @ 1)) (NIL 'a (cons @ 2)) (NIL NIL (cons @ 3))) )
### do ###
(test (1 2 3 4 5 6 7)
   (make
      (let N 0
         (do 7
            (link (inc 'N)) ) ) ) )
(test (1 2 3 4 5 6 7)
   (make
      (let N 1
         (do T
            (link N)
            (T (> (inc 'N) 7)) ) ) ) )
### at ###
(test (1 2 3 - 4 5 6 - 7 8 9 -)
   (make
      (let N 0
         (do 9
            (link (inc 'N))
            (at (0 . 3) (link '-)) ) ) ) )
### for ###
(test (1 2 3 4 5 6 7)
   (make
      (for N (1 2 3 4 5 6 7)
         (link N) ) ) )
(test (1 2 3 4 5 6 7)
   (make
      (for (N . X) '(a b c d e f g)
         (link N) ) ) )
(test (1 2 3 4 5 6 7)
   (make
      (for N 7
         (link N) ) ) )
(test (1 2 3 4 5 6 7)
   (make
      (for (N 1 (>= 7 N) (inc N))
         (link N) ) ) )
(test (1 2 3 4 5 6 7)
   (make
      (for ((N . X) 7 (gt0 X) (dec X))
         (link N) ) ) )
(test (1 2 3 4 5 6 7)
   (make
      (for (N 1 T)
         (link N)
         (T (> (inc 'N) 7)) ) ) )
### catch throw ###
(test NIL (catch NIL (throw)))
(test 'b (catch 'a (throw 'a 'b)))
(test 123 (catch T (throw 'a 123)))
(test "Undefined"
   (catch '("Undefined") (mist)) )
(test "No such file"
   (catch '("No such file")
      (in "doesntExist" (foo)) ) )
(test 6
   (casq
      (catch '("No such file" "Undefined" "expected")
         (+ 1 2 3) )
      ("No such file" (shouldNotComeHere))
      ("Undefined" (shouldNotComeHere))
      ("expected" (shouldNotComeHere))
      (T @) ) )
### finally ###
(test 'B
   (let X 'A
      (catch NIL
         (finally (setq X 'B)
            (setq X 'C)
            (throw)
            (setq X 'D) ) )
      X ) )
### co yield ###
(test (1 2 3 (1 2 3))
   (make
      (do 4
         (link
            (co "co123"
               (make
                  (yield (link 1))
                  (yield (link 2))
                  (yield (link 3)) ) ) ) ) ) )
### exec ###
(test
   (123 abc)
   (pipe (exec 'echo 123 "abc")
      (list (read) (read)) ) )
### call ###
(test T (call "test" "-d" (path "@test")))
(test NIL (call "test" "-f" (path "@test")))
### kill ###
(test T (kill *Pid 0))

# 03apr23 Software Lab. Alexander Burger
### ext:Snx ###
(test "PSLSFSNTSNNLSF"
   (ext:Snx "PicoLisp is not Common Lisp") )
(test "PSLSFSNT"
   (ext:Snx "PicoLisp is not Common Lisp" 8) )
### ext:Base64 ###
(test "TQ=="
   (pipe (ext:Base64 77) (line T)) )
(test "AQID"
   (pipe (ext:Base64 1 2 3) (line T)) )
(test '("A" "Q" "I" "D" "B" "A" "U" "G" "B" "w" "=" "=")
   (make
      (let L (1 2 3 4 5 6 7)
         (output (link @@)
            (while L
               (ext:Base64 (++ L) (++ L) (++ L)) ) ) ) ) )
(test (77)
   (pipe
      (prinl "TQ==")
      (make (while (ext:Base64) (link @))) ) )
(test (1 2 3)
   (pipe
      (prinl "AQID")
      (make (while (ext:Base64) (link @))) ) )
(test (1 2 3 4 5 6 7)
   (let L '("A" "Q" "I" "D" "B" "A" "U" "G" "B" "w" "=" "=")
      (make
         (input (++ L)
            (while (ext:Base64) (link @)) ) ) ) )
(let F (tmp "base64")
   (out F
      (pipe
         (prin "Polyfon zwitschernd aßen Mäxchens Vögel Rüben, Joghurt und Quark")
         (while (ext:Base64 (rd 1) (rd 1) (rd 1))) ) )
   (test "UG9seWZvbiB6d2l0c2NoZXJuZCBhw59lbiBNw6R4Y2hlbnMgVsO2Z2VsIFLDvGJlbiwgSm9naHVydCB1bmQgUXVhcms="
      (in F (line T)) )
   (test "Polyfon zwitschernd aßen Mäxchens Vögel Rüben, Joghurt und Quark"
      (pipe
         (in F (while (ext:Base64) (wr @)))
         (line T) ) ) )

# 21aug22 Software Lab. Alexander Burger
(test T (pool (tmp "db") (2 3)))
### extern ###
(test NIL (extern (box)))
(test *DB (extern "1"))
### ext? ###
(test *DB (ext? *DB))
(test NIL (ext? 'abc))
(test NIL (ext? "abc"))
(test NIL (ext? 123))
### touch ###
(test *DB (touch *DB))
(rollback)
### id ###
(test *DB (id 1))
(test 1 (id *DB))
(let I (id 3 4)
   (test (3 . 4) (id I T)) )
### wipe ###
(set *DB (1 2 3 4))
(put *DB 'a 1)
(put *DB 'b 2)
(test (1 2 3 4) (val *DB))
(test '((2 . b) (1 . a)) (getl *DB))
(wipe *DB)
(test (1 2 3 4) (val *DB))
(test '((2 . b) (1 . a)) (getl *DB))
(rollback)
### lieu ###
(test NIL (lieu *DB))
(test *DB (val *DB) (lieu *DB))
(rollback)
### commit rollback ###
(let (X (new 1)  Y (new 2))
   (set X 1  Y 2)
   (commit)
   (test 1 (val X))
   (test 2 (val Y))
   (set X 111)
   (set Y 222)
   (test 111 (val X))
   (test 222 (val Y))
   (rollback)
   (test 1 (val X))
   (test 2 (val Y)) )
### mark ###
(test NIL (mark *DB))
(test NIL (mark *DB T))
(test T (mark *DB))
(test T (mark *DB 0))
(test NIL (mark *DB))
### dbck ###
(test NIL (dbck))
(rollback)

# 06oct20 Software Lab. Alexander Burger
### format ###
(scl 0)
(test "123456789" (format 123456789))
(test "12346" (format 12345.6789))
(test "1234567.89" (format 123456789 2))
(test "1234567,89" (format 123456789 2 ","))
(test "1.234.567,89" (format 123456789 2 "," "."))
(test 123456789 (format "123456789"))
(test 12345678900 (format "1234567.89" 4))
(test NIL (format "1.234.567,89"))
(test 12345678900 (format "1234567,89" 4 ","))
(test NIL (format "1.234.567,89" 4 ","))
(test 12345678900 (format "1.234.567,89" 4 "," "."))
(test 123456 (format (1 "23" (4 5 6))))
### + ###
(test 6 (+ 1 2 3))
(test 0 (+ 1 2 -3))
(test NIL (+ NIL 7))
### - ###
(test -7 (- 7))
(test 7 (- -7))
(test 6 (- 7 2 -1))
(test NIL (- NIL 7))
### inc ###
(test 8 (inc 7))
(test -6 (inc -7))
(test 0 (inc -1))
(test 1 (inc 0))
(test (8 -6 0 1) (let L (7 -7 -1 0) (map inc L) L))
(test NIL (inc NIL))
(let N 0
   (test 1 (inc 'N))
   (test 1 N)
   (test 8 (inc 'N 7))
   (test 8 N) )
(let L (1 2 3 4)
   (test 3 (inc (cdr L)))
   (test (1 3 3 4) L) )
### dec ###
(test 7 (dec 8))
(test -8 (dec -7))
(test -1 (dec 0))
(test (7 -8 -1) (let L (8 -7 0) (map dec L) L))
(test NIL (dec NIL))
(let N 7
   (test 6 (dec 'N))
   (test 6 N)
   (test 3 (dec 'N 3))
   (test 3 N) )
### * ###
(test 6 (* 1 2 3))
(test -60 (* -5 3 2 2))
(test NIL (* NIL 7))
### */ ###
(test 6 (*/ 3 4 2))
(test -247 (*/ 1234 -2 10))
(test 17 (*/ 100 6))
(test NIL (*/ 3 4 NIL))
### / ###
(test 4 (/ 12 3))
(test -5 (/ 60 -3 2 2))
(test NIL (/ 10 NIL))
### % ###
(test 2 (% 17 5))
(test -2 (% -17 5))
(test 1 (% 5 2))
(test 5 (% 15 10))
(test 1 (% 15 10 2))
(test NIL (% NIL 7))
### >> ###
(test 4 (>> 1 8))
(test 2 (>> 3 16))
(test 128 (>> -3 16))
(test -32 (>> -1 -16))
(test 0 (>> 1 -1))
### lt0 ###
(test -2 (lt0 -2))
(test NIL (lt0 7))
(test NIL (lt0 0))
### le0 ###
(test -7 (le0 -7))
(test NIL (le0 2))
(test 0 (le0 0))
### ge0 ###
(test 7 (ge0 7))
(test NIL (ge0 -2))
(test 0 (ge0 0))
### gt0 ###
(test 7 (gt0 7))
(test NIL (gt0 -2))
(test NIL (gt0 0))
### abs ###
(test 7 (abs -7))
(test 7 (abs 7))
(test NIL (abs NIL))
### bit? ###
(test 7 (bit? 7 15 255))
(test NIL (bit? 1 2))
(test 1 (bit? 1 3))
(test 1 (bit? 1 -3))
(test 1 (bit? -1 3))
(test 1 (bit? -1 -3))
(test (hex "100000000000000000000")
   (bit? (hex "100000000000000000000") (hex "300000000000000000000")) )
### & ###
(test 2 (& 6 3))
(test 1 (& 7 3 1))
(test NIL (& 7 NIL))
(test 1 (& 1 3))
(test 1 (& 1 -3))
(test 1 (& -1 3))
(test 1 (& -1 -3))
(test (hex "100000000000000000000")
   (& (hex "100000000000000000000") (hex "300000000000000000000")) )
### | ###
(test 15 (| 1 2 4 8))
(test NIL (| NIL 1))
(test 3 (| 1 2))
(test 3 (| 1 -2))
(test 3 (| -1 2))
(test 3 (| -1 -2))
(test (hex "300000000000000000000")
   (| (hex "100000000000000000000") (hex "200000000000000000000")) )
### x| ###
(test 5 (x| 2 7))
(test 4 (x| 2 7 1))
(test NIL (x| NIL 1))
(test 3 (x| 1 2))
(test 3 (x| 1 -2))
(test 3 (x| -1 2))
(test 3 (x| -1 -2))
(test (hex "300000000000000000000")
   (x| (hex "100000000000000000000") (hex "200000000000000000000")) )
### sqrt ###
(test 8 (sqrt 64))
(test 4 (sqrt 21))
(test 5 (sqrt 21 T))
(test 31 (sqrt 1000))
(test 32 (sqrt 1000 T))
(test 458 (sqrt 2100 100))
(test 479 (sqrt 230000))
(test 480 (sqrt 2300 100))
(test 800 (sqrt 6400 100))
(test 100000000000000000000
   (sqrt 10000000000000000000000000000000000000000) )
(test NIL (sqrt NIL))
### seed rand hash ###
(test -417605464 (seed "init string"))
(test -1061886707 (rand))
(test 822065436 (rand))
(test 5 (rand 3 9))
(test 3 (rand 3 9))
(test 1 (hash 0))
(test 55682 (hash 1))
(test 35970 (hash 7))
(test 29691 (hash 1234567))

# 01may22 Software Lab. Alexander Burger
### apply ###
(test 6 (apply + (1 2 3)))
(test 360 (apply * (5 6) 3 4))
(test 27 (apply '((X Y Z) (* X (+ Y Z))) (3 4 5)))
(test (5 7 9) (apply mapcar '((1 2 3) (4 5 6)) +))
### pass ###
(test 24 ((quote (N . @) (* N (pass + 6))) 2 1 2 3))
### fun ###
(test '(NIL NIL NIL)
   (mapcar fun
      '(gt0 ((N) (bit? 1 N)) ((N) (> N 4)))
      -2 ) )
(test (2 NIL NIL)
   (mapcar fun
      '(gt0 ((N) (bit? 1 N)) ((N) (> N 4)))
      2 ) )
(test (3 1 NIL)
   (mapcar fun
      '(gt0 ((N) (bit? 1 N)) ((N) (> N 4)))
      3 ) )
(test (7 1 T)
   (mapcar fun
      '(gt0 ((N) (bit? 1 N)) ((N) (> N 4)))
      7 ) )
### maps ###
(let L '((1 . a) (2 . b) flg)
   (test L (let X (box) (putl X (reverse L)) (make (maps link X)))) )
### map ###
(test '((1 2 3) (2 3) (3)) (make (map link (1 2 3))))
### mapc ###
(test (1 2 3) (make (mapc link (1 2 3))))
### maplist ###
(test '(((1 2 3) A B C) ((2 3) B C) ((3) C)) (maplist cons (1 2 3) '(A B C)))
### mapcar ###
(test (5 7 9) (mapcar + (1 2 3) (4 5 6)))
(test (26 38 52 68) (mapcar '((X Y) (+ X (* Y Y))) (1 2 3 4) (5 6 7 8)))
### mapcon ###
(test (1 2 3 4 5 2 3 4 5 3 4 5 4 5 5) (mapcon copy (1 2 3 4 5)))
### mapcan ###
(test '(c b a f e d i h g) (mapcan reverse '((a b c) (d e f) (g h i))))
### filter ###
(test (1 2 3) (filter num? (1 A 2 (B) 3 CDE)))
### extract ###
(let (A NIL  B 1  C NIL  D 2  E NIL  F 3)
   (test (1 2 3)
      (extract val '(A B C D E F)) )
   (test (1 2 3)
      (extract val '(B D E F)) ) )
### seek ###
(test (12 19 22) (seek '((X) (> (car X) 9)) (1 5 8 12 19 22)))
(let (A -1  B 2  C 3)
   (test '(B C) (seek '((L) (gt0 (val (car L)))) '(A B C)))
   (test 2 @@) )
### find ###
(test '(B) (find pair (1 A 2 (B) 3 CDE)))
(test 4 (find > (1 2 3 4 5 6) (6 5 4 3 2 1)))
(test 4 (find '((A B) (> A B)) (1 2 3 4 5 6) (6 5 4 3 2 1)))
(let (A -1  B 2  C 3)
   (test 'B (find '((X) (gt0 (val X))) '(A B C)))
   (test 2 @@) )
### pick ###
(test "Hello"
   (pick '((X) (get X 'str))
      (list (box) (prog1 (box) (put @ 'str "Hello")) (box)) ) )
### fully ###
(test T (fully gt0 (1 2 3)))
(test NIL (fully gt0 (1 -2 3)))
### cnt ###
(test 2 (cnt cdr '((1 . T) (2) (3 4) (5))))
### sum ###
(test 6 (sum val (list (box 1) (box) (box 2) (box 'a) (box 3))))
### maxi mini ###
(let (A 1 B 2 C 3)
   (test 'C (maxi val '(A B C)))
   (test 3 @@)
   (test 'A (mini val '(A B C)))
   (test 1 @@)
   (test '(A B C) (by val sort '(C A B))) )
### fish ###
(test (1 2 3)
   (fish gt0 '(a -2 (1 b (-3 c 2)) 3 d -1)) )
(test (-2 1 -3 -1)
   (fish < '(a -2 (1 b (-3 c 2)) 3 d -1) NIL 2) )
(test '(a b c d)
   (fish sym? '(a -2 (1 b (-3 c 2)) 3 d -1)) )
(test (3 7)
   (fish
      '((X)
         (if (and (pair X) (=1 (car X)))
            "skip"
            (gt0 X) ) )
      '(a -2 (1 b (-3 c 2)) 3 d -1 7)
      "skip" ) )
(test '(b b)
   (fish == '(a 1 (b (3 b)) 3) NIL 'b) )
### by ###
(test '(A B C)
   (let (A 1 B 2 C 3)
      (by val sort '(C A B)) ) )
(test '((3 11 9 5 7 1) (6 2 4 10 12 8))
   (by '((N) (bit? 1 N))
      group
      (3 11 6 2 9 5 4 10 12 7 8 1) ) )
(test '(("x" "x" "x") ("y") ("z" "z"))
   (by name group '("x" "x" "y" "z" "x" "z")) )
(test '((123 "xyz") ((1 2) "XY") ("abcd" (1 2 3 4)))
   (by length group '(123 (1 2) "abcd" "xyz" (1 2 3 4) "XY")) )

# 01jun21 Software Lab. Alexander Burger
### task ###
(test (3 . 4)
   (let (*Run NIL  *A NIL  *B NIL)
      (task -10 0 (setq *A 3))
      (task (port T 0 "TaskPort") (eval (udp @)))
      (udp "localhost" "TaskPort" '(setq *B 4))
      (wait NIL (and *A *B))
      (cons *A *B) ) )
### timeout ###
(test '((-1 3600000 (bye)))
   (let *Run NIL
      (timeout 3600000)
      *Run ) )
### abort ###
(test 6 (abort 2 (+ 1 2 3)))
(test NIL (abort 2 (wait 4000)))
### macro ###
(test 6
   (let (@A 1  @B 2  @C 3)
      (macro (* @A @B @C)) ) )
### later ###
(test '((@ . 1) (@ . 4) (@ . 9) (@ . 16) (@ . 25) (@ . 36))
   (prog1
      (mapcan
         '((N) (later (cons) (cons *Pid (* N N))))
         (1 2 3 4 5 6) )
      (wait NIL (full @)) ) )
### recur recurse ###
(test 720
   (let N 6
      (recur (N)
         (if (=0 N)
            1
            (* N (recurse (dec N))) ) ) ) )
### curry ###
(test '((N) (* 7 N))
   ((quote (@X) (curry (@X) (N) (* @X N))) 7) )
(test 21
   (((quote (@X) (curry (@X) (N) (* @X N))) 7) 3) )
(test '((N) (job '((A . 1)) (+ A 7 N)))
   (let (A 1 @X 7) (curry (A @X) (N) (+ A @X N))) )
### cache ###
(let C NIL
   (test 0 (cache 'C 1234 0))
   (test 7 (cache 'C 4321 7))
   (test 7 (cache 'C 4321 8))
   (inc (cache 'C 4321))
   (test 8 (val (cache 'C 4321))) )
### expr subr undef ###
(let foo car
   (test 7 (foo (7)))
   (test T (== 'pass (caadr (expr 'foo))))
   (test car (subr 'foo))
   (test car (undef 'foo))
   (test NIL (val 'foo)) )
### redef ###
(let foo inc
   (redef foo (N) (inc (foo N)))
   (test 3 (foo 1)) )
### daemon patch ###
(let foo car
   (daemon 'foo (msg 'daemon))
   (test T (= '(msg 'daemon) (cadr (getd 'foo))))
   (patch foo 'daemon 'patch)
   (test T (= '(msg 'patch) (cadr (getd 'foo)))) )
### scl ###
(scl 0)
(test 123 (any "123.45"))
(scl 1)
(test (1235) (scl 1 (str "123.45")))
(test 1235 (any "123.45"))
(scl 3)
(test 123450 (any "123.45"))
### ** ###
(test 32768 (** 2 15))
(test 1 (** 123 0))
(test 0 (** 3 -1))
### accu ###
(off Sum)
(test '(a . 1) (accu 'Sum 'a 1))
(test 6 (accu 'Sum 'a 5))
(test (22 . 100) (accu 'Sum 22 100))
(test '((22 . 100) (a . 6)) Sum)
(test '((b . 2) (a . 3))
   (let L NIL (accu 'L 'a 2) (accu 'L 'b 2) (accu 'L 'a 1) L) )
### script ###
(out (tmp "script")
   (println '(pass * 7)) )
(test 42 (script (tmp "script") 2 3))
### once ###
(let N 0
   (test 1
      (once (inc 'N))
      (once (inc 'N))
      N ) )
### rc ###
(let F (tmp "rc")
   (rc F 'a 123)
   (rc F 'b "test"  'c (1 2 3))
   (test '((c 1 2 3) (b . "test") (a . 123))
      (in F (read)) )
   (test 123 (rc F 'a))
   (test "test" (rc F 'b))
   (test (1 2 3) (rc F 'c)) )
### acquire release ###
(let F (tmp "sema")
   (test *Pid (acquire F))
   (test T (acquire F))
   (test *Pid (in F (rd)))
   (test NIL (release F))
   (test NIL (in F (rd))) )
### uniq ###
(test (2 4 6 1 3 5) (uniq (2 4 6 1 2 3 4 5 6 1 3 5)))
### qsym ###
(let "A" 1234
   (put '"A" 'a 1)
   (put '"A" 'b 2)
   (put '"A" 'f T)
   (test (1234 f (2 . b) (1 . a))
      (qsym . "A") ) )
### loc ###
(let (X 'foo  bar '((A B) (foo B A)))
   (test "foo" (zap 'foo))
   (test "foo" (str? "foo"))
   (test T (== X (loc "foo" bar))) )
### class ###
(off "+A" "+B" "+C")
(test '"+A" (class "+A" "+B" "+C"))
(test '"+A" *Class)
(test '("+B" "+C") "+A")
### object ###
(off "Obj")
(test '"Obj"
   (object '"Obj" '("+A" "+B" "+C")  'a 1 'b 2 'c 3) )
(test '((3 . c) (2 . b) (1 . a) (@X . *Dbg))
   (getl '"Obj") )
### extend var var: ###
(test '"+B" (extend "+B"))
(test T (== *Class '"+B"))
(test 1 (var a . 1))
(test 2 (var (b . "+B") . 2))
(test '((2 . b) (1 . a)) (cdr (getl '"+B")))
(with '"Obj"
   (test 1 (var: a))
   (test 2 (var: b)) )

# 26may22 Software Lab. Alexander Burger
### locale ###
(locale "DE" "de")
(test "Ja" (val ,"Yes"))
(locale)
### align ###
(test "   a" (align 4 'a))
(test "   a" (align 4 "a"))
(test "12  " (align -4 12))
(test "   a  12   b" (align (4 4 4) "a" 12 "b"))
### center ###
(test " 12" (center 4 12))
(test " a" (center 4 "a"))
(test "   a" (center 7 'a))
(test " a  b  c" (center (3 3 3) "a" "b" "c"))
### wrap ###
(test "The quick brown fox\njumps over the lazy\ndog"
   (wrap 20 (chop "The quick brown fox jumps over the lazy dog")) )
(test "The\nquick\nbrown\nfox\njumps\nover the\nlazy dog"
   (wrap 8 (chop "The quick brown fox jumps over the lazy dog")) )
(test "The\nquick\nbrown\nfox\njumps\nover\nthe\nlazy\ndog"
   (wrap 2 (chop "The quick brown fox jumps over the lazy dog")) )
(test '("The" "quick" "brown" "fox" "jumps" "over the" "lazy dog")
   (wrap 8 "The quick brown fox jumps over the lazy dog") )
### pad ###
(test "00001" (pad 5 1))
(test "123456789" (pad 5 123456789))
### bin ###
(test "1001001" (bin (+ 64 8 1)))
(test (+ 64 8 1) (bin "1001001"))
(test "-110110" (bin -54))
(test -54 (bin "-110110"))
### oct ###
(test "111" (oct (+ 64 8 1)))
(test (+ 64 8 1) (oct "111"))
(test "-66" (oct -54))
(test -54 (oct "-66"))
### hex ###
(test "111" (hex (+ 256 16 1)))
(test (+ 256 16 1) (hex "111"))
(test "-FFFF" (hex -65535))
### money ###
(test "1,234,567.89" (money 123456789))
(test "1,234,567.89 EUR" (money 123456789 "EUR"))
(locale "DE" "de")
(test "1.234.567,89 EUR" (money 123456789 "EUR"))
(locale)
### round ###
(scl 4)
(test "12.35" (round 123456 2))
(test "12.3456" (round 123456 6))
(test "12.346" (round 123456))
### balance ###
(test (5 (2 (1) 3 NIL 4) 7 (6) 8 NIL 9)
   (let I NIL (balance 'I (sort (1 4 2 5 3 6 7 9 8))) I) )
### *Allow allowed allow ###
(allowed ("app/")
   "start" "stop" "lib.css" "psh" )
(allow "myFoo")
(allow "myDir/" T)
(test '(("psh" ("lib.css" NIL "myFoo") "start" NIL "stop") "app/" "myDir/")
   *Allow )
(test '("lib.css" "myFoo" "psh" "start" "stop")
   (idx *Allow) )
(test '("app/" "myDir/")
   (cdr *Allow) )
### telStr ###
(test "+49 1234 5678-0" (telStr "49 1234 5678-0"))
(locale "DE" "de")
(test "01234 5678-0" (telStr "49 1234 5678-0"))
(locale)
### expTel ###
(test "49 1234 5678-0" (expTel "+49 1234 5678-0"))
(test "49 1234 5678-0" (expTel "0049 1234 5678-0"))
(test NIL (expTel "01234 5678-0"))
(locale "DE" "de")
(test "49 1234 5678-0" (expTel "01234 5678-0"))
(locale)
### dat$ ###
(test "20070601" (dat$ (date 2007 6 1)))
(test "2007-06-01" (dat$ (date 2007 6 1) "-"))
### $dat ###
(test 733134 ($dat "20070601"))
(test 733134 ($dat "2007-06-01" "-"))
### datSym ###
(test "01jun07" (datSym (date 2007 6 1)))
### datStr ###
(test "2007-06-01" (datStr (date 2007 6 1)))
(locale "DE" "de")
(test "01.06.2007" (datStr (date 2007 6 1)))
(test "01.06.07" (datStr (date 2007 6 1) T))
(locale)
### strDat ###
(test 733134 (strDat "2007-06-01"))
(test NIL (strDat "01.06.2007"))
(locale "DE" "de")
(test 733134 (strDat "01.06.2007"))
(test 733134 (strDat "1.6.2007"))
(locale)
### expDat ###
(test 733133 (date 2007 5 31))
(test 733133 (expDat "31057"))
(test 733133 (expDat "310507"))
(test 733133 (expDat "2007-05-31"))
(test 733133 (expDat "7-5-31"))
(let D (date)
   (test D (expDat "."))
   (test (inc D) (expDat "+1"))
   (test (dec D) (expDat "-1")) )
(locale "DE" "de")
(test 733133 (expDat "31.5.7"))
(locale)
### day ###
(test "Friday" (day (date 2007 6 1)))
(locale "DE" "de")
(test "Freitag" (day (date 2007 6 1)))
(test "Fr"
   (day (date 2007 6 1) '("Mo" "Tu" "We" "Th" "Fr" "Sa" "Su")) )
(locale)
### week ###
(test 22 (week (date 2007 6 1)))
### ultimo ###
(test (2007 1 31) (date (ultimo 2007 1)))
(test (2007 2 28) (date (ultimo 2007 2)))
(test (2004 2 29) (date (ultimo 2004 2)))
(test (2000 2 29) (date (ultimo 2000 2)))
(test (1900 2 28) (date (ultimo 1900 2)))
### tim$ ###
(test "10:57" (tim$ (time 10 57 56)))
(test "10:57:56" (tim$ (time 10 57 56) T))
### $tim ###
(test (10 57 56) (time ($tim "10:57:56")))
(test (10 57 0) (time ($tim "10:57")))
(test (10 0 0) (time ($tim "10")))
### stamp ###
(test "2007-06-01 10:57:56"
   (stamp (date 2007 6 1) (time 10 57 56)) )
### chdir ###
(let P (pwd)
   (chdir "/"
      (test "/" (pwd)) )
   (test P *PWD) )
### dirname basename ###
(test "a/b/c/" (dirname "a/b/c/d"))
(test "a/b/c/" (dirname "a/b/c/d/"))
(test "d" (basename "a/b/c/d"))
(test "d" (basename "a/b/c/d/"))

# 06oct20 Software Lab. Alexander Burger
(scl 6)
(load "@lib/math.l")
### pow ###
(test 8.0 (pow 2.0 3.0))
(test 8.0 (pow 64.0 0.5))
### exp ###
(test 2.718282 (exp 1.0))
### log ###
(test 0.693147 (log 2.0))
### sin ###
(test 0.0 (sin 0.0))
(test 1.0 (sin (/ pi 2)))
### cos ###
(test 1.0 (cos 0.0))
(test -1.0 (cos pi))
### tan ###
(test 0.0 (tan 0.0))
(test 0.0 (tan pi))
### asin ###
(test 0.0 (asin 0.0))
(test (/ pi 2) (asin 1.0))
### acos ###
(test 0.0 (acos 1.0))
(test pi (acos -1.0))
### atan ###
(test 0.0 (atan 0.0))
### atan2 ###
(test 0.0 (atan2 0.0 1.0))
(test (/ pi 2) (atan2 1.0 0.0))

# 06oct20 Software Lab. Alexander Burger
### noLint ###
(let foo '(() (bar FreeVariable))
   (use *NoLint
      (noLint 'bar)
      (noLint 'foo 'FreeVariable)
      (test NIL (lint 'foo)) ) )
### lint ###
(let foo '((R S T R) (let N 7 (bar X Y)))
    (test '((var T) (dup R) (def bar) (bnd Y X) (use N))
       (lint 'foo) ) )
(let foo '(() (task -6000 0 X 7 (println N)))
   (test '((bnd N) (use X))
       (lint 'foo) ) )

# 21aug22 Software Lab. Alexander Burger
### +Joint ###
(test T (pool (tmp "db")))
(class +A +Entity)
(rel k (+Key +String))
(rel b (+List +Bag)
   ((+Joint) a (+B))
   ((+Number)) )
(class +B +Entity)
(rel k (+Key +String))
(rel a (+Joint) b (+A) list asoq)
(let
   (A (new T '(+A) 'k "a")
      B (new T '(+B) 'k "b")
      C (new T '(+B) 'k "c") )
   (test T (bool (has> A 'k "a")))
   (test T (bool (has> B 'k "b")))
   (test A (db 'k '+A "a"))
   (test B (db 'k '+B "b"))
   (test C (db 'k '+B "c"))
   (put> B 'a A)
   (test (list (list B)) (; A b))
   (test A (; B a))
   (test T (bool (has> A 'b B)))
   (test T (bool (has> A 'b (list B))))
   (test T (bool (has> A 'b (list (list B)))))
   (test T (bool (has> B 'a A)))
   (put> B 'a NIL)
   (test NIL (; A b))
   (test NIL (; B a))
   (put> A 'b (list (list B 123)))
   (test (list (list B 123)) (; A b))
   (test A (; B a))
   (put> A 'b (list (list C 7)))
   (test (list (list C 7)) (; A b))
   (test NIL (; B a))
   (test A (; C a))
   (put> A 'b NIL)
   (test NIL (; A b))
   (test NIL (; B a)) )
(rollback)
### +Swap ###
(class +C +Entity)
(rel s (+Swap +String))
(rel l (+Swap +List +String))
(rel b (+List +Bag)
   ((+Number))
   ((+Swap +String)) )
(rel c (+Swap +List +Bag)
   ((+Number))
   ((+String)) )
(let A
   (new T '(+C)
      's "a"
      'l '("b" "c")
      'b '((123 "def"))
      'c '((123 "def")) )
   (test T (bool (has> A 's "a")))
   (test NIL (has> A 's "x"))
   (test T (bool (has> A 'l '("b" "c"))))
   (test NIL (has> A 'l '("b")))
   (test NIL (has> A 'l '("c")))
   (test NIL (has> A 'l '("x")))
   (test T (bool (has> A 'b '((123 "def")))))
   (test NIL (has> A 'b '((123))))
   (test NIL (has> A 'b '(("def"))))
   (test T (bool (has> A 'c '((123 "def")))))
   (test NIL (has> A 'c '((123))))
   (test NIL (has> A 'c '(("def"))))
   (let S (; A l)
      (put> A 'l '("x"))
      (test S (; A l))
      (test '("x") (; A l 0)) )
   (let S (; A b 1 2)
      (put> A 'b (list (list 4 S)))
      (test S (; A b 1 2))
      (test "def" (; A b 1 2 0))
      (test 4 (; A b 1 1))
      (put> A 'b '((7 "y")))
      (test S (; A b 1 2))
      (test 7 (; A b 1 1))
      (test "y" (; A b 1 2 0)) ) )
(rollback)

# 03feb24 Software Lab. Alexander Burger
(symbols '(llvm))
(local) *Version
(pico~de *Version 24 2 3)

// 24apr22 Software Lab. Alexander Burger
#include <stdio.h>
#include <stdint.h>
#include <stdlib.h>
#include <unistd.h>
#include <limits.h>
#include <errno.h>
#include <fcntl.h>
#include <dirent.h>
#include <signal.h>
#include <dlfcn.h>
#include <time.h>
#include <poll.h>
#include <termios.h>
#include <sys/ioctl.h>
#include <sys/types.h>
#include <sys/wait.h>
#include <sys/stat.h>
#include <sys/time.h>
#include <sys/times.h>
#include <sys/resource.h>
#include <netdb.h>
#include <sys/socket.h>
#include <netinet/in.h>
static void ttl(char *nm) {
   printf("\n[%s]\n", nm);
}
static void num(char *sym, long val) {
   printf("%s\t%ld\n", sym, val);
}
static void str(char *sym, char *val) {
   printf("%s\t\"%s\"\n", sym, val);
}
int main(void) {
   struct winsize term;
   struct sockaddr_in6 addr;
   struct addrinfo ai;
   printf("# %s\n", __VERSION__);
   printf("# %s\n", _OS);
   printf("# %s\n", _CPU);
   ttl("errno");
   num("EINTR", EINTR);
   num("EAGAIN", EAGAIN);
   num("EACCES", EACCES);
   ttl("stdio");
   num("BUFSIZ", BUFSIZ);
   ttl("unistd");
   num("PIPE_BUF", PIPE_BUF);
   num("PATH_MAX", PATH_MAX);
   ttl("terminal");
   num("TIOCGWINSZ", TIOCGWINSZ);
   num("TIOCSWINSZ", TIOCSWINSZ);
   num("winsize", sizeof(struct winsize));
   num("ws_row", (char*)&term.ws_row - (char*)&term);
   num("ws_col", (char*)&term.ws_col - (char*)&term);
   ttl("networking");
   num("SOCK_STREAM", SOCK_STREAM);
   num("SOCK_DGRAM", SOCK_DGRAM);
   num("AF_INET6", AF_INET6);
   num("SOL_SOCKET", SOL_SOCKET);
   num("SO_REUSEADDR", SO_REUSEADDR);
   num("IPPROTO_IPV6", IPPROTO_IPV6);
   num("IPV6_V6ONLY", IPV6_V6ONLY);
   num("INET6_ADDRSTRLEN", INET6_ADDRSTRLEN);
   num("sockaddr_in6", sizeof(struct sockaddr_in6));
   num("sin6_family",  (char*)&addr.sin6_family - (char*)&addr);
   num("sin6_addr", (char*)&addr.sin6_addr - (char*)&addr);
   num("sin6_port", (char*)&addr.sin6_port - (char*)&addr);
   num("NI_MAXHOST", NI_MAXHOST);
   num("NI_NAMEREQD", NI_NAMEREQD);
   num("addrinfo", sizeof(struct addrinfo));
   num("ai_family", (char*)&ai.ai_family - (char*)&ai);
   num("ai_socktype", (char*)&ai.ai_socktype - (char*)&ai);
   num("socklen_t", sizeof(socklen_t));
   num("ai_addrlen", (char*)&ai.ai_addrlen - (char*)&ai);
   num("ai_addr", (char*)&ai.ai_addr - (char*)&ai);
   num("ai_next", (char*)&ai.ai_next - (char*)&ai);
   num("AF_UNSPEC", AF_UNSPEC);
   return 0;
}

# 08aug23 Software Lab. Alexander Burger
(symbols '(llvm))
(local) (bufSize pathSize bufString pathString)
(de i64 bufSize (Nm)
   (let N 1
      (while (big? Nm)
         (inc 'N 8)
         (setq Nm (val (big Nm))) )
      (setq Nm (int Nm))
      (while Nm
         (inc 'N)
         (setq Nm (shr Nm 8)) )
      N ) )
(de i64 pathSize (Nm)
   (let
      (Len (bufSize Nm)
         N (if (cnt? Nm) (int @) (val (dig @)))
         B (i8 N) )
      (cond
         ((or
               (== B (char "@"))
               (and
                  (== B (char "+"))
                  (== (i8 (shr N 8)) (char "@")) ) )
            (+ (val $PilLen) (dec Len)) )
         ((or
               (== B (char "~"))
               (and
                  (== B (char "+"))
                  (== (i8 (shr N 8)) (char "~")) ) )
            (+ (val $UsrLen) (dec Len)) )
         (T Len) ) ) )
(de i8* bufString (Nm (i8* . P))
   (let Q (push 0 Nm)  # [cnt name]
      (prog1 P
         (while (set P (symByte Q))
            (inc 'P) ) ) ) )
(de i8* pathString (Nm (i8* . P))
   (let (Q (push 0 Nm)  B (symByte Q))  # [cnt name]
      (prog1 P
         (when (== B (char "+"))
            (set P B)
            (inc 'P)
            (setq B (symByte Q)) )
         (case B
            ((char "@")
               (when (val $PilLen)
                  (memcpy P (val $PilHome) @)
                  (inc 'P @) ) )
            ((char "~")
               (when (val $UsrLen)
                  (memcpy P (val $UsrHome) @)
                  (inc 'P @) ) )
            (T
               (set P B)
               (inc 'P) ) )
         (while (set P (symByte Q))
            (inc 'P) ) ) ) )
(local) (mkChar mkStr firstByte firstChar isBlank)
(de mkChar ((i32 . C))
   (consStr
      (cnt
         (cond
            ((>= 127 C) (i64 C))  # Single byte
            ((== TOP C) (hex "FF"))  # Infinite
            ((> (hex "800") C)  # Double-byte
               (i64
                  (|
                     (| (hex "C0") (& (shr C 6) (hex "1F")))  # 10xxxxx 10xxxxxx
                     (shl (| (hex "80") (& C (hex "3F"))) 8) ) ) )
            ((> (hex "10000") C)  # Three bytes
               (i64
                  (|
                     (|
                        (| (hex "E0") (& (shr C 12) (hex "0F")))  # 1110xxxx 10xxxxxx 10xxxxxx
                        (shl (| (hex "80") (& (shr C 6) (hex "3F"))) 8) )
                     (shl (| (hex "80") (& C (hex "3F"))) 16) ) ) )
            (T
               (|
                  (i64
                     (|
                        (|
                           (| (hex "F0") (& (shr C 18) (hex "07")))  # 11110xxx 10xxxxxx 10xxxxxx 10xxxxxx
                           (shl (| (hex "80") (& (shr C 12) (hex "3F"))) 8) )
                        (shl (| (hex "80") (& (shr C 6) (hex "3F"))) 16) ) )
                  (shl
                     (| (hex "80") (& (i64 C) (hex "3F")))
                     24 ) ) ) ) ) ) )
(de mkStr ((i8* . Str))
   (if Str
      (let P (push 4 NIL ZERO NIL)  # [cnt last name link]
         (link (ofs P 2) T)
         (while (val Str)
            (byteSym @ P)
            (inc 'Str) )
         (consStr (val 3 P)) )
      $Nil ) )
(de mkStrE ((i8* . Str) (i8* . End))
   (let P (push 4 NIL ZERO NIL)  # [cnt last name link]
      (link (ofs P 2) T)
      (loop
         (? (== Str End))
         (? (=0 (val Str)))
         (byteSym @ P)
         (inc 'Str) )
      (consStr (val 3 P)) ) )
(de i8 firstByte (Sym)
   (i8
      (cond
         ((nil? Sym) 0)
         ((sym? (val (tail Sym))) 0)
         ((cnt? (name @)) (int @))
         (T (val (dig @))) ) ) )
(de i32 firstChar (Sym)
   (cond
      ((nil? Sym) 0)
      ((sym? (val (tail Sym))) 0)  # External symbol
      (T (symChar (push 0 (name @)))) ) )  # Else get name
(de i1 isBlank (X)
   (or
      (nil? X)
      (and
         (symb? X)
         (not (sym? (val (tail X))))
         (let P (push 0 (name @))  # [cnt name]
            (loop
               (? (=0 (symByte P)) YES)
               (? (> @ 32) NO) ) ) ) ) )
# Build external symbol name
(local) extNm
(de extNm ((i32 . File) (i64 . Obj))
   (cnt
      (|
         (& Obj (hex "FFFFF"))  # Lowest 20 bits
         (|
            (shl (i64 (& File (hex "FF"))) 20)  # Lower 8 bits
            (|
               (shl
                  (& (setq Obj (shr Obj 20)) (hex "FFF"))  # Middle 12 bits
                  28 )
               (|
                  (shl (i64 (shr File 8)) 40)  # Upper 8 bits
                  (shl (shr Obj 12) 48) ) ) ) ) ) )  # Highest 10 bits
(local) (objFile objId packAO packOct packExtNm pack chopExtNm)
# Get file number from external symbol name
(de i32 objFile (Name)
   (|
      (& (i32 (setq Name (shr Name 24))) (hex "FF"))  # Low 8 bits
      (& (i32 (shr Name 12)) (hex "FF00")) ) )  # High 8 bits
# Get object ID from external symbol name
(de i64 objId (Name)
   (|
      (|
         (& (setq Name (shr Name 4)) (hex "FFFFF"))  # Lowest 20 bits
         (& (setq Name (shr Name 8)) (hex "FFF00000")) )  # Middle 12 bits
      (& (shr Name 8) (hex "3FF00000000")) ) )  # Highest 10 bits
# Pack external symbol name
(de void packAO ((i32 . File) (i64* . P))
   (when (> File 15)
      (packAO (shr File 4) P) )  # Divide by 16
   (byteSym (+ (& (i8 File) 15) (char "@")) P) )  # Make ASCII letter
(de void packOct ((i64 . Obj) (i64* . P))
   (when (> Obj 7)
      (packOct (shr Obj 3) P) )  # Divide by 8
   (byteSym (+ (& (i8 Obj) 7) (char "0")) P) )  # Make ASCII digit
(de void packExtNm (Name (i64* . P))
   (when (objFile Name)
      (packAO @ P) )
   (packOct (objId Name) P) )
# General pack
(de void pack (X (i64* . P))
   (when (pair X)
      (stkChk 0)
      (loop
         (pack (++ X) P)
         (? (atom X)) ) )
   (cond
      ((nil? X))
      ((num? X) (fmtNum X 0 0 0 P))
      ((sym? (val (tail X)))
         (byteSym (char "{") P)
         (packExtNm (name (& @ -9)) P)
         (byteSym (char "}") P) )
      (T
         (let Q (push 0 (name @))  # [cnt name]
            (while (symByte Q)
               (byteSym @ P) ) ) ) ) )
# Chop external symbol name
(de chopExtNm (Name)
   (let (R (link (push $Nil NIL))  N (objId Name))
      (loop
         (let A (+ (& N 7) (char "0"))  # Make ASCII digit
            (when (setq N (shr N 3))
               (setq A
                  (|
                     (shl A 8)
                     (+ (& N 7) (char "0")) ) )  # Second octal digit
               (when (setq N (shr N 3))
                  (setq A
                     (|
                        (shl A 8)
                        (+ (& N 7) (char "0")) ) ) ) )  # Third octal digit
            (set R
               (cons (consSym (cnt A) 0) (val R)) ) )
         (? (=0 (setq N (shr N 3)))) )
      (when (setq N (objFile Name))
         (let F (i32 0)
            (loop
               (setq F
                  (| F (+ (& N 15) (char "@"))) )  # Make ASCII letter
               (? (=0 (setq N (shr N 4))))
               (setq F (shl F 8)) )
            (set R
               (cons (consStr (cnt (i64 F))) (val R)) ) ) )
      (pop R) ) )
### Interning ###
(local) (cmpLong isIntern isLstIntern findSym)
# Compare long names
(de i64 cmpLong (X Y)
   (loop
      (? (sub (val (dig X)) (val (dig Y)))
         (if @@ -1 +1) )
      (setq X (val (big X))  Y (val (big Y)))
      (? (cnt? X)
         (cond
            ((big? Y) -1)
            ((== Y X) 0)
            ((> Y X) -1)
            (T +1) ) )
      (? (cnt? Y) +1) ) )
# Is name interned?
(de isIntern (Name Tree)
   (if (cnt? Name)  # Short name
      (let X (car Tree)  # First tree
         (loop
            (? (atom X) 0)  # Empty
            (let (S (car X)  Nm (name (val (tail S))))
               (? (== Name Nm) S)
               (setq X
                  (if (> Name Nm)  # Symbol is smaller
                     (cddr X)
                     (cadr X) ) ) ) ) )
      # Long name
      (let X (cdr Tree)  # Second tree
         (loop
            (? (atom X) 0)  # Empty
            (let (S (car X)  Nm (name (val (tail S))))
               (? (=0 (cmpLong Nm Name)) S)
               (setq X
                  (if (lt0 @)  # Symbol is smaller
                     (cddr X)
                     (cadr X) ) ) ) ) ) ) )
(de isLstIntern (Name Lst)
   (loop
      (? (atom Lst) 0)
      (? (isIntern Name (cdar (car Lst))) @)
      (shift Lst) ) )
(de i1 findSym (Sym Name Lst)
   (loop
      (? (atom Lst) NO)
      (? (== Sym (isIntern Name (cdar (car Lst)))) YES)
      (shift Lst) ) )
(local) (intern1 intern2 internRight internLeft)
(inline intern1 (Sym Val Name Node More)
   (if (isLstIntern Name More)
      @
      (unless Sym  # New symbol
         (setq Sym (consSym Name Val)) )
      (set Node (cons Sym $Nil))
      Sym ) )
(inline intern2 (Sym Val Name Node More)
   (if (isLstIntern Name More)
      @
      (unless Sym  # New symbol
         (setq Sym (consSym Name Val)) )
      (set 2 Node (cons Sym $Nil))
      Sym ) )
(inline internRight (Sym Val Name Node More)
   (if (isLstIntern Name More)
      @
      (unless Sym  # New symbol
         (setq Sym (consSym Name Val)) )
      (set 2 Node (cons $Nil (cons Sym $Nil)))
      Sym ) )
(inline internLeft (Sym Val Name Node More)
   (if (isLstIntern Name More)
      @
      (unless Sym  # New symbol
         (setq Sym (consSym Name Val)) )
      (set 2 Node (cons (cons Sym $Nil) $Nil))
      Sym ) )
(local) (intern requestSym extern delNode unintern)
# Intern a symbol/name
(de intern (Sym Val Name Tree More (i1 . Rpl))
   (if (cnt? Name)  # Short name
      (let X (car Tree)  # First tree
         (if (pair X)  # Not empty
            (loop
               (let (S (car X)  Nm (name (val (tail S))))
                  (? (== Name Nm)  # Found name
                     (if Rpl
                        (set X Sym)  # Replace with argument symbol
                        S ) )  # Return found symbol
                  (let Y (cdr X)  # Get link cell
                     (cond
                        ((> Name Nm)  # Symbol is smaller
                           (? (atom Y) (internRight Sym Val Name X More))  # No link yet
                           (? (atom (setq Y (cdr (setq X Y))))
                              (intern2 Sym Val Name X More) ) )
                        (T  # Symbol is greater
                           (? (atom Y) (internLeft Sym Val Name X More))  # No link yet
                           (? (atom (setq Y (car (setq X Y))))
                              (intern1 Sym Val Name X More) ) ) )
                     (setq X Y) ) ) )
            # Empty
            (intern1 Sym Val Name Tree More) ) )
      # Long name
      (let X (cdr Tree)  # Second tree
         (if (pair X)  # Not empty
            (loop
               (let (S (car X)  Nm (name (val (tail S))))
                  (? (=0 (cmpLong Nm Name))  # Found name
                     (if Rpl
                        (set X Sym)  # Replace with argument symbol
                        S ) )  # Return found symbol
                  (let Y (cdr X)  # Get link cell
                     (cond
                        ((lt0 @)  # Symbol is smaller
                           (? (atom Y) (internRight Sym Val Name X More))  # No link yet
                           (? (atom (setq Y (cdr (setq X Y))))
                              (intern2 Sym Val Name X More) ) )
                        (T  # Symbol is greater
                           (? (atom Y) (internLeft Sym Val Name X More))  # No link yet
                           (? (atom (setq Y (car (setq X Y))))
                              (intern1 Sym Val Name X More) ) ) )
                     (setq X Y) ) ) )
            # Empty
            (intern2 Sym Val Name Tree More) ) ) ) )
(de requestSym (Name)
   (if (isIntern Name $PrivT)
      @
      (let L (val $Intern)
         (intern 0 $Nil Name
            (cdar (car L))
            (cdr L)
            NO ) ) ) )
# Intern an external symbol
(de extern (Name)
   (need3)  # Reserve 3 cells
   (let (X (val $Extern)  C 0  Sym T)
      (loop
         (inc 'C)  # Next level
         (setq Sym (car X))  # Next symbol
         (let Nm
            (&
               (name (& (val (tail Sym)) -9))
               (hex "3FFFFFFFFFFFFFF7") )  # Mask status and extern bits
            (? (== Nm Name))  # Found
            (let Y (cdr X)  # Get link cell
               (cond
                  ((> Name Nm)  # Symbol is smaller
                     (? (atom Y)  # No link yet
                        (set 2 X
                           (cons $Nil (cons (setq Sym (consExt Name)) $Nil)) ) )
                     (? (atom (setq Y (cdr (setq X Y))))
                        (set 2 X
                           (cons (setq Sym (consExt Name)) $Nil) ) ) )
                  (T  # Symbol is greater
                     (? (atom Y)  # No link yet
                        (set 2 X
                           (cons (cons (setq Sym (consExt Name)) $Nil) $Nil) ) )
                     (? (atom (setq Y (car (setq X Y))))
                        (set X
                           (cons (setq Sym (consExt Name)) $Nil) ) ) ) )
               (setq X Y) ) ) )
      (setq C (shr C 1))  # Half depth
      (when (> (shl 1 C) (val $ExtCnt))  # 2 ** (C/2)
         (setq X (val $Extern))
         (let N (val $ExtSkip)  # Levels to skip
            (if (> (inc 'N) C)  # Beyond half depth
               (set $ExtSkip 0)  # Don't skip
               (set $ExtSkip N)
               (loop  # Skip
                  (setq X
                     (if
                        (>
                           Name
                           (&
                              (name (& (val (tail (++ X))) -9))
                              (hex "3FFFFFFFFFFFFFF7") ) )
                        (cdr X)
                        (car X) ) )
                  (? (=0 (dec 'C))) ) ) )
         (loop  # Pivot
            (let
               (Nm
                  (&
                     (name (& (val (tail (car X))) -9))
                     (hex "3FFFFFFFFFFFFFF7") )
                  Y (cdr X) )
               (? (== Nm Name))  # Done
               (if (> Name Nm)  # Symbol is smaller
                  (let Z (cdr Y)  # Get right node
                     (? (atom (cdr Z)))
                     (xchg Z X)  # Pivot left
                     (setq Z (cdr Z)  X (cdr Z))
                     (set  # Rotate pointers
                        2 Z (val Z)
                        Z (val Y)
                        Y (cdr Y)
                        2 Y X) )
                  (let Z (car Y)  # Get left node
                     (? (atom (cdr Z)))
                     (xchg Z X)  # Pivot right
                     (setq Z (cdr Z)  X (val Z))
                     (set  # Rotate pointers
                        Z (cdr Z)
                        2 Z (cdr Y)
                        2 Y (val Y)
                        Y X) ) ) ) ) )
      Sym ) )
(de void delNode (X P)
   (let Y (cdr X)  # Subtrees
      (cond
         ((atom (car Y))  # No left branch
            (set P (cdr Y)) )  # Use right branch
         ((atom (cdr Y))  # No right branch
            (set P (car Y)) )  # Use left branch
         ((atom (car (setq P (cdr (shift Y)))))  # Y on right branch, P on sub-branches
            (set  # No left sub-branch
               X (car Y)  # Insert right sub-branch
               2 (cdr X) (cdr P) ) )
         (T
            (setq P (car P))  # Left sub-branch
            (loop
               (let Z (cdr P)  # More left branches
                  (? (atom (car Z))
                     (set
                        X (car P)  # Insert left sub-branch
                        (cdr Y) (cdr Z) ) )
                  (setq Y P  P (car Z)) ) ) ) ) ) )  # Go down left
(de void unintern (Sym Name P)
   (if (cnt? Name)  # Short name
      (loop  # First tree
         (let X (car P)  # Next node
            (? (atom X))  # Empty
            (let (S (car X)  Nm (name (val (tail S))))
               (? (== Name Nm)
                  (when (== S Sym)  # Correct symbol
                     (delNode X P) ) )
               (? (atom (shift X)))
               (setq P
                  (if (> Name Nm) (ofs X 1) X) ) ) ) )
      # Long name
      (setq P (ofs P 1))  # Second tree
      (loop
         (let X (car P)  # Next node
            (? (atom X))  # Empty
            (let
               (S (car X)
                  Nm (name (val (tail S)))
                  I (cmpLong Nm Name) )
               (? (=0 I)
                  (when (== S Sym)  # Correct symbol
                     (delNode X P) ) )
               (? (atom (shift X)))
               (setq P
                  (if (lt0 I) (ofs X 1) X) ) ) ) ) ) )
# (name 'sym) -> sym
(de _Name (Exe)
   (let Tail (val (tail (needSymb Exe (eval (cadr Exe)))))
      (if (sym? Tail)  # External
         (let P (push 4 NIL ZERO NIL)  # [cnt last name link]
            (link (ofs P 2) T)
            (packExtNm (name (& Tail -9)) P)
            (consStr (val 3 P)) )
         (consStr (name Tail)) ) ) )
# (nsp 'sym) -> sym
(de _Nsp (Exe)
   (let Sym (needSymb Exe (eval (cadr Exe)))
      (if (sym? (val (tail Sym)))
         $Nil
         (let Nm (name @)
            (if (== Sym (isIntern Nm $PrivT))  # Private?
               $priv
               (let Lst (val $Intern)  # Search namespaces
                  (loop
                     (? (atom Lst) $Nil)
                     (let Nsp (car Lst)
                        (? (== Sym (isIntern Nm (cdar Nsp))) Nsp) )
                     (shift Lst) ) ) ) ) ) ) )
# (sp? 'any) -> flg
(de _SpQ (Exe)
   (if (isBlank (eval (cadr Exe)))
      $T
      $Nil ) )
# (pat? 'any) -> sym | NIL
(de _PatQ (Exe)
   (let X (eval (cadr Exe))
      (if (and (symb? X) (== (firstChar X) (char "@")))
         X
         $Nil ) ) )
# (fun? 'any) -> any
(de _FunQ (Exe)
   (if (funq (eval (cadr Exe)))
      @
      $Nil ) )
# (getd 'any) -> fun | NIL
(de _Getd (Exe)
   (let (X (eval (cadr Exe))  V T)
      (cond
         ((not (symb? X)) $Nil)
         ((funq (setq V (val X))) V)
         ((and (nil? V) (sharedLib X)) (val X))
         (T $Nil) ) ) )
### Namespaces ###
(local) consTree
# Build sorted list from tree
(de consTree (P Lst)
   (if (atom P)
      Lst
      (let
         (Q (link (push NIL NIL))
            Tos (link (push -ZERO NIL)))
         (loop
            (loop
               (let X (cdr P)  # Get subtrees
                  (? (atom (cdr X)))  # Right subtree
                  (let Y P  # Go right
                     (setq P @)  # Invert tree
                     (set 2 X (val Tos))
                     (set Tos Y) ) ) )
            (set Q P)  # Save tree
            (loop
               (setq Lst (cons (car P) Lst))  # Cons symbol
               (let X (cdr P)
                  (? (pair (car X))  # Left subtree
                     (let Y P  # Go left
                        (setq P @)  # Invert tree
                        (set X (val Tos))
                        (set Tos (| Y 8))  # First visit
                        (set Q P) ) ) )  # Save tree
               (loop
                  (let X (val Tos)
                     (when (== -ZERO X)
                        (drop Q)
                        (ret Lst) )
                     (? (=0 (& X 8))  # Second visit
                        (let Y (cdr X)  # Nodes
                           (set Tos (cdr Y))  # TOS on up link
                           (set 2 Y P)
                           (setq P X)
                           (set Q P) ) )  # Save tree
                     (setq X (& X -9))  # Clear visit bit
                     (let Y (cdr X)  # Nodes
                        (set Tos (car Y))
                        (set Y P)
                        (setq P X)
                        (set Q P) ) ) ) ) ) ) ) )  # Save tree
# (all ['NIL | 'T | '0 | 'sym | '(NIL . flg) | '(T . flg) | '(0)]) -> lst
(de _All (Exe)
   (let X (eval (cadr Exe))
      (cond
         ((nil? X)  # Internal symbols
            (let Y (val $Intern)
               (loop
                  (let Z (cdar (++ Y))
                     (setq X
                        (consTree (car Z) (consTree (cdr Z) X)) ) )
                  (? (atom Y) X) ) ) )
         ((t? X)  # Transient symbols
            (consTree (val $Transient) (consTree (val 2 $Transient) $Nil)) )
         ((num? X)  # External symbols
            (consTree (val $Extern) $Nil) )
         ((sym? X)  # Given namespace
            (let Y (cdar X)
               (if (pair Y)
                  (consTree (car Y) (consTree (cdr Y) $Nil))
                  $Nil ) ) )
         ((nil? (car X))  # Direct internal tree
            (let Y (val (car (val $Intern)))
               (if (nil? (cdr X))
                  (val Y)
                  (val 2 Y) ) ) )
         ((t? (car X))  # Direct transient trees
            (if (nil? (cdr X))
               (val $Transient)
               (val 2 $Transient) ) )
         (T (val $Extern)) ) ) ) # Direct external tree
# (symbols) -> lst
# (symbols 'lst) -> lst
# (symbols 'lst . prg) -> any
# (symbols 'sym1 'sym2 ..) -> lst
(de _Symbols (Exe)
   (let X (cdr Exe)
      (if (atom X)  # No args
         (val $Intern)
         (let Y (eval (++ X))
            (if (pair Y)  # List argument
               (let L Y
                  (loop
                     (needNsp Exe (needSymb Exe (++ L)))
                     (? (atom L)) )
                  (if (atom X)  # No 'prg'
                     (prog1
                        (val $Intern)
                        (set $Intern Y) )
                     (let Z (save (val $Intern))
                        (set $Intern Y)
                        (prog1
                           (run X)  # Run 'prg'
                           (set $Intern Z) ) ) ) )
               (if
                  (or  # New namespace
                     (nil? (val (needSymb Exe Y)))
                     (== @ Y) )
                  (set
                     (chkVar Exe Y)
                     (cons $Tilde (cons $Nil $Nil)) )
                  (needNsp Exe Y) )
               (let R (setq Y (save (cons Y $Nil)))
                  (while (pair X)
                     (setq Y
                        (set 2 Y
                           (cons
                              (needNsp Exe (needSymb Exe (eval (++ X))))
                              $Nil ) ) ) )
                  (prog1
                     (val $Intern)
                     (set $Intern R)
                     (putSrc (car R) 0) ) ) ) ) ) ) )
# (intern 'any ['nsp]) -> sym
(de _Intern (Exe)
   (let (X (cdr Exe)  Sym (save (evSym X)))
      (cond
         ((sym? (val (tail Sym))) $Nil)  # External symbol
         ((== (name @) ZERO) $Nil)  # Anonymous symbol
         (T
            (let Nm @
               (if (nil? (eval (cadr X)))
                  (let L (val $Intern)
                     (intern Sym 0 Nm
                        (cdar (car L))
                        (cdr L)
                        NO ) )
                  (intern Sym 0 Nm
                     (if (t? @)
                        (cdar (car (val $Intern)))
                        (cdar @) )
                     $Nil
                     NO ) ) ) ) ) ) )
# (====) -> NIL
(de _Hide (Exe)
   (set $Transient (set 2 $Transient $Nil)) )
# (box? 'any) -> sym | NIL
(de _BoxQ (Exe)
   (let X (eval (cadr Exe))
      (if
         (and
            (symb? X)
            (not (sym? (val (tail X))))
            (== ZERO (name @)) )
         X
         $Nil ) ) )
# (str? 'any) -> sym | NIL
(de _StrQ (Exe)
   (let X (eval (cadr Exe))
      (cond
         ((not (symb? X)) $Nil)
         ((or
               (sym? (val (tail X)))  # External
               (findSym X (name @) (val $Intern)) )
            $Nil )
         (T X) ) ) )
# (zap 'sym) -> sym
(de _Zap (Exe)
   (let Sym (needSymb Exe (eval (cadr Exe)))
      (if (sym? (val (tail Sym)))  # External
         (dbZap Sym)
         (unintern Sym (name @) (cdar (car (val $Intern)))) )
      Sym ) )
# (chop 'any) -> lst
(de _Chop (Exe)
   (let X (eval (cadr Exe))
      (if (or (pair X) (nil? X))
         X
         (let Tail (val (tail (xSym X)))
            (if (sym? Tail)  # External
               (chopExtNm (name (& Tail -9)))
               (let (P (push 0 (name Tail))  C (symChar P))
                  (if C
                     (save Tail
                        (let (Y (cons (mkChar C) $Nil)  R (save Y))
                           (while (setq C (symChar P))
                              (setq Y
                                 (set 2 Y (cons (mkChar C) $Nil)) ) )
                           R ) )
                     $Nil ) ) ) ) ) ) )
# (pack 'any ..) -> sym
(de _Pack (Exe)
   (save -ZERO
      (let
         (X (cdr Exe)
            P (push 4 NIL ZERO NIL) )  # [cnt last name link]
         (link (ofs P 2))
         (while (pair X)
            (pack (safe (eval (++ X))) P) )
         (consStr (val 3 P)) ) ) )
# (glue 'any 'lst) -> sym
(de _Glue (Exe)
   (let (X (cdr Exe)  Y (save (eval (++ X))))  # 'any'
      (if (atom (eval (++ X)))  # 'lst'
         @
         (let (Z (save @)  P (push 4 NIL ZERO NIL))  # [cnt last name link]
            (link (ofs P 2))
            (loop
               (pack (++ Z) P)
               (? (atom Z))
               (pack Y P) )
            (consStr (val 3 P)) ) ) ) )
# (text 'any1 'any ..) -> sym
(de _Text (Exe)
   (let (X (cdr Exe)  Y (evSym X))
      (if (nil? Y)
         Y
         (let
            (P (push 0 (xName Exe Y) NIL)  # [cnt name link]
               Q (link (ofs P 1) T)
               R (push 4 NIL ZERO NIL)  # [cnt last name link]
               A (link (ofs R 2))
               N 0
               C T )
            (while (pair (shift X))
               (setq A (link (push (eval (car X)) NIL)))
               (inc 'N) )
            (while (setq C (symByte P))
               (cond
                  ((<> C (char "@")) (byteSym C R))
                  ((== (setq C (symByte P)) (char "@"))
                     (byteSym C R) )  # "@@"
                  ((gt0 (dec 'C (char "0")))
                     (when (> C 9)
                        (dec 'C 7) )  # Adjust for letter
                     (when (ge0 (setq C (- N (i64 C))))
                        (let I A
                           (while (ge0 (dec 'C))
                              (shift I) )
                           (pack (val I) R) ) ) ) ) )
            (consStr (val 3 R)) ) ) ) )
### Matching ###
(local) (preStr subStr)
(de i1 preStr (Nm (i8 . B) (i64* . P))
   (let (Q (push 0 (i64 Nm))  C (symByte Q))
      (loop
         (? (<> B C) NO)
         (? (=0 (setq C (symByte Q))) YES)
         (? (=0 (setq B (symByte P))) NO) ) ) )
(de i1 subStr (X Y)
   (or
      (nil? X)
      (== ZERO (setq X (xName 0 X)))
      (let (P (push 0 (xName 0 Y))  B T)
         (loop
            (? (=0 (setq B (symByte P))) NO)
            (let (Cnt (val P)  Nm (val 2 P))
               (? (preStr X B P) YES)
               (set P Cnt  2 P Nm) ) ) ) ) )
# (pre? 'any1 'any2) -> any2 | NIL
(de _PreQ (Exe)
   (let (X (cdr Exe)  Y (save (evSym X))  Z (evSym (shift X)))
      (cond
         ((nil? Y) Z)
         ((== ZERO (setq Y (xName Exe Y)))
            Z )
         (T
            (let P (push 0 (xName Exe Z))
               (cond
                  ((=0 (symByte P)) $Nil)
                  ((preStr Y @ P) Z)
                  (T $Nil) ) ) ) ) ) )
# (sub? 'any1 'any2) -> any2 | NIL
(de _SubQ (Exe)
   (let (X (cdr Exe)  Y (save (evSym X))  Z (evSym (shift X)))
      (if (subStr Y Z)
         Z
         $Nil ) ) )
# (val 'var) -> any
(de _Val (Exe)
   (let V (needVar Exe (eval (cadr Exe)))
      (when (and (sym? V) (sym? (val (tail V))))
         (dbFetch Exe V) )
      (val V) ) )
# (set 'var 'any ..) -> any
(de _Set (Exe)
   (save -ZERO
      (let X (cdr Exe)
         (loop
            (let Y (safe (needChkVar Exe (eval (++ X))))
               (when (and (sym? Y) (sym? (val (tail Y))))
                  (dbTouch Exe Y) )
               (let Z (eval (++ X))
                  (set Y Z)
                  (? (atom X) Z) ) ) ) ) ) )
# (setq var 'any ..) -> any
(de _Setq (Exe)
   (let X (cdr Exe)
      (loop
         (let Y (set (needChkVar Exe (++ X)) (eval (++ X)))
            (? (atom X) Y) ) ) ) )
# (swap 'var 'any) -> any
(de _Swap (Exe)
   (let
      (X (cdr Exe)
         Y (save (needChkVar Exe (eval (++ X)))) )
      (when (and (sym? Y) (sym? (val (tail Y))))
         (dbTouch Exe Y) )
      (let (Z (eval (car X))  V (val Y))
         (set Y Z)
         V ) ) )
# (xchg 'var 'var ..) -> any
(de _Xchg (Exe)
   (save -ZERO
      (let X (cdr Exe)
         (loop
            (let Y (safe (needChkVar Exe (eval (++ X))))
               (when (and (sym? Y) (sym? (val (tail Y))))
                  (dbTouch Exe Y) )
               (let Z (needChkVar Exe (eval (++ X)))
                  (when (and (sym? Z) (sym? (val (tail Z))))
                     (dbTouch Exe Z) )
                  (setq Z (xchg Y Z))
                  (? (atom X) Z) ) ) ) ) ) )
# (on var ..) -> T
(de _On (Exe)
   (let X (cdr Exe)
      (loop
         (set (needChkVar Exe (++ X)) $T)
         (? (atom X) $T) ) ) )
# (off var ..) -> NIL
(de _Off (Exe)
   (let X (cdr Exe)
      (loop
         (set (needChkVar Exe (++ X)) $Nil)
         (? (atom X) $Nil) ) ) )
# (onOff var ..) -> flg
(de _OnOff (Exe)
   (let X (cdr Exe)
      (loop
         (let
            (Y (needChkVar Exe (++ X))
               Z (if (nil? (val Y)) $T $Nil) )
            (set Y Z)
            (? (atom X) Z) ) ) ) )
# (zero var ..) -> 0
(de _Zero (Exe)
   (let X (cdr Exe)
      (loop
         (set (needChkVar Exe (++ X)) ZERO)
         (? (atom X) ZERO) ) ) )
# (one var ..) -> 1
(de _One (Exe)
   (let X (cdr Exe)
      (loop
         (set (needChkVar Exe (++ X)) ONE)
         (? (atom X) ONE) ) ) )
# (default sym 'any ..) -> any
(de _Default (Exe)
   (let X (cdr Exe)
      (loop
         (let Y (needChkVar Exe (++ X))
            (when (nil? (val Y))
               (set Y (eval (car X))) )
            (? (atom (shift X)) (val Y)) ) ) ) )
# (push 'var 'any ..) -> any
(de _Push (Exe)
   (let
      (X (cdr Exe)
         Y (save (needChkVar Exe (eval (++ X)))) )
      (when (and (sym? Y) (sym? (val (tail Y))))
         (dbTouch Exe Y) )
      (loop
         (let Z (eval (++ X))
            (set Y (cons Z (val Y)))
            (? (atom X) Z) ) ) ) )
# (push1 'var 'any ..) -> any
(de _Push1 (Exe)
   (let
      (X (cdr Exe)
         Y (save (needChkVar Exe (eval (++ X)))) )
      (when (and (sym? Y) (sym? (val (tail Y))))
         (dbTouch Exe Y) )
      (loop
         (let (Z (eval (++ X))  V (val Y))
            (unless (member Z V)
               (set Y (cons Z V)) )
            (? (atom X) Z) ) ) ) )
# (push1q 'var 'any ..) -> any
(de _Push1q (Exe)
   (let
      (X (cdr Exe)
         Y (save (needChkVar Exe (eval (++ X)))) )
      (when (and (sym? Y) (sym? (val (tail Y))))
         (dbTouch Exe Y) )
      (loop
         (let (Z (eval (++ X))  V (val Y))
            (unless (memq Z V)
               (set Y (cons Z V)) )
            (? (atom X) Z) ) ) ) )
# (pop 'var) -> any
(de _Pop (Exe)
   (let X (needChkVar Exe (eval (cadr Exe)))
      (when (and (sym? X) (sym? (val (tail X))))
         (dbTouch Exe X) )
      (if (atom (val X))
         @
         (set X (cdr @))
         (car @) ) ) )
# (++ var) -> any
(de _Popq (Exe)
   (let X (needChkVar Exe (cadr Exe))
      (if (atom (val X))
         @
         (set X (cdr @))
         (car @) ) ) )
# (shift 'var) -> any
(de _Shift (Exe)
   (let X (needChkVar Exe (eval (cadr Exe)))
      (when (and (sym? X) (sym? (val (tail X))))
         (dbTouch Exe X) )
      (set X (cdr (needLst Exe (val X)))) ) )
# (cut 'cnt 'var) -> lst
(de _Cut (Exe)
   (let (X (cdr Exe)  N (evCnt Exe X))
      (if (le0 N)
         $Nil
         (let Y (needChkVar Exe (eval (cadr X)))
            (when (and (sym? Y) (sym? (val (tail Y))))
               (dbTouch Exe Y) )
            (if (atom (val Y))
               @
               (let
                  (V (save @)
                     Z (cons (++ V) $Nil)
                     R (save Z) )
                  (while (and (pair V) (dec 'N))
                     (setq Z (set 2 Z (cons (++ V) $Nil))) )
                  (set Y V)  # Set new value
                  R ) ) ) ) ) )
# (del 'any 'var ['flg]) -> lst
(de _Del (Exe)
   (let
      (X (cdr Exe)
         Y (save (eval (++ X)))
         Var (save (needChkVar Exe (eval (++ X))))
         Flg (nil? (eval (car X))) )
      (when (and (sym? Var) (sym? (val (tail Var))))
         (dbTouch Exe Var) )
      (let V (val Var)
         (loop
            (? (atom V) V)
            (let Z (++ V)
               (? (not (equal Y Z))
                  (let (P (cons Z $Nil)  R P)
                     (save R
                        (loop
                           (? (atom V))
                           (if (equal Y (setq Z (++ V)))
                              (? Flg)
                              (setq P (set 2 P (cons Z $Nil))) ) ) )
                     (set 2 P V  Var R) ) ) )
            (set Var V)
            (? Flg V) ) ) ) )
# (queue 'var 'any) -> any
(de _Queue (Exe)
   (let
      (X (cdr Exe)
         Y (save (needChkVar Exe (eval (++ X)))) )
      (when (and (sym? Y) (sym? (val (tail Y))))
         (dbTouch Exe Y) )
      (let
         (Z (eval (car X))
            L (cons Z $Nil)
            V (val Y) )
         (if (atom V)
            (set Y L)
            (while (pair (cdr V))
               (shift V) )
            (set 2 V L) )
         Z ) ) )
# (fifo 'var ['any ..]) -> any
(de _Fifo (Exe)
   (let
      (X (cdr Exe)
         Y (save (needChkVar Exe (eval (++ X)))) )
      (when (and (sym? Y) (sym? (val (tail Y))))
         (dbTouch Exe Y) )  # External symbol
      (let V (val Y)
         (cond
            ((pair X)  # Add to fifo
               (let E (eval (car X))
                  (if (pair V)
                     (setq V (set 2 V (cons E (cdr V))))  # Concat into value
                     (setq V (cons E -ZERO))  # Circular cell
                     (set 2 V V) )
                  (while (pair (shift X))
                     (setq V
                        (set 2 V
                           (cons
                              (setq E (eval (car X)))
                              (cdr V) ) ) ) )
                  (set Y V)
                  E ) )
            ((atom V) $Nil)  # Empty
            ((== (cdr V) V)  # Single cell
               (set Y $Nil)  # Clear value
               (car V) )
            (T
               (set 2 V (cdr @))  # Remove
               (car @) ) ) ) ) )  # and return
# (rid 'var 'any) -> any
(de _Rid (Exe)
   (let
      (X (cdr Exe)
         Y (save (needChkVar Exe (eval (++ X)))) )
      (when (and (sym? Y) (sym? (val (tail Y))))
         (dbTouch Exe Y) )  # External symbol
      (setq X (eval (car X)))
      (let V (val Y)
         (cond
            ((pair V)
               (let (Z V  L (cdr Z))
                  (loop
                     (? (atom L)  # Non-circular
                        (when (equal L X)
                           (set 2 Z $Nil) )
                        (if (equal (car V) X)
                           (set Y (cdr V))
                           V ) )
                     (? (== L V)  # Circular
                        (nond
                           ((equal (car L) X) V)
                           ((== L Z)
                              (set 2 Z (cdr L))
                              (set Y Z) )
                           (NIL (set Y $Nil)) ) )
                     (if (equal (car L) X)
                        (set 2 Z (shift L))
                        (setq L (cdr (shift Z))) ) ) ) )
            ((equal V X) (set Y $Nil))
            (T V) ) ) ) )
# (enum 'var 'cnt ['cnt ..]) -> lst
# (enum 'var) -> lst
(de _Enum (Exe)
   (let
      (X (cdr Exe)
         Var (save (needChkVar Exe (eval (++ X))))
         Cnt T )
      (if (pair X)
         (loop
            (? (le0 (setq Cnt (evCnt Exe X))) $Nil)
            (let P (val Var)
               (loop
                  (let N (shr Cnt 1)
                     (? (=0 N)
                        (setq Var
                           (if (pair P)
                              @
                              (set Var (cons $Nil $Nil)) ) ) )
                     (if (& Cnt 1)
                        (cond
                           ((atom P)
                              (let Y (cons $Nil (setq P $Nil))
                                 (set Var (cons $Nil Y))
                                 (setq Var (ofs Y 1)) ) )
                           ((atom (cdr P))
                              (setq Var
                                 (ofs
                                    (set 2 P (cons $Nil (setq P $Nil)))
                                    1 ) ) )
                           (T
                              (setq P (val (setq Var (ofs @ 1)))) ) )
                        (cond
                           ((atom P)
                              (let Y (cons (setq P $Nil) $Nil)
                                 (set Var (cons $Nil Y))
                                 (setq Var Y) ) )
                           ((atom (cdr P))
                              (setq Var
                                 (set 2 P (cons (setq P $Nil) $Nil)) ) )
                           (T (setq P (val (setq Var @)))) ) )
                     (setq Cnt N) ) ) )
            (? (atom (shift X)) Var) )
         (setq Cnt 0)
         (let
            (Q (link (push NIL NIL))
               Tos (link (push -ZERO NIL))
               R (link (push $Nil NIL))
               P (val Var)
               M 1 )
            (loop
               (loop
                  (let Y (cdr P)  # Get subtrees
                     (? (atom (cdr Y)))  # Right subtree
                     (let Z P  # Go right
                        (setq P @)  # Invert tree
                        (set 2 Y (val Tos))
                        (set Tos Z) )
                     (setq
                        Cnt (| Cnt M)
                        M (shl M 1) ) ) )
               (set Q P)  # Save tree
               (loop
                  (unless (nil? (car P))
                     (set R
                        (cons  # (cnt . any)
                           (cons (cnt (| Cnt M)) @)
                           (val R) ) ) )
                  (let Y (cdr P)
                     (? (pair (car Y))  # Left subtree
                        (let Z P  # Go left
                           (setq P @)  # Invert tree
                           (set Y (val Tos))
                           (set Tos (| Z 8))  # First visit
                           (set Q P) )  # Save tree
                        (setq M (shl M 1)) ) )
                  (loop
                     (let Y (val Tos)
                        (when (== -ZERO Y)
                           (ret (val R)) )
                        (? (=0 (& Y 8))  # Second visit
                           (setq
                              M (shr M 1)
                              Cnt (& Cnt (x| M -1)) )
                           (let Z (cdr Y)  # Nodes
                              (set Tos (cdr Z))  # TOS on up link
                              (set 2 Z P)
                              (setq P Y)
                              (set Q P) ) )  # Save tree
                        (setq
                           Y (& Y -9)  # Clear visit bit
                           M (shr M 1)
                           Cnt (& Cnt (x| M -1)) )
                        (let Z (cdr Y)  # Nodes
                           (set Tos (car Z))
                           (set Z P)
                           (setq P Y)
                           (set Q P) ) ) ) ) ) ) ) ) )  # Save tree
# (enum? 'lst 'cnt ['cnt ..]) -> lst | NIL
(de _EnumQ (Exe)
   (let
      (X (cdr Exe)
         P (save (eval (++ X)))
         Cnt T )
      (loop
         (? (le0 (setq Cnt (evCnt Exe X))) $Nil)
         (loop
            (let N (shr Cnt 1)
               (? (=0 N))
               (setq P
                  (if (& Cnt 1) (cddr P) (cadr P)) )
               (? (atom P) (ret $Nil))
               (setq Cnt N) ) )
         (? (atom (shift X)) P)
         (setq P (car P)) ) ) )
(local) (idxPut idxGet idxDel)
(de idxPut (Var Key Flg)
   (let X (val Var)
      (if (pair X)
         (loop
            (? (=0 (compare (car X) Key)) X)  # Found key
            (let Y (cdr X)  # Get link cell
               (cond
                  ((lt0 @)  # Entry is smaller
                     (? (atom Y)  # No link yet
                        (if (or (t? Flg) (chance 1))
                           (set 2 X (cons $Nil (cons Key $Nil)))
                           (set 2 X (cons (cons (car X) $Nil) $Nil))
                           (set X Key) )
                        $Nil )
                     (? (atom (setq Y (cdr Y)))
                        (if (or (t? Flg) (chance 1))
                           (set 2 (cdr X) (cons Key $Nil))
                           (set (cdr X)
                              (cons (car X) (cons (cadr X) $Nil)) )
                           (set X Key) )
                        $Nil )
                     (if
                        (or
                           (t? Flg)
                           (atom (cdr Y))
                           (gt0 (compare (car Y) Key))
                           (chance (hex "FFF")) )
                        (setq X Y)
                        (xchg X Y)
                        (set
                           2 (cdr X) (cddr Y)
                           2 (cdr Y) (cadr Y)
                           (cdr Y) (cadr X)
                           (cdr X) Y ) ) )
                  (T  # Entry is greater
                     (? (atom Y)  # No link yet
                        (if (or (t? Flg) (chance 1))
                           (set 2 X (cons (cons Key $Nil) $Nil))
                           (set 2 X (cons $Nil (cons (car X) $Nil)))
                           (set X Key) )
                        $Nil )
                     (? (atom (setq Y (car Y)))
                        (if (or (t? Flg) (chance 1))
                           (set (cdr X) (cons Key $Nil))
                           (set 2 (cdr X)
                              (cons (car X) (cons $Nil (cddr X))) )
                           (set X Key) )
                        $Nil )
                     (if
                        (or
                           (t? Flg)
                           (atom (cdr Y))
                           (lt0 (compare (car Y) Key))
                           (chance (hex "FFF")) )
                        (setq X Y)
                        (xchg X Y)
                        (set
                           (cdr X) (cadr Y)
                           (cdr Y) (cddr Y)
                           2 (cdr Y) (cddr X)
                           2 (cdr X) Y ) ) ) ) ) )
         (set Var (cons Key $Nil))
         $Nil ) ) )
(de idxGet (Var Key)
   (let X (val Var)
      (cond
         ((nil? Key)
            (while (pair (cadr X))
               (setq X @) )
            X )
         ((t? Key)
            (while (pair (cddr X))
               (setq X @) )
            X )
         (T
            (loop
               (? (atom X) $Nil)
               (? (=0 (compare (car X) Key)) X)  # Found key
               (let Y (cdr X)  # Get link cell
                  (setq X
                     (if (lt0 @) (cdr Y) (car Y)) ) ) ) ) ) ) )
(de idxDel (Var Key)
   (loop
      (let X (val Var)
         (? (atom X) $Nil)
         (let Y (cdr X)  # Subtrees
            (let I (compare (car X) Key)
               (? (=0 I)  # Found key
                  (cond
                     ((atom (car Y))  # No left branch
                        (set Var (cdr Y)) )  # Use right branch
                     ((atom (cdr Y))  # No right branch
                        (set Var (car Y)) )  # Use left branch
                     (T
                        (let Z (cdr (setq Y (cdr Y)))  # Sub-branches
                           (if (atom (car Z))  # No left sub-branch
                              (set   # Insert right sub-branch
                                 X (car Y)
                                 2 (cdr X) (cdr Z) )
                              (let L (cdr (setq Z (car Z)))  # Left sub-branch
                                 (loop
                                    (? (atom (car L)))
                                    (setq Y Z  Z (car L)  L (cdr Z)) )
                                 (set
                                    X (car Z)
                                    (cdr Y) (cdr L) ) ) ) ) ) )
                  X )
               (? (atom Y) $Nil)  # No link cell
               (setq Var Y)  # Default point to left subtree
               (and (lt0 I) (setq Var (ofs Var 1))) ) ) ) ) )  # Point to right
# (idx 'var 'any 'flg) -> lst
# (idx 'var 'any) -> lst
# (idx 'var) -> lst
(de _Idx (Exe)
   (let
      (X (cdr Exe)
         Var (needChkVar Exe (eval (++ X))) )
      (if (atom X)
         (consTree (val Var) $Nil)  # Single arg
         (save Var
            (let Key (save (eval (++ X)))
               (cond
                  ((atom X) (idxGet Var Key))  # Two args
                  ((nil? (eval (car X))) (idxDel Var Key))  # Delete
                  (T (idxPut Var Key @)) ) ) ) ) ) )
# (lup 'lst 'any) -> lst
# (lup 'lst 'any 'any2) -> lst
(de _Lup (Exe)
   (let (X (cdr Exe)  P (save (eval (++ X))))
      (if (atom P)
         P
         (let Key (eval (++ X))
            (if (atom X)
               (loop
                  (let Y (car P)
                     (cond
                        ((t? Y) (setq P (cadr P)))
                        ((atom Y) (setq P (cddr P)))
                        (T
                           (? (=0 (compare (car Y) Key)) (car P))
                           (setq
                              P (cdr P)
                              P (if (lt0 @) (cdr P) (car P)) ) ) ) )
                  (? (atom P) $Nil) )
               (save Key)
               (let
                  (Key2 (save (eval (car X)))
                     Q (link (push NIL NIL))
                     Tos (link (push -ZERO NIL))
                     R $Nil )
                  (loop
                     (loop
                        (let Y (cdr (setq X (cdr P)))  # Right subtree
                           (? (atom Y))
                           (let Z (car P)
                              (? (t? Z))
                              (? (and (pair Z) (gt0 (compare (car Z) Key2)))) )
                           (let Z P  # Go right
                              (setq P Y)  # Invert tree
                              (set 2 X (val Tos))
                              (set Tos Z) ) ) )
                     (set Q P)  # Save tree
                     (loop
                        (when
                           (and
                              (pair (setq X (car P)))
                              (ge0 (compare (car X) Key)) )
                           (when (le0 (compare (car X) Key2))
                              (setq R (cons X R)) )  # Cons symbol
                           (? (pair (car (setq X (cdr P))))  # Left subtree
                              (let Z P  # Go left
                                 (setq P @)  # Invert tree
                                 (set X (val Tos))
                                 (set Tos (| Z 8))  # First visit
                                 (set Q P) ) ) )  # Save tree
                        (loop
                           (when (== -ZERO (setq X (val Tos)))
                              (ret R) )
                           (? (=0 (& X 8))  # Second visit
                              (let Y (cdr X)  # Nodes
                                 (set Tos (cdr Y))  # TOS on up link
                                 (set 2 Y P)
                                 (setq P X)
                                 (set Q P) ) )  # Save tree
                           (setq X (& X -9))  # Clear visit bit
                           (let Y (cdr X)  # Nodes
                              (set Tos (car Y))
                              (set Y P)
                              (setq P X)
                              (set Q P) ) ) ) ) ) ) ) ) ) )  # Save tree
### Property access ###
(local) (put putn get getn prop)
(de void put (Sym Key Val)
   (let Tail (val (tail Sym))
      (unless (num? Tail)  # Property list
         (let (L (any (& Tail -9))  X (car L))
            (if (atom X)
               (when (== Key X)
                  (cond
                     ((nil? Val)
                        (shift L)  # Remove first property
                        (set (tail Sym)
                           (if (sym? Tail) (sym L) L) ) )
                     ((<> Val $T)  # Change to cell
                        (set L (cons Val Key)) ) )
                  (ret) )
               (when (== Key (cdr X))
                  (cond
                     ((nil? Val)
                        (shift L)  # Remove first property
                        (set (tail Sym)
                           (if (sym? Tail) (sym L) L) ) )
                     ((t? Val) (set L Key))  # Change to flag
                     (T (set X Val)) )  # Set new value
                  (ret) ) )
            (while (pair (setq X (cdr L)))
               (let Y (car X)
                  (if (atom Y)
                     (when (== Key Y)
                        (if (nil? Val)
                           (set 2 L (cdr X))  # Remove cell
                           (unless (t? Val)
                              (set X (cons Val Key)) )
                           (set 2 L (cdr X))  # Unlink cell
                           (ifn (sym? Tail)
                              (set 2 X Tail)
                              (set 2 X (& Tail -9))
                              (setq X (sym X)) )
                           (set (tail Sym) X) )
                        (ret) )
                     (when (== Key (cdr Y))
                        (if (nil? Val)
                           (set 2 L (cdr X))  # Remove cell
                           (if (t? Val)
                              (set X Key)  # Change to flag
                              (set Y Val) )  # Set new value
                           (set 2 L (cdr X))  # Unlink cell
                           (ifn (sym? Tail)
                              (set 2 X Tail)
                              (set 2 X (& Tail -9))
                              (setq X (sym X)) )
                           (set (tail Sym) X) )
                        (ret) ) ) )
                  (setq L X) ) ) )
      (unless (nil? Val)  # Non-NIL value
         (setq Val
            (if (t? Val) Key (cons Val Key)) )
         (set (tail Sym)
            (if (sym? Tail)
               (sym (cons Val (& Tail -9)))
               (cons Val Tail) ) ) ) ) )
(de void putn (Exe Lst Key Val)
   (nond
      ((num? Key)
         (loop  # asoq
            (let X (car Lst)
               (? (and (pair X) (== Key (car X)))
                  (set 2 X Val) ) )
            (when (atom (shift Lst))
               (itemErr Exe Key) ) ) )
      ((== ZERO Key)
         (let Cnt (int Key)  # index
            (while (dec 'Cnt)
               (when (atom (shift Lst))
                  (itemErr Exe Key) ) ) )
         (if (sign? Key)
            (set 2 Lst Val)
            (set Lst Val) ) )
      (NIL (argErr Exe Key)) ) )
(de get (Sym Key)
   (let Tail (val (tail Sym))
      (unless (num? Tail)
         (let (L (any (& Tail -9))  X (car L))
            (if (atom X)
               (when (== Key X)
                  (ret $T) )
               (when (== Key (cdr X))
                  (ret (car X)) ) )
            (while (pair (setq X (cdr L)))
               (let Y (car X)
                  (if (atom Y)
                     (when (== Key Y)
                        (set 2 L (cdr X))  # Unlink cell
                        (ifn (sym? Tail)
                           (set 2 X Tail)
                           (set 2 X (& Tail -9))
                           (setq X (sym X)) )
                        (set (tail Sym) X)
                        (ret $T) )
                     (when (== Key (cdr Y))
                        (set 2 L (cdr X))  # Unlink cell
                        (ifn (sym? Tail)
                           (set 2 X Tail)
                           (set 2 X (& Tail -9))
                           (setq X (sym X)) )
                        (set (tail Sym) X)
                        (ret (car Y)) ) )
                  (setq L X) ) ) ) )
      $Nil ) )
(de getn (Exe X Key)
   (when (num? X)  # Need symbol or pair
      (argErr Exe X) )
   (if (pair X)
      (nond
         ((num? Key)
            (loop  # asoq
               (let Y (car X)
                  (? (and (pair Y) (== Key (car Y)))
                     (cdr Y) ) )
               (? (atom (shift X)) $Nil) ) )
         ((== ZERO Key) (nth Key X))
         (NIL $Nil) )
      (when (sym? (val (tail X)))
         (dbFetch Exe X) )
      (if (== Key ZERO)
         (val X)
         (tailcall (get X Key)) ) ) )
(de prop (Sym Key)
   (let Tail (val (tail Sym))
      (unless (num? Tail)
         (let (L (any (& Tail -9))  X (car L))
            (if (atom X)
               (when (== Key X)
                  (ret Key) )
               (when (== Key (cdr X))
                  (ret X) ) )
            (while (pair (setq X (cdr L)))
               (let Y (car X)
                  (if (atom Y)
                     (when (== Key Y)
                        (set 2 L (cdr X))  # Unlink cell
                        (ifn (sym? Tail)
                           (set 2 X Tail)
                           (set 2 X (& Tail -9))
                           (setq X (sym X)) )
                        (set (tail Sym) X)
                        (ret Key) )
                     (when (== Key (cdr Y))
                        (set 2 L (cdr X))  # Unlink cell
                        (ifn (sym? Tail)
                           (set 2 X Tail)
                           (set 2 X (& Tail -9))
                           (setq X (sym X)) )
                        (set (tail Sym) X)
                        (ret Y) ) ) )
               (setq L X) ) ) )
      (let R (cons $Nil Key)
         (set (tail Sym)
            (if (sym? Tail)
               (sym (cons R (& Tail -9)))
               (cons R Tail) ) )
         R ) ) )
# (put 'sym1|lst ['sym2|cnt ..] 'any) -> any
(de _Put (Exe)
   (let
      (X (cdr Exe)
         Y (save (eval (++ X)))
         Key T )
      (loop
         (setq Key (eval (++ X)))
         (? (atom (cdr X)))
         (setq Y (safe (getn Exe Y Key))) )
      (when (num? Y)  # Need symbol or pair
         (argErr Exe Y) )
      (link (push Key NIL))
      (let Val (eval (car X))
         (if (pair Y)
            (putn Exe Y Key Val)
            (when (sym? (val (tail Y)))
               (if (nil? Key)
                  (dbFetch Exe Y)  # Volatile property
                  (dbTouch Exe Y) ) )
            (if (== ZERO Key)
               (set (chkVar Exe Y) Val)
               (put Y Key Val) ) )
         Val ) ) )
# (get 'sym1|lst ['sym2|cnt ..]) -> any
(de _Get (Exe)
   (let (X (cdr Exe)  Y (eval (++ X)))
      (when (pair X)
         (save Y
            (loop
               (setq Y (getn Exe Y (eval (++ X))))
               (? (atom X))
               (safe Y) ) ) )
      Y ) )
# (prop 'sym1|lst ['sym2|cnt ..] 'sym) -> var
(de _Prop (Exe)
   (let
      (X (cdr Exe)
         Y (save (eval (++ X)))
         Key T )
      (loop
         (setq Key (eval (++ X)))
         (? (atom X))
         (setq Y (safe (getn Exe Y Key))) )
      (needSymb Exe Y)
      (link (push Key NIL))
      (when (sym? (val (tail Y)))
         (if (nil? Key)
            (dbFetch Exe Y)  # Volatile property
            (dbTouch Exe Y) ) )
      (prop Y Key) ) )
# (; 'sym1|lst [sym2|cnt ..]) -> any
(de _Semicol (Exe)
   (let (X (cdr Exe)  Y (eval (++ X)))
      (when (pair X)
         (save Y
            (loop
               (setq Y (getn Exe Y (++ X)))
               (? (atom X))
               (safe Y) ) ) )
      Y ) )
# (=: sym|0 [sym1|cnt ..] 'any) -> any
(de _SetCol (Exe)
   (let (X (cdr Exe)  Y (val $This)  Key T)
      (loop
         (setq Key (++ X))
         (? (atom (cdr X)))
         (setq Y (getn Exe Y Key)) )
      (when (num? Y)  # Need symbol or pair
         (argErr Exe Y) )
      (let Val (eval (car X))
         (if (pair Y)
            (putn Exe Y Key Val)
            (when (sym? (val (tail Y)))
               (if (nil? Key)
                  (dbFetch Exe Y)  # Volatile property
                  (dbTouch Exe Y) ) )
            (if (== ZERO Key)
               (set (chkVar Exe Y) Val)
               (put Y Key Val) ) )
         Val ) ) )
# (: sym|0 [sym1|cnt ..]) -> any
(de _Col (Exe)
   (let (X (cdr Exe)  Y (val $This))
      (loop
         (setq Y (getn Exe Y (++ X)))
         (? (atom X) Y) ) ) )
# (:: sym|0 [sym1|cnt .. sym2]) -> var
(de _PropCol (Exe)
   (let (X (cdr Exe)  Y (val $This)  Key T)
      (loop
         (setq Key (++ X))
         (? (atom X))
         (setq Y (getn Exe Y Key)) )
      (needSymb Exe Y)
      (when (sym? (val (tail Y)))
         (if (nil? Key)
            (dbFetch Exe Y)  # Volatile property
            (dbTouch Exe Y) ) )
      (prop Y Key) ) )
# (putl 'sym1|lst1 ['sym2|cnt ..] 'lst) -> lst
(de _Putl (Exe)
   (let
      (X (cdr Exe)
         Y (save (eval (++ X)))
         Z T )
      (loop
         (setq Z (eval (++ X)))
         (? (atom X))
         (setq Y (safe (getn Exe Y Z))) )
      (let
         (R (save Z)
            Tail (val (tail (needSymb Exe Y))) )
         (when (sym? (setq X Tail))
            (dbTouch Exe Y)
            (setq X (& (val (tail Y)) -9)) )
         (until (num? X)  # Skip old properties
            (shift X) )
         (while (pair Z)  # New property list
            (let P (++ Z)
               (if (atom P)
                  (setq X (cons P X))
                  (unless (nil? (car P))
                     (when (t? (car P))
                        (setq P (cdr P)) )
                     (setq X (cons P X)) ) ) ) )
         (set (tail Y)
            (if (sym? Tail) (sym X) X) )
         R ) ) )
# (getl 'sym1|lst1 ['sym2|cnt ..]) -> lst
(de _Getl (Exe)
   (let (X (cdr Exe)  Y (save (eval (car X))))
      (while (pair (shift X))
         (setq Y
            (safe (getn Exe Y (eval (car X)))) ) )
      (when (sym? (setq X (val (tail (needSymb Exe Y)))))
         (dbFetch Exe Y)
         (setq X (& (val (tail Y)) -9)) )
      (if (num? X)
         $Nil
         (let R (setq Y (cons (car X) $Nil))
            (link (push R NIL))
            (while (pair (shift X))
               (setq Y
                  (set 2 Y (cons (car X) $Nil)) ) )
            R ) ) ) )
(local) wipe
(de void wipe (Exe X)
   (let
      (Tail (val (tail (needSymb Exe X)))
         Nm (name (& Tail -9)) )
      (ifn (sym? Tail)  # External symbol
         (set
            X $Nil  # Clear value
            (tail X) Nm )  # and properties
         (setq Nm (add Nm Nm))  # Get carry
         (unless @@  # Not dirty
            (setq Nm (add Nm Nm))
            (when @@  # and loaded
               (set
                  X $Nil
                  (tail X) (sym (shr Nm 2)) ) ) ) ) ) )  # Set "not loaded"
# (wipe 'sym|lst) -> sym|lst
(de _Wipe (Exe)
   (let X (eval (cadr Exe))
      (unless (nil? X)
         (if (atom X)
            (wipe Exe X)
            (let Y X
               (loop
                  (wipe Exe (++ Y))
                  (? (atom Y)) ) ) ) )
      X ) )
(local) meta
(de meta (X Key)
   (loop
      (? (atom X) $Nil)
      (let Y (car X)
         (when (symb? Y)
            (?
               (not
                  (nil?
                     (if (== Key ZERO) (val Y) (get Y Key)) ) )
               @ )
            (stkChk 0)
            (? (not (nil? (meta (car Y) Key))) @) ) )
      (shift X) ) )
# (meta 'obj|typ 'sym ['sym2|cnt ..]) -> any
(de _Meta (Exe)
   (let (X (cdr Exe)  Y (save (eval (++ X))))
      (when (num? Y)  # Need symbol or pair
         (argErr Exe Y) )
      (when (sym? Y)
         (when (sym? (val (tail Y)))
            (dbFetch Exe Y) )
         (setq Y (val Y)) )
      (setq Y (meta Y (eval (car X))))
      (while (pair (shift X))
         (safe Y)
         (setq Y (getn Exe Y (eval (car X)))) )
      Y ) )
# (low? 'any) -> sym | NIL
(de _LowQ (Exe)
   (let X (eval (cadr Exe))
      (if (and (symb? X) (isLowc (firstChar X)))
         X
         $Nil ) ) )
# (upp? 'any) -> sym | NIL
(de _UppQ (Exe)
   (let X (eval (cadr Exe))
      (if (and (symb? X) (isUppc (firstChar X)))
         X
         $Nil ) ) )
# (lowc 'any) -> any
(de _Lowc (Exe)
   (let X (eval (cadr Exe))
      (if (or (not (symb? X)) (nil? X))
         X
         (let
            (P (push 0 (xName Exe X) NIL)  # [cnt name link]
               Q (link (ofs P 1) T)
               R (push 4 NIL ZERO NIL)  # [cnt last name link]
               C T )
            (link (ofs R 2))
            (while (setq C (symChar P))
               (charSym (toLowerCase C) R) )
            (consStr (val 3 R)) ) ) ) )
# (uppc 'any) -> any
(de _Uppc (Exe)
   (let X (eval (cadr Exe))
      (if (or (not (symb? X)) (nil? X))
         X
         (let
            (P (push 0 (xName Exe X) NIL)  # [cnt name link]
               Q (link (ofs P 1) T)
               R (push 4 NIL ZERO NIL)  # [cnt last name link]
               C T )
            (link (ofs R 2))
            (while (setq C (symChar P))
               (ifn (== C (char "ß"))
                  (charSym (toUpperCase C) R)
                  (charSym (char "S") R)
                  (charSym (char "S") R) ) )
            (consStr (val 3 R)) ) ) ) )
# (fold 'any ['cnt]) -> sym
(de _Fold (Exe)
   (let (X (cdr Exe)  Y (eval (++ X)))
      (if (or (not (symb? Y)) (nil? Y))
         Y
         (let
            (N (if (atom X) 0 (evCnt Exe X))
               P (push 0 (xName Exe Y) NIL)  # [cnt name link]
               Q (link (ofs P 1) T)
               R (push 4 NIL ZERO NIL)  # [cnt last name link]
               C T )
            (link (ofs R 2))
            (while (setq C (symChar P))
               (when (isLetterOrDigit C)
                  (charSym (toLowerCase C) R)
                  (? (=0 (dec 'N))) ) )
            (consStr (val 3 R)) ) ) ) )