sym.l

A very small LISP implementation with several packages and demo programs.

# 10dec07abu
# (c) Software Lab. Alexander Burger

### name ###
(test "abc" (name 'abc))
(test "abc" (name '{abc}))
(let X (box)
   (test NIL (name X))
   (name X "xxx")
   (test "xxx" (name X)) )


### sp? ###
(test T (sp? " ^I^J"))
(test NIL (sp? " abc"))
(test NIL (sp? 123))


### pat? ###
(test `(char '@) (char (pat? '@)))
(test NIL (pat? "ABC"))
(test NIL (pat? 123))


### fun? ###
(test 1000000000 (fun? 1000000000))
(test NIL (fun? 100000000000000))
(test NIL (fun? 1000000001))
(test '(A B) (fun? '((A B) (* A B))))
(test NIL (fun? '((A B) (* A B) . C)))
(test NIL (fun? (1 2 3 4)))
(test NIL (fun? '((A 2 B) (* A B))))
(test T (fun? '(NIL (* 3 4))))


### all ###
(test '(test)
   (filter '((S) (= S "test")) (all)) )


### intern ###
(test car (val (intern (pack "c" "a" "r"))))


### extern ###
(test NIL (extern (box)))
(test *DB (extern "1"))


### ==== ###
(setq *Sym "abc")
(test T (== *Sym "abc"))
(====)
(test NIL (== *Sym "abc"))


### box? ###
(let X (box)
   (test X (box? X)) )
(test NIL (box? 123))
(test NIL (box? 'a))
(test NIL (box? NIL))


### str? ###
(test NIL (str? 123))
(test NIL (str? '{ABC}))
(test NIL (str? 'abc))
(test "abc" (str? "abc"))


### ext? ###
(test *DB (ext? *DB))
(test NIL (ext? 'abc))
(test NIL (ext? "abc"))
(test NIL (ext? 123))


### touch ###
(test *DB (touch *DB))
(rollback)


### zap ###
(test "abc" (str? (zap 'abc)))


### chop ###
(test '("c" "a" "r") (chop 'car)))
(test '("H" "e" "l" "l" "o") (chop "Hello"))
(test '("1" "2" "3") (chop 123))
(test (1 2 3) (chop (1 2 3)))
(test NIL (chop NIL))


### pack ###
(test "car is 1 symbol name"
   (pack 'car " is " 1 '(" symbol " name)) )


### glue ###
(test 1 (glue NIL 1))
(test "a" (glue NIL '(a)))
(test "ab" (glue NIL '(a b)))
(test "a,b" (glue "," '(a b)))
(test "a8b" (glue 8 '(a b)))
(test "a123b123c" (glue (1 2 3) '(a b c)))


### text ###
(test "abc XYZ def 123" (text "abc @1 def @2" 'XYZ 123))
(test "aXYZz" (text "a@3z" 1 2 '(X Y Z)))
(test "[e-mail]" (text "a@@bc.@1" "de"))
(test "10.11.12" (text "@A.@B.@C" 1 2 3 4 5 6 7 8 9 10 11 12))


### pre? ###
(test T (pre? "abc" "abcdef")))
(test NIL (pre? "def" "abcdef"))
(test T (pre? "" "abcdef"))


### sub? ###
(test T (sub? "def" "abcdef"))
(test NIL (sub? "abb" "abcdef"))
(test T (sub? "" "abcdef"))


### val ###
(let L '(a b c)
   (test '(a b c) (val 'L))
   (test 'b (val (cdr L))) )


### set ###
(use L
   (test '(a b c) (set 'L '(a b c)))
   (test 999 (set (cdr L) '999))
   (test '(a 999 c) L) )


### setq ###
(use (A B)
   (test (123 123)
      (setq  A 123  B (list A A)) )
   (test 123 A)
   (test (123 123) B) )


### xchg ###
(let (A 1  B 2  C '(a b c))
   (test 2 (xchg 'A C  'B (cdr C)))
   (test 'a A)
   (test 'b B)
   (test (1 2 c) C) )


### on off onOff zero one ###
(use (A B)
   (test T (on A B))
   (test T A)
   (test T B)
   (test NIL (off A))
   (test NIL A)
   (test NIL (onOff B))
   (test NIL B)
   (test T (onOff A B))
   (test T A)
   (test T B)
   (test 0 (zero A B))
   (test 0 A)
   (test 0 B)
   (test 1 (one A B))
   (test 1 A)
   (test 1 B) )


### default ###
(let (A NIL  B NIL)
   (test 2 (default A 1  B 2))
   (test A 1)
   (test B 2)
   (test 2 (default A 7  B 8))
   (test A 1)
   (test B 2) )


### push push1 pop cut ###
(let L NIL
   (test 1 (push 'L 3 2 1))
   (test L (1 2 3))
   (test 0 (push1 'L 0))
   (test 1 (push1 'L 1))
   (test L (0 1 2 3))
   (test 0 (pop 'L))
   (test (1 2) (cut 2 'L))
   (test (3) L) )


### del ###
(let L '((a b c) (d e f))
   (test '((a b c)) (del '(d e f) 'L))
   (test '(a c) (del 'b L)) )


### queue ###
(let A NIL
   (test 1 (queue 'A 1))
   (test 2 (queue 'A 2))
   (test 3 (queue 'A 3))
   (test (1 2 3) A) )


### fifo ###
(let X NIL
   (test 1 (fifo 'X 1))
   (test 3 (fifo 'X 2 3))
   (test 1 (fifo 'X))
   (test 2 (fifo 'X))
   (test 3 (fifo 'X)) )


### idx lup ###
(let X NIL
   (test NIL (idx 'X 'd T))
   (test NIL (idx 'X (2 . f) T))
   (test NIL (idx 'X (3 . g) T))
   (test NIL (idx 'X '(a b c) T))
   (test NIL (idx 'X 17 T))
   (test NIL (idx 'X 'A T))
   (test '(d . @) (idx 'X 'd T))
   (test NIL (idx 'X T T))
   (test '(A) (idx 'X 'A))
   (test '(17 A d (2 . f) (3 . g) (a b c) T)
      (idx 'X) )
   (test (2 . f) (lup X 2))
   (test '((2 . f) (3 . g)) (lup X 1 4))
   (test '(17 . @) (idx 'X 17 NIL))
   (test '(A d (2 . f) (3 . g) (a b c) T)
      (idx 'X) ) )


### put get prop =: : :: putl getl ###
(let (A (box)  B (box A)  C (box (cons A B)))
   (put B 'a A)
   (put C 'b B)
   (put A 'x 1)
   (put B 'a 'y 2)
   (put C 0 -1 'a 'z 3)
   (test 1 (get A 'x))
   (test 2 (with A (: y)))
   (test 2 (get A 'y))
   (test 2 (with B (: 0 y)))
   (test 2 (get 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 . 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))) (getl C 'b 0)) )

(test NIL (get (1 2 3) 0))
(test 1 (get (1 2 3) 1))
(test 3 (get (1 2 3) 3))
(test NIL (get (1 2 3) 4))
(test (3) (get (1 2 3) -2))
(test 1 (get '((a (b . 1) (c . 2)) (d (e . 3) (f . 4))) 'a 'b))
(test 4 (get '((a (b . 1) (c . 2)) (d (e . 3) (f . 4))) 'd 'f))


### wipe ###
(let X (box (1 2 3 4))
   (put X 'a 1)
   (put X 'b 2)
   (test (1 2 3 4) (val X))
   (test '((2 . b) (1 . a)) (getl X))
   (wipe X)
   (test NIL (val X))
   (test NIL (getl X)) )

(setq "W" (1 2 3 4))
(put '"W" 'a 1)
(put '"W" 'b 2)
(test (1 2 3 4) "W")
(test '((2 . b) (1 . a)) (getl '"W"))
(wipe '"W")
(test NIL "W")
(test NIL (getl '"W"))

(set *DB (1 2 3 4))
(put *DB 'a 1)
(put *DB 'b 2)
(test (1 2 3 4) (val *DB))
(test '((2 . b) (1 . a)) (getl *DB))
(wipe *DB)
(test (1 2 3 4) (val *DB))
(test '((2 . b) (1 . a)) (getl *DB))
(rollback)
(test NIL "W")
(test NIL (getl '"W"))


### meta ###
(let A '("B")
   (put '"B" 'a 123)
   (test 123 (meta 'A 'a)) )


### low? ###
(test "a" (low? "a"))
(test NIL (low? "A"))
(test NIL (low? 123))
(test NIL (low? "."))


### upp? ###
(test "A" (upp? "A"))
(test NIL (upp? "a"))
(test NIL (upp? 123))
(test NIL (upp? "."))


### lowc ###
(test "abc" (lowc "ABC"))
(test "盲枚眉" (lowc "脛脰脺"))
(test "盲枚眉" (lowc "盲枚眉"))
(test 123 (lowc 123))


### uppc ###
(test "ABC" (uppc "abc"))
(test "脛脰脺" (uppc "盲枚眉"))
(test "脛脰脺" (uppc "脛脰脺"))
(test 123 (lowc 123))


### fold ###
(test "1a2b3" (fold " 1A 2-b/3"))
(test "1a2" (fold " 1A 2-B/3" 3))

# vi:et:ts=3:sw=3