picolisp

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

lib.l (3946B)

      1 # 05jul13abu
      2 # (c) Software Lab. Alexander Burger
      3 
      4 ### task ###
      5 (test (3 . 4)
      6    (let (*Run NIL  *A NIL  *B NIL)
      7       (task -10 0 (setq *A 3))
      8       (task (port T 0 "TaskPort") (eval (udp @)))
      9       (udp "localhost" "TaskPort" '(setq *B 4))
     10       (wait NIL (and *A *B))
     11       (cons *A *B) ) )
     12 
     13 
     14 ### timeout ###
     15 (test '((-1 3600000 (bye)))
     16    (let *Run NIL
     17       (timeout 3600000)
     18       *Run ) )
     19 
     20 
     21 ### abort ###
     22 (test 6 (abort 2 (+ 1 2 3)))
     23 (test NIL (abort 2 (wait 4000)))
     24 
     25 
     26 ### macro ###
     27 (test 6
     28    (let (@A 1  @B 2  @C 3)
     29       (macro (* @A @B @C)) ) )
     30 
     31 
     32 ### later ###
     33 (test '((@ . 1) (@ . 4) (@ . 9) (@ . 16) (@ . 25) (@ . 36))
     34    (prog1
     35       (mapcan
     36          '((N) (later (cons) (cons *Pid (* N N))))
     37          (1 2 3 4 5 6) )
     38       (wait NIL (full @)) ) )
     39 
     40 
     41 ### recur recurse ###
     42 (test 720
     43    (let N 6
     44       (recur (N)
     45          (if (=0 N)
     46             1
     47             (* N (recurse (dec N))) ) ) ) )
     48 
     49 
     50 ### curry ###
     51 (test '((N) (* 7 N))
     52    ((quote (@X) (curry (@X) (N) (* @X N))) 7) )
     53 (test 21
     54    (((quote (@X) (curry (@X) (N) (* @X N))) 7) 3) )
     55 (test '((N) (job '((A . 1)) (+ A 7 N)))
     56    (let (A 1 @X 7) (curry (A @X) (N) (+ A @X N))) )
     57 
     58 
     59 ### getd ###
     60 (test car (getd 'car))
     61 (test '((File . @) (load File))
     62    (getd 'script) )
     63 (test NIL (getd 1))
     64 
     65 
     66 ### expr subr undef ###
     67 (let foo car
     68    (test 7 (foo (7)))
     69    (test T (== 'pass (caadr (expr 'foo))))
     70    (test car (subr 'foo))
     71    (test car (undef 'foo))
     72    (test NIL (val 'foo)) )
     73 
     74 
     75 ### redef ###
     76 (let foo inc
     77    (redef foo (N) (inc (foo N)))
     78    (test 3 (foo 1)) )
     79 
     80 
     81 ### daemon patch ###
     82 (let foo car
     83    (daemon 'foo (msg 'daemon))
     84    (test T (= '(msg 'daemon) (cadr (getd 'foo))))
     85    (patch foo 'daemon 'patch)
     86    (test T (= '(msg 'patch) (cadr (getd 'foo)))) )
     87 
     88 
     89 ### scl ###
     90 (scl 0)
     91 (test 123 (any "123.45"))
     92 (scl 1)
     93 (test (1235) (scl 1 (str "123.45")))
     94 (test 1235 (any "123.45"))
     95 (scl 3)
     96 (test 123450 (any "123.45"))
     97 
     98 
     99 ### script ###
    100 (out (tmp "script")
    101    (println '(pass * 7)) )
    102 (test 42 (script (tmp "script") 2 3))
    103 
    104 
    105 ### once ###
    106 (let N 0
    107    (test 1
    108       (once (inc 'N))
    109       (once (inc 'N))
    110       N ) )
    111 
    112 
    113 ### rc ###
    114 (let F (tmp "rc")
    115    (rc F 'a 123)
    116    (rc F 'b "test")
    117    (rc F 'c (1 2 3))
    118    (test '((c 1 2 3) (b . "test") (a . 123))
    119       (in F (read)) )
    120    (test 123 (rc F 'a))
    121    (test "test" (rc F 'b))
    122    (test (1 2 3) (rc F 'c)) )
    123 
    124 
    125 ### acquire release ###
    126 (let F (tmp "sema")
    127    (test *Pid (acquire F))
    128    (test T (acquire F))
    129    (test *Pid (in F (rd)))
    130    (test NIL (release F))
    131    (test NIL (in F (rd))) )
    132 
    133 
    134 ### insert ###
    135 (test '(a b 777 c d e) (insert 3 '(a b c d e) 777))
    136 (test (777 a b c d e) (insert 1 '(a b c d e) 777))
    137 (test '(a b c d e 777) (insert 9 '(a b c d e) 777))
    138 
    139 
    140 ### remove ###
    141 (test '(a b d e) (remove 3 '(a b c d e)))
    142 (test '(b c d e) (remove 1 '(a b c d e)))
    143 (test '(a b c d e) (remove 9 '(a b c d e)))
    144 
    145 
    146 ### place ###
    147 (test '(a b 777 d e) (place 3 '(a b c d e) 777))
    148 (test (777 b c d e) (place 1 '(a b c d e) 777))
    149 (test '(a b c d e 777) (place 9 '(a b c d e) 777))
    150 
    151 
    152 ### uniq ###
    153 (test (2 4 6 1 3 5) (uniq (2 4 6 1 2 3 4 5 6 1 3 5)))
    154 
    155 
    156 ### group ###
    157 (test '((1 a b c) (2 d e f))
    158    (group '((1 . a) (1 . b) (1 . c) (2 . d) (2 . e) (2 . f))) )
    159 
    160 
    161 ### qsym ###
    162 (let "A" 1234
    163    (put '"A" 'a 1)
    164    (put '"A" 'b 2)
    165    (put '"A" 'f T)
    166    (test (1234 f (2 . b) (1 . a))
    167       (qsym . "A") ) )
    168 
    169 ### loc ###
    170 (let (X 'foo  bar '((A B) (foo B A)))
    171    (test "foo" (zap 'foo))
    172    (test "foo" (str? "foo"))
    173    (test T (== X (loc "foo" bar))) )
    174 
    175 
    176 ### class ###
    177 (off "+A" "+B" "+C")
    178 (test '"+A" (class "+A" "+B" "+C"))
    179 (test '"+A" *Class)
    180 (test '("+B" "+C") "+A")
    181 
    182 
    183 ### object ###
    184 (off "Obj")
    185 (test '"Obj"
    186    (object '"Obj" '("+A" "+B" "+C")  'a 1 'b 2 'c 3) )
    187 (test '((3 . c) (2 . b) (1 . a) (@X . *Dbg))
    188    (getl '"Obj") )
    189 
    190 
    191 ### extend var var: ###
    192 (test '"+B" (extend "+B"))
    193 (test T (== *Class '"+B"))
    194 
    195 (test 1 (var a . 1))
    196 (test 2 (var b . 2))
    197 (test '((2 . b) (1 . a)) (getl '"+B"))
    198 
    199 (with '"Obj"
    200    (test 1 (var: a))
    201    (test 2 (var: b)) )
    202 
    203 # vi:et:ts=3:sw=3