← Back to branch summary

~ubuntu-branches/debian/sid/picolisp/sid

« back to all changes in this revision

Viewing changes to .pc/picolisp_sync_to_tip.patch/ersatz/lib.l

  • Committer: Package Import Robot
  • Author(s): Kan-Ru Chen
  • Date: 2011-11-13 17:15:44 UTC
  • mfrom: (1.1.14)
  • Revision ID: package-import@ubuntu.com-20111113171544-04gkr7r0lzmngt0u
Tags: 3.0.8.7-1
New upstream release.

Show diffs side-by-side

added added

removed removed

Lines of Context:
.pc/picolisp_sync_to_tip.patch/ersatz/lib.l
 
1
# 09oct11abu
 
2
# (c) Software Lab. Alexander Burger
 
3
 
 
4
(setq *OS (java (java "java.lang.System" "getProperty" "os.name")))
 
5
 
 
6
############ lib.l ############
 
7
 
 
8
(de task (Key . Prg)
 
9
   (nond
 
10
      (Prg (del (assoc Key *Run) '*Run))
 
11
      ((num? Key) (quit "Bad Key" Key))
 
12
      ((assoc Key *Run)
 
13
         (push '*Run
 
14
            (conc
 
15
               (make
 
16
                  (when (lt0 (link Key))
 
17
                     (link (+ (eval (pop 'Prg) 1))) ) )
 
18
               (ifn (sym? (car Prg))
 
19
                  Prg
 
20
                  (cons
 
21
                     (cons 'job
 
22
                        (cons
 
23
                           (lit
 
24
                              (make
 
25
                                 (while (atom (car Prg))
 
26
                                    (link
 
27
                                       (cons (pop 'Prg) (eval (pop 'Prg) 1)) ) ) ) )
 
28
                           Prg ) ) ) ) ) ) )
 
29
      (NIL (quit "Key conflict" Key)) ) )
 
30
 
 
31
(de timeout (N)
 
32
   (if2 N (assoc -1 *Run)
 
33
      (set (cdr @) (+ N))
 
34
      (push '*Run (list -1 (+ N) '(bye)))
 
35
      (del @ '*Run) ) )
 
36
 
 
37
(de macro "Prg"
 
38
   (run (fill "Prg")) )
 
39
 
 
40
(de recur recurse
 
41
   (run (cdr recurse)) )
 
42
 
 
43
(de curry "Z"
 
44
   (let ("X" (pop '"Z")  "Y" (pop '"Z")  "P" (filter pat? "X"))
 
45
      (if2 "P" (diff "X" "P")
 
46
         (list "Y" (cons 'job (lit (env @)) (fill "Z" "P")))
 
47
         (cons "Y" (fill "Z" "P"))
 
48
         (list "Y" (cons 'job (lit (env @)) "Z"))
 
49
         (cons "Y" "Z") ) ) )
 
50
 
 
51
(====)
 
52
 
 
53
### Definitions ###
 
54
(de expr ("F")
 
55
   (set "F"
 
56
      (list '@ (list 'pass (box (getd "F")))) ) )
 
57
 
 
58
(de subr ("F")
 
59
   (set "F"
 
60
      (getd (cadr (cadr (getd "F")))) ) )
 
61
 
 
62
(de undef ("X" "C")
 
63
   (when (pair "X")
 
64
      (setq  "C" (cdr "X")  "X" (car "X")) )
 
65
   (ifn "C"
 
66
      (prog1 (val "X") (set "X"))
 
67
      (prog1
 
68
         (cdr (asoq "X" (val "C")))
 
69
         (set "C"
 
70
            (delq (asoq "X" (val "C")) (val "C")) ) ) ) )
 
71
 
 
72
(de redef "Lst"
 
73
   (let ("Old" (car "Lst")  "New" (name "Old"))
 
74
      (set
 
75
         "New" (getd "Old")
 
76
         "Old" "New"
 
77
         "Old" (fill (cdr "Lst") "Old") )
 
78
      "New" ) )
 
79
 
 
80
(de daemon ("X" . Prg)
 
81
   (prog1
 
82
      (nond
 
83
         ((pair "X")
 
84
            (or (pair (getd "X")) (expr "X")) )
 
85
         ((pair (cdr "X"))
 
86
            (method (car "X") (cdr "X")) )
 
87
         (NIL
 
88
            (method (car "X") (get (or (cddr "X") *Class) (cadr "X"))) ) )
 
89
      (con @ (append Prg (cdr @))) ) )
 
90
 
 
91
(de patch ("Lst" "Pat" . "Prg")
 
92
   (bind (fish pat? "Pat")
 
93
      (recur ("Lst")
 
94
         (loop
 
95
            (cond
 
96
               ((match "Pat" (car "Lst"))
 
97
                  (set "Lst" (run "Prg")) )
 
98
               ((pair (car "Lst"))
 
99
                  (recurse @) ) )
 
100
            (NIL (cdr "Lst"))
 
101
            (T (atom (cdr "Lst"))
 
102
               (when (match "Pat" (cdr "Lst"))
 
103
                  (con "Lst" (run "Prg")) ) )
 
104
            (setq "Lst" (cdr "Lst")) ) ) ) )
 
105
 
 
106
(====)
 
107
 
 
108
(de cache ("Var" "Str" . Prg)
 
109
   (nond
 
110
      ((setq "Var" (car (idx "Var" "Str" T)))
 
111
         (set "Str" "Str"  "Str" (run Prg 1)) )
 
112
      ((n== "Var" (val "Var"))
 
113
         (set "Var" (run Prg 1)) )
 
114
      (NIL (val "Var")) ) )
 
115
 
 
116
(====)
 
117
 
 
118
### I/O ###
 
119
(de tab (Lst . @)
 
120
   (for N Lst
 
121
      (let V (next)
 
122
         (and (gt0 N) (space (- N (length V))))
 
123
         (prin V)
 
124
         (and (lt0 N) (args) (space (- 0 N (length V)))) ) )
 
125
   (prinl) )
 
126
 
 
127
(de beep ()
 
128
   (prin "^G") )
 
129
 
 
130
(de msg (X . @)
 
131
   (out 2
 
132
      (print X)
 
133
      (pass prinl)
 
134
      (flush) )
 
135
   X )
 
136
 
 
137
(de script (File . @)
 
138
   (load File) )
 
139
 
 
140
(de once Prg
 
141
   (unless (idx '*Once (file) T)
 
142
      (run Prg 1) ) )
 
143
 
 
144
(de pil @
 
145
   (when (== "Pil" '"Pil")
 
146
      (call 'mkdir "-p" (setq "Pil" `(pack (sys "HOME") "/.pil/"))) )
 
147
   (pass pack "Pil") )
 
148
 
 
149
# Temporary Files
 
150
(de tmp @
 
151
   (unless *Tmp
 
152
      (push '*Bye '(call 'rm "-r" *Tmp))
 
153
      (call 'mkdir "-p" (setq *Tmp (pil "tmp/" *Pid "/"))) )
 
154
   (pass pack *Tmp) )
 
155
 
 
156
### List ###
 
157
(de insert (N Lst X)
 
158
   (conc
 
159
      (cut (dec N) 'Lst)
 
160
      (cons X)
 
161
      Lst ) )
 
162
 
 
163
(de remove (N Lst)
 
164
   (conc
 
165
      (cut (dec N) 'Lst)
 
166
      (cdr Lst) ) )
 
167
 
 
168
(de place (N Lst X)
 
169
   (conc
 
170
      (cut (dec N) 'Lst)
 
171
      (cons X)
 
172
      (cdr Lst) ) )
 
173
 
 
174
(de uniq (Lst)
 
175
   (let R NIL
 
176
      (filter
 
177
         '((X) (not (idx 'R X T)))
 
178
         Lst ) ) )
 
179
 
 
180
(de group (Lst)
 
181
   (make
 
182
      (for X Lst
 
183
         (if (assoc (car X) (made))
 
184
            (conc @ (cons (cdr X)))
 
185
            (link (list (car X) (cdr X))) ) ) ) )
 
186
 
 
187
### Symbol ###
 
188
(de qsym "Sym"
 
189
   (cons (val "Sym") (getl "Sym")) )
 
190
 
 
191
(de loc (S X)
 
192
   (if (and (str? X) (= S X))
 
193
      X
 
194
      (and
 
195
         (pair X)
 
196
         (or
 
197
            (loc S (car X))
 
198
            (loc S (cdr X)) ) ) ) )
 
199
 
 
200
### OOP ###
 
201
(de class Lst
 
202
   (let L (val (setq *Class (car Lst)))
 
203
      (def *Class
 
204
         (recur (L)
 
205
            (if (atom (car L))
 
206
               (cdr Lst)
 
207
               (cons (car L) (recurse (cdr L))) ) ) ) ) )
 
208
 
 
209
(de object ("Sym" "Val" . @)
 
210
   (def "Sym" "Val")
 
211
   (putl "Sym")
 
212
   (while (args)
 
213
      (put "Sym" (next) (next)) )
 
214
   "Sym" )
 
215
 
 
216
(de extend X
 
217
   (setq *Class (car X)) )
 
218
 
 
219
# Class variables
 
220
(de var X
 
221
   (put *Class (car X) (cdr X)) )
 
222
 
 
223
(de var: X
 
224
   (apply meta X This) )
 
225
 
 
226
### Math ###
 
227
(de scl (N)
 
228
   (setq *Scl N) )
 
229
 
 
230
(de sqrt (N F)
 
231
   (cond
 
232
      ((lt0 N) (quit "Bad argument" N))
 
233
      (N
 
234
         (let (A 1  B 0)
 
235
            (while (>= N A)
 
236
               (setq A (>> -2 A)) )
 
237
            (loop
 
238
               (if (> (inc 'B A) N)
 
239
                  (dec 'B A)
 
240
                  (dec 'N B)
 
241
                  (inc 'B A) )
 
242
               (setq B (>> 1 B)  A (>> 2 A))
 
243
               (T (=0 A)) )
 
244
            (and F (> N B) (inc 'B))
 
245
            B ) ) ) )
 
246
 
 
247
# (Knuth Vol.2, p.442)
 
248
(de ** (X N)  # N th power of X
 
249
   (let Y 1
 
250
      (loop
 
251
         (when (bit? 1 N)
 
252
            (setq Y (* Y X)) )
 
253
         (T (=0 (setq N (>> 1 N)))
 
254
            Y )
 
255
         (setq X (* X X)) ) ) )
 
256
 
 
257
(de accu (Var Key Val)
 
258
   (when Val
 
259
      (if (assoc Key (val Var))
 
260
         (con @ (+ Val (cdr @)))
 
261
         (push Var (cons Key Val)) ) ) )
 
262
 
 
263
### Pretty Printing ###
 
264
(de *PP
 
265
   T NIL if ifn when unless while until do case state for
 
266
   with catch finally ! setq default push job use let let?
 
267
   prog1 recur redef =: in out tab new )
 
268
(de *PP1 let let? for redef)
 
269
(de *PP2 setq default)
 
270
(de *PP3 if2)
 
271
 
 
272
(de pretty (X N . @)
 
273
   (setq N (abs (space (or N 0))))
 
274
   (while (args)
 
275
      (printsp (next)) )
 
276
   (if (or (atom X) (>= 12 (size X)))
 
277
      (print X)
 
278
      (while (== 'quote (car X))
 
279
         (prin "'")
 
280
         (pop 'X) )
 
281
      (let Z X
 
282
         (prin "(")
 
283
         (cond
 
284
            ((memq (print (pop 'X)) *PP)
 
285
               (cond
 
286
                  ((memq (car Z) *PP1)
 
287
                     (if (and (pair (car X)) (pair (cdar X)))
 
288
                        (when (>= 12 (size (car X)))
 
289
                           (space)
 
290
                           (print (pop 'X)) )
 
291
                        (space)
 
292
                        (print (pop 'X))
 
293
                        (when (or (atom (car X)) (>= 12 (size (car X))))
 
294
                           (space)
 
295
                           (print (pop 'X)) ) ) )
 
296
                  ((memq (car Z) *PP2)
 
297
                     (inc 'N 3)
 
298
                     (loop
 
299
                        (prinl)
 
300
                        (pretty (cadr X) N (car X))
 
301
                        (NIL (setq X (cddr X)) (space)) ) )
 
302
                  ((or (atom (car X)) (>= 12 (size (car X))))
 
303
                     (space)
 
304
                     (print (pop 'X)) ) ) )
 
305
            ((and (memq (car Z) *PP3) (>= 12 (size (head 2 X))))
 
306
               (space)
 
307
               (print (pop 'X) (pop 'X)) ) )
 
308
         (when X
 
309
            (loop
 
310
               (T (== Z X) (prin " ."))
 
311
               (T (atom X) (prin " . ") (print X))
 
312
               (prinl)
 
313
               (pretty (pop 'X) (+ 3 N))
 
314
               (NIL X) )
 
315
            (space) )
 
316
         (prin ")") ) ) )
 
317
 
 
318
(de pp ("X" C)
 
319
   (let *Dbg NIL
 
320
      (and (pair "X") (setq C (cdr "X")))
 
321
      (prin "(")
 
322
      (printsp (if C 'dm 'de))
 
323
      (prog1 (printsp "X")
 
324
         (setq "X"
 
325
            (if C
 
326
               (method (if (pair "X") (car "X") "X") C)
 
327
               (val "X") ) )
 
328
         (cond
 
329
            ((atom "X") (prin ". ") (print "X"))
 
330
            ((atom (cdr "X"))
 
331
               (ifn (cdr "X")
 
332
                  (print (car "X"))
 
333
                  (print (car "X"))
 
334
                  (prin " . ")
 
335
                  (print @) ) )
 
336
            (T
 
337
               (let Z "X"
 
338
                  (print (pop '"X"))
 
339
                  (loop
 
340
                     (T (== Z "X") (prin " ."))
 
341
                     (NIL "X")
 
342
                     (T (atom "X")
 
343
                        (prin " . ")
 
344
                        (print "X") )
 
345
                     (prinl)
 
346
                     (pretty (pop '"X") 3) )
 
347
                  (space) ) ) )
 
348
         (prinl ")") ) ) )
 
349
 
 
350
(de show ("X" . @)
 
351
   (let *Dbg NIL
 
352
      (setq "X" (pass get "X"))
 
353
      (when (sym? "X")
 
354
         (print "X" (val "X"))
 
355
         (prinl)
 
356
         (maps
 
357
            '((X)
 
358
               (space 3)
 
359
               (if (atom X)
 
360
                  (println X)
 
361
                  (println (cdr X) (car X)) ) )
 
362
            "X" ) )
 
363
      "X" ) )
 
364
 
 
365
(de view (X Y)
 
366
   (let *Dbg NIL
 
367
      (if (=T Y)
 
368
         (let N 0
 
369
            (recur (N X)
 
370
               (when X
 
371
                  (recurse (+ 3 N) (cddr X))
 
372
                  (space N)
 
373
                  (println (car X))
 
374
                  (recurse (+ 3 N) (cadr X)) ) ) )
 
375
         (let Z X
 
376
            (loop
 
377
               (T (atom X) (println X))
 
378
               (if (atom (car X))
 
379
                  (println '+-- (pop 'X))
 
380
                  (print '+---)
 
381
                  (view
 
382
                     (pop 'X)
 
383
                     (append Y (cons (if X "|   " "    "))) ) )
 
384
               (NIL X)
 
385
               (mapc prin Y)
 
386
               (T (== Z X) (println '*))
 
387
               (println '|)
 
388
               (mapc prin Y) ) ) ) ) )
 
389
 
 
390
### Assertions ###
 
391
(de assert Prg
 
392
   (when *Dbg
 
393
      (cons
 
394
         (list 'unless
 
395
            (if (cdr Prg) (cons 'and Prg) (car Prg))
 
396
            (list 'quit "'assert' failed" (lit (car Prg))) ) ) ) )
 
397
 
 
398
############ lib/misc.l ############
 
399
 
 
400
# *Allow *Tmp
 
401
 
 
402
(de *Day . (Mon Tue Wed Thu Fri Sat Sun .))
 
403
(de *Mon . (Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec .))
 
404
(de *mon . (jan feb mar apr may jun jul aug sep oct nov dec .))
 
405
 
 
406
### Locale ###
 
407
(de *Ctry)
 
408
(de *Lang)
 
409
(de *Sep0 . ".")
 
410
(de *Sep3 . ",")
 
411
(de *CtryCode)
 
412
(de *DateFmt @Y "-" @M "-" @D)
 
413
(de *DayFmt "Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday" "Sunday")
 
414
(de *MonFmt "January" "February" "March" "April" "May" "June" "July" "August" "September" "October" "November" "December")
 
415
 
 
416
(de locale (Ctry Lang App)  # "DE" "de" ["app/loc/"]
 
417
   (load (if (setq *Ctry Ctry) (pack "@loc/" @ ".l") "@loc/NIL.l"))
 
418
   (ifn (setq *Lang Lang)
 
419
      (for S (idx '*Uni)
 
420
         (set S S) )
 
421
      (let L
 
422
         (sort
 
423
            (make
 
424
               ("loc" (pack "@loc/" Lang))
 
425
               (and App ("loc" (pack App Lang))) ) )
 
426
         (balance '*Uni L T)
 
427
         (for S L
 
428
            (set (car (idx '*Uni S)) (val S)) ) ) ) )
 
429
 
 
430
(de "loc" (F)
 
431
   (in F
 
432
      (use X
 
433
         (while (setq X (read))
 
434
            (if (=T X)
 
435
               ("loc" (read))
 
436
               (set (link @) (name (read))) ) ) ) ) )
 
437
 
 
438
### String ###
 
439
(de align (X . @)
 
440
   (pack
 
441
      (if (pair X)
 
442
         (mapcar
 
443
            '((X) (need X (chop (next)) " "))
 
444
            X )
 
445
         (need X (chop (next)) " ") ) ) )
 
446
 
 
447
(de center (X . @)
 
448
   (pack
 
449
      (if (pair X)
 
450
         (let R 0
 
451
            (mapcar
 
452
               '((X)
 
453
                  (let (S (chop (next))  N (>> 1 (+ X (length S))))
 
454
                     (prog1
 
455
                        (need (+ N R) S " ")
 
456
                        (setq R (- X N)) ) ) )
 
457
               X ) )
 
458
         (let S (chop (next))
 
459
            (need (>> 1 (+ X (length S))) S " ") ) ) ) )
 
460
 
 
461
(de wrap (Max Lst)
 
462
   (setq Lst (split Lst " " "^J"))
 
463
   (pack
 
464
      (make
 
465
         (while Lst
 
466
            (if (>= (length (car Lst)) Max)
 
467
               (link (pop 'Lst) "^J")
 
468
               (chain
 
469
                  (make
 
470
                     (link (pop 'Lst))
 
471
                     (loop
 
472
                        (NIL Lst)
 
473
                        (T (>= (+ (length (car Lst)) (sum length (made))) Max)
 
474
                           (link "^J") )
 
475
                        (link " " (pop 'Lst)) ) ) ) ) ) ) ) )
 
476
 
 
477
### Number ###
 
478
(de pad (N Val)
 
479
   (pack (need N (chop Val) "0")) )
 
480
 
 
481
(de money (N Cur)
 
482
   (if Cur
 
483
      (pack (format N 2 *Sep0 *Sep3) " " Cur)
 
484
      (format N 2 *Sep0 *Sep3) ) )
 
485
 
 
486
(de round (N D)
 
487
   (if (> *Scl (default D 3))
 
488
      (format (*/ N (** 10 (- *Scl D))) D *Sep0 *Sep3)
 
489
      (format N *Scl *Sep0 *Sep3) ) )
 
490
 
 
491
# Binary notation
 
492
(de bin (X I)
 
493
   (cond
 
494
      ((num? X)
 
495
         (let (S (and (lt0 X) '-)  L (& 1 X)  A (cons 0 I))
 
496
            (until (=0 (setq X (>> 1 X)))
 
497
               (at A (push 'L " "))
 
498
               (push 'L (& 1 X)) )
 
499
            (pack S L) ) )
 
500
      ((setq X (filter '((C) (not (sp? C))) (chop X)))
 
501
         (let (S (and (= '- (car X)) (pop 'X))  N 0)
 
502
            (for C X
 
503
               (setq N (| (format C) (>> -1 N))) )
 
504
            (if S (- N) N) ) ) ) )
 
505
 
 
506
# Octal notation
 
507
(de oct (X I)
 
508
   (cond
 
509
      ((num? X)
 
510
         (let (S (and (lt0 X) '-)  L (& 7 X)  A (cons 0 I))
 
511
            (until (=0 (setq X (>> 3 X)))
 
512
               (at A (push 'L " "))
 
513
               (push 'L (& 7 X)) )
 
514
            (pack S L) ) )
 
515
      ((setq X (filter '((C) (not (sp? C))) (chop X)))
 
516
         (let (S (and (= '- (car X)) (pop 'X))  N 0)
 
517
            (for C X
 
518
               (setq N (| (format C) (>> -3 N))) )
 
519
            (if S (- N) N) ) ) ) )
 
520
 
 
521
# Hexadecimal notation
 
522
(de hex (X I)
 
523
   (cond
 
524
      ((num? X)
 
525
         (let (S (and (lt0 X) '-)  L (hex1 X)  A (cons 0 I))
 
526
            (until (=0 (setq X (>> 4 X)))
 
527
               (at A (push 'L " "))
 
528
               (push 'L (hex1 X)) )
 
529
            (pack S L) ) )
 
530
      ((setq X (filter '((C) (not (sp? C))) (chop X)))
 
531
         (let (S (and (= '- (car X)) (pop 'X))  N 0)
 
532
            (for C X
 
533
               (setq C (- (char C) `(char "0")))
 
534
               (and (> C 9) (dec 'C 7))
 
535
               (and (> C 22) (dec 'C 32))
 
536
               (setq N (| C (>> -4 N))) )
 
537
            (if S (- N) N) ) ) ) )
 
538
 
 
539
(de hex1 (N)
 
540
   (let C (& 15 N)
 
541
      (and (> C 9) (inc 'C 7))
 
542
      (char (+ C `(char "0"))) ) )
 
543
 
 
544
### Tree ###
 
545
(de balance ("Var" "Lst" "Flg")
 
546
   (unless "Flg" (set "Var"))
 
547
   (let "Len" (length "Lst")
 
548
      (recur ("Lst" "Len")
 
549
         (unless (=0 "Len")
 
550
            (let ("N" (>> 1 (inc "Len"))  "L" (nth "Lst" "N"))
 
551
               (idx "Var" (car "L") T)
 
552
               (recurse "Lst" (dec "N"))
 
553
               (recurse (cdr "L") (- "Len" "N")) ) ) ) ) )
 
554
 
 
555
### Allow ###
 
556
(de allowed Lst
 
557
   (setq *Allow (cons NIL (car Lst)))
 
558
   (balance *Allow (sort (cdr Lst))) )
 
559
 
 
560
(de allow (X Flg)
 
561
   (nond
 
562
      (*Allow)
 
563
      (Flg (idx *Allow X T))
 
564
      ((member X (cdr *Allow))
 
565
         (conc *Allow (cons X)) ) )
 
566
   X )
 
567
 
 
568
### Telephone ###
 
569
(de telStr (S)
 
570
   (cond
 
571
      ((not S))
 
572
      ((and *CtryCode (pre? (pack *CtryCode " ") S))
 
573
         (pack 0 (cdddr (chop S))) )
 
574
      (T (pack "+" S)) ) )
 
575
 
 
576
(de expTel (S)
 
577
   (setq S
 
578
      (make
 
579
         (for (L (chop S) L)
 
580
            (ifn (sub? (car L) " -")
 
581
               (link (pop 'L))
 
582
               (let F NIL
 
583
                  (loop
 
584
                     (and (= '- (pop 'L)) (on F))
 
585
                     (NIL L)
 
586
                     (NIL (sub? (car L) " -")
 
587
                        (link (if F '- " ")) ) ) ) ) ) ) )
 
588
   (cond
 
589
      ((= "+" (car S)) (pack (cdr S)))
 
590
      ((head '("0" "0") S)
 
591
         (pack (cddr S)) )
 
592
      ((and *CtryCode (= "0" (car S)))
 
593
         (pack *CtryCode " " (cdr S)) ) ) )
 
594
 
 
595
### Date ###
 
596
# ISO date
 
597
(de dat$ (Dat C)
 
598
   (when (date Dat)
 
599
      (pack (car @) C (pad 2 (cadr @)) C (pad 2 (caddr @))) ) )
 
600
 
 
601
(de $dat (S C)
 
602
   (if C
 
603
      (and
 
604
         (= 3
 
605
            (length (setq S (split (chop S) C))) )
 
606
         (date
 
607
            (format (car S))               # Year
 
608
            (or (format (cadr S)) 0)       # Month
 
609
            (or (format (caddr S)) 0) ) )  # Day
 
610
      (and
 
611
         (format S)
 
612
         (date
 
613
            (/ @ 10000)       # Year
 
614
            (% (/ @ 100) 100) # Month
 
615
            (% @ 100) ) ) ) )
 
616
 
 
617
(de datSym (Dat)
 
618
   (when (date Dat)
 
619
      (pack
 
620
         (pad 2 (caddr @))
 
621
         (get *mon (cadr @))
 
622
         (pad 2 (% (car @) 100)) ) ) )
 
623
 
 
624
# Localized
 
625
(de datStr (D F)
 
626
   (when (setq D (date D))
 
627
      (let
 
628
         (@Y (if F (pad 2 (% (car D) 100)) (pad 4 (car D)))
 
629
            @M (pad 2 (cadr D))
 
630
            @D (pad 2 (caddr D)) )
 
631
         (pack (fill *DateFmt)) ) ) )
 
632
 
 
633
(de strDat (S)
 
634
   (use (@Y @M @D)
 
635
      (and
 
636
         (match *DateFmt (chop S))
 
637
         (date
 
638
            (format @Y)
 
639
            (or (format @M) 0)
 
640
            (or (format @D) 0) ) ) ) )
 
641
 
 
642
(de expDat (S)
 
643
   (use (@Y @M @D X)
 
644
      (unless (match *DateFmt (setq S (chop S)))
 
645
         (if
 
646
            (or
 
647
               (cdr (setq S (split S ".")))
 
648
               (>= 2 (length (car S))) )
 
649
            (setq
 
650
               @D (car S)
 
651
               @M (cadr S)
 
652
               @Y (caddr S) )
 
653
            (setq
 
654
               @D (head 2 (car S))
 
655
               @M (head 2 (nth (car S) 3))
 
656
               @Y (nth (car S) 5) ) ) )
 
657
      (and
 
658
         (setq @D (format @D))
 
659
         (date
 
660
            (nond
 
661
               (@Y (car (date (date))))
 
662
               ((setq X (format @Y)))
 
663
               ((>= X 100)
 
664
                  (+ X
 
665
                     (* 100 (/ (car (date (date))) 100)) ) )
 
666
               (NIL X) )
 
667
            (nond
 
668
               (@M (cadr (date (date))))
 
669
               ((setq X (format @M)) 0)
 
670
               ((n0 X) (cadr (date (date))))
 
671
               (NIL X) )
 
672
            @D ) ) ) )
 
673
 
 
674
# Day of the week
 
675
(de day (Dat Lst)
 
676
   (get
 
677
      (or Lst *DayFmt)
 
678
      (inc (% (inc Dat) 7)) ) )
 
679
 
 
680
# Week of the year
 
681
(de week (Dat)
 
682
   (let W
 
683
      (-
 
684
         (_week Dat)
 
685
         (_week (date (car (date Dat)) 1 4))
 
686
         -1 )
 
687
      (if (=0 W) 53 W) ) )
 
688
 
 
689
(de _week (Dat)
 
690
   (/ (- Dat (% (inc Dat) 7)) 7) )
 
691
 
 
692
# Last day of month
 
693
(de ultimo (Y M)
 
694
   (dec
 
695
      (if (= 12 M)
 
696
         (date (inc Y) 1 1)
 
697
         (date Y (inc M) 1) ) ) )
 
698
 
 
699
### Time ###
 
700
(de tim$ (Tim F)
 
701
   (when Tim
 
702
      (setq Tim (time Tim))
 
703
      (pack (pad 2 (car Tim)) ":" (pad 2 (cadr Tim))
 
704
         (and F ":")
 
705
         (and F (pad 2 (caddr Tim))) ) ) )
 
706
 
 
707
(de $tim (S)
 
708
   (setq S (split (chop S) ":"))
 
709
   (unless (or (cdr S) (>= 2 (length (car S))))
 
710
      (setq S
 
711
         (list
 
712
            (head 2 (car S))
 
713
            (head 2 (nth (car S) 3))
 
714
            (nth (car S) 5) ) ) )
 
715
   (when (format (car S))
 
716
      (time @
 
717
         (or (format (cadr S)) 0)
 
718
         (or (format (caddr S)) 0) ) ) )
 
719
 
 
720
(de stamp (Dat Tim)
 
721
   (and (=T Dat) (setq Dat (date T)))
 
722
   (default Dat (date)  Tim (time T))
 
723
   (pack (dat$ Dat "-") " " (tim$ Tim T)) )
 
724
 
 
725
 
 
726
(de dirname (F)
 
727
   (pack (flip (member '/ (flip (chop F))))) )
 
728
 
 
729
(de basename (F)
 
730
   (pack (stem (chop F) '/)) )
 
731
 
 
732
# Print or eval
 
733
(de prEval (Prg Ofs)
 
734
   (default Ofs 1)
 
735
   (for X Prg
 
736
      (if (atom X)
 
737
         (prinl (eval X Ofs))
 
738
         (eval X Ofs) ) ) )
 
739
 
 
740
# Echo here-documents
 
741
(de here (S)
 
742
   (line)
 
743
   (echo S) )
 
744
 
 
745
# Unit tests
 
746
(de test (Pat . Prg)
 
747
   (bind (fish pat? Pat)
 
748
      (unless (match Pat (run Prg 1))
 
749
         (msg Prg)
 
750
         (quit "'test' failed" Pat) ) ) )
 
751
 
 
752
############ lib/pilog.l ############
 
753
 
 
754
# *Rule
 
755
 
 
756
(de be CL
 
757
   (clause CL) )
 
758
 
 
759
(de clause (CL)
 
760
   (with (car CL)
 
761
      (if (== *Rule This)
 
762
         (=: T (conc (: T) (cons (cdr CL))))
 
763
         (=: T (cons (cdr CL)))
 
764
         (setq *Rule This) )
 
765
      This ) )
 
766
 
 
767
(de repeat ()
 
768
   (conc (get *Rule T) (get *Rule T)) )
 
769
 
 
770
(de asserta (CL)
 
771
   (with (car CL)
 
772
      (=: T (cons (cdr CL) (: T))) ) )
 
773
 
 
774
(de assertz (CL)
 
775
   (with (car CL)
 
776
      (=: T (conc (: T) (cons (cdr CL)))) ) )
 
777
 
 
778
(de retract (X)
 
779
   (if (sym? X)
 
780
      (put X T)
 
781
      (put (car X) T
 
782
         (delete (cdr X) (get (car X) T)) ) ) )
 
783
 
 
784
(de rules @
 
785
   (while (args)
 
786
      (let S (next)
 
787
         (for ((N . L) (get S T) L)
 
788
            (prin N " (be ")
 
789
            (print S)
 
790
            (for X (pop 'L)
 
791
               (space)
 
792
               (print X) )
 
793
            (prinl ")")
 
794
            (T (== L (get S T))
 
795
               (println '(repeat)) ) )
 
796
         S ) ) )
 
797
 
 
798
### Pilog Interpreter ###
 
799
(de goal ("CL" . @)
 
800
   (let "Env" '(T)
 
801
      (while (args)
 
802
         (push '"Env"
 
803
            (cons (cons 0 (next)) 1 (next)) ) )
 
804
      (while (and "CL" (pat? (car "CL")))
 
805
         (push '"Env"
 
806
            (cons
 
807
               (cons 0 (pop '"CL"))
 
808
               (cons 1 (eval (pop '"CL"))) ) ) )
 
809
      (cons
 
810
         (cons
 
811
            (conc (list 1 (0) NIL "CL" NIL) "Env") ) ) ) )
 
812
 
 
813
(de fail ()
 
814
   (goal '((NIL))) )
 
815
 
 
816
(de pilog ("CL" . "Prg")
 
817
   (for ("Q" (goal "CL") (prove "Q"))
 
818
      (bind @ (run "Prg")) ) )
 
819
 
 
820
(de solve ("CL" . "Prg")
 
821
   (make
 
822
      (if "Prg"
 
823
         (for ("Q" (goal "CL") (prove "Q"))
 
824
            (link (bind @ (run "Prg"))) )
 
825
         (for ("Q" (goal "CL") (prove "Q"))
 
826
            (link @) ) ) ) )
 
827
 
 
828
(de query ("Q" "Dbg")
 
829
   (use "R"
 
830
      (loop
 
831
         (NIL (prove "Q" "Dbg"))
 
832
         (T (=T (setq "R" @)) T)
 
833
         (for X "R"
 
834
            (space)
 
835
            (print (car X))
 
836
            (print '=)
 
837
            (print (cdr X))
 
838
            (flush) )
 
839
         (T (line)) ) ) )
 
840
 
 
841
(de ? "CL"
 
842
   (let "L"
 
843
      (make
 
844
         (while (nor (pat? (car "CL")) (lst? (car "CL")))
 
845
            (link (pop '"CL")) ) )
 
846
      (query (goal "CL") "L") ) )
 
847
 
 
848
### Basic Rules ###
 
849
(be repeat)
 
850
(repeat)
 
851
 
 
852
(be true)
 
853
 
 
854
(be not @P (1 -> @P) T (fail))
 
855
(be not @P)
 
856
 
 
857
(be call @P
 
858
   (2 cons (-> @P)) )
 
859
 
 
860
(be or @L (@C box (-> @L)) (_or @C))
 
861
 
 
862
(be _or (@C) (3 pop (-> @C)))
 
863
(be _or (@C) (@ not (val (-> @C))) T (fail))
 
864
(repeat)
 
865
 
 
866
(be nil (@X) (@ not (-> @X)))
 
867
 
 
868
(be equal (@X @X))
 
869
 
 
870
(be different (@X @X) T (fail))
 
871
(be different (@ @))
 
872
 
 
873
(be append (NIL @X @X))
 
874
(be append ((@A . @X) @Y (@A . @Z)) (append @X @Y @Z))
 
875
 
 
876
(be member (@X (@X . @)))
 
877
(be member (@X (@ . @Y)) (member @X @Y))
 
878
 
 
879
(be delete (@A (@A . @Z) @Z))
 
880
(be delete (@A (@X . @Y) (@X . @Z))
 
881
   (delete @A @Y @Z) )
 
882
 
 
883
(be permute ((@X) (@X)))
 
884
(be permute (@L (@X . @Y))
 
885
   (delete @X @L @D)
 
886
   (permute @D @Y) )
 
887
 
 
888
(be uniq (@B @X)
 
889
   (@ not (idx (-> @B) (-> @X) T)) )
 
890
 
 
891
(be asserta (@C) (@ asserta (-> @C)))
 
892
 
 
893
(be assertz (@C) (@ assertz (-> @C)))
 
894
 
 
895
(be retract (@C)
 
896
   (2 cons (-> @C))
 
897
   (@ retract (list (car (-> @C)) (cdr (-> @C)))) )
 
898
 
 
899
(be clause ("@H" "@B")
 
900
   ("@A" get (-> "@H") T)
 
901
   (member "@B" "@A") )
 
902
 
 
903
(be show (@X) (@ show (-> @X)))
 
904
 
 
905
 
 
906
(be val (@V . @L)
 
907
   (@V apply get (-> @L))
 
908
   T )
 
909
 
 
910
(be lst (@V . @L)
 
911
   (@Lst box (apply get (-> @L)))
 
912
   (_lst @V @Lst) )
 
913
 
 
914
(be _lst (@Val @Lst) (@ not (val (-> @Lst))) T (fail))
 
915
(be _lst (@Val @Lst) (@Val pop (-> @Lst)))
 
916
(repeat)
 
917
 
 
918
(be map (@V . @L)
 
919
   (@Lst box (apply get (-> @L)))
 
920
   (_map @V @Lst) )
 
921
 
 
922
(be _map (@Val @Lst) (@ not (val (-> @Lst))) T (fail))
 
923
(be _map (@Val @Lst) (@Val prog1 (val (-> @Lst)) (pop (-> @Lst))))
 
924
(repeat)
 
925
 
 
926
 
 
927
(be isa (@Typ . @L)
 
928
   (@ or
 
929
      (not (-> @Typ))
 
930
      (isa (-> @Typ) (apply get (-> @L))) ) )
 
931
 
 
932
(be same (@V . @L)
 
933
   (@ let V (-> @V)
 
934
      (or
 
935
         (not V)
 
936
         (let L (-> @L)
 
937
            ("same" (car L) (cdr L)) ) ) ) )
 
938
 
 
939
(de "same" (X L)
 
940
   (cond
 
941
      ((not L)
 
942
         (if (atom X)
 
943
            (= V X)
 
944
            (member V X) ) )
 
945
      ((atom X)
 
946
         ("same" (get X (car L)) (cdr L)) )
 
947
      ((atom (car L))
 
948
         (pick
 
949
            '((Y) ("same" (get Y (car L)) (cdr L)))
 
950
            X ) )
 
951
      (T ("same" (apply get (car L) X) (cdr L))) ) )
 
952
 
 
953
(be bool (@F . @L)
 
954
   (@ or
 
955
      (not (-> @F))
 
956
      (apply get (-> @L)) ) )
 
957
 
 
958
(be range (@N . @L)
 
959
   (@ let N (-> @N)
 
960
      (or
 
961
         (not N)
 
962
         (let L (-> @L)
 
963
            ("range" (car L) (cdr L)) ) ) ) )
 
964
 
 
965
(de "range" (X L)
 
966
   (cond
 
967
      ((not L)
 
968
         (if (atom X)
 
969
            (or
 
970
               (<= (car N) X (cdr N))
 
971
               (>= (car N) X (cdr N)) )
 
972
            (find
 
973
               '((Y)
 
974
                  (or
 
975
                     (<= (car N) Y (cdr N))
 
976
                     (>= (car N) Y (cdr N)) ) )
 
977
               X ) ) )
 
978
      ((atom X)
 
979
         ("range" (get X (car L)) (cdr L)) )
 
980
      ((atom (car L))
 
981
         (pick
 
982
            '((Y) ("range" (get Y (car L)) (cdr L)))
 
983
            X ) )
 
984
      (T ("range" (apply get (car L) X) (cdr L))) ) )
 
985
 
 
986
(be head (@S . @L)
 
987
   (@ let S (-> @S)
 
988
      (or
 
989
         (not S)
 
990
         (let L (-> @L)
 
991
            ("head" (car L) (cdr L)) ) ) ) )
 
992
 
 
993
(de "head" (X L)
 
994
   (cond
 
995
      ((not L)
 
996
         (if (atom X)
 
997
            (pre? S X)
 
998
            (find '((Y) (pre? S Y)) X) ) )
 
999
      ((atom X)
 
1000
         ("head" (get X (car L)) (cdr L)) )
 
1001
      ((atom (car L))
 
1002
         (pick
 
1003
            '((Y) ("head" (get Y (car L)) (cdr L)))
 
1004
            X ) )
 
1005
      (T ("head" (apply get (car L) X) (cdr L))) ) )
 
1006
 
 
1007
(be fold (@S . @L)
 
1008
   (@ let S (-> @S)
 
1009
      (or
 
1010
         (not S)
 
1011
         (let L (-> @L)
 
1012
            ("fold" (car L) (cdr L)) ) ) ) )
 
1013
 
 
1014
(de "fold" (X L)
 
1015
   (cond
 
1016
      ((not L)
 
1017
         (let P (fold S)
 
1018
            (if (atom X)
 
1019
               (pre? P (fold X))
 
1020
               (find '((Y) (pre? P (fold Y))) X) ) ) )
 
1021
      ((atom X)
 
1022
         ("fold" (get X (car L)) (cdr L)) )
 
1023
      ((atom (car L))
 
1024
         (pick
 
1025
            '((Y) ("fold" (get Y (car L)) (cdr L)))
 
1026
            X ) )
 
1027
      (T ("fold" (apply get (car L) X) (cdr L))) ) )
 
1028
 
 
1029
(be part (@S . @L)
 
1030
   (@ let S (-> @S)
 
1031
      (or
 
1032
         (not S)
 
1033
         (let L (-> @L)
 
1034
            ("part" (car L) (cdr L)) ) ) ) )
 
1035
 
 
1036
(de "part" (X L)
 
1037
   (cond
 
1038
      ((not L)
 
1039
         (let P (fold S)
 
1040
            (if (atom X)
 
1041
               (sub? P (fold X))
 
1042
               (find '((Y) (sub? P (fold Y))) X) ) ) )
 
1043
      ((atom X)
 
1044
         ("part" (get X (car L)) (cdr L)) )
 
1045
      ((atom (car L))
 
1046
         (pick
 
1047
            '((Y) ("part" (get Y (car L)) (cdr L)))
 
1048
            X ) )
 
1049
      (T ("part" (apply get (car L) X) (cdr L))) ) )
 
1050
 
 
1051
(be tolr (@S . @L)
 
1052
   (@ let S (-> @S)
 
1053
      (or
 
1054
         (not S)
 
1055
         (let L (-> @L)
 
1056
            ("tolr" (car L) (cdr L)) ) ) ) )
 
1057
 
 
1058
(de "tolr" (X L)
 
1059
   (cond
 
1060
      ((not L)
 
1061
         (if (atom X)
 
1062
            (or (sub? S X) (pre? (ext:Snx S) (ext:Snx X)))
 
1063
            (let P (ext:Snx S)
 
1064
               (find
 
1065
                  '((Y)
 
1066
                     (or (sub? S Y) (pre? P (ext:Snx Y))) )
 
1067
                  X ) ) ) )
 
1068
      ((atom X)
 
1069
         ("tolr" (get X (car L)) (cdr L)) )
 
1070
      ((atom (car L))
 
1071
         (pick
 
1072
            '((Y) ("tolr" (get Y (car L)) (cdr L)))
 
1073
            X ) )
 
1074
      (T ("tolr" (apply get (car L) X) (cdr L))) ) )
 
1075
 
 
1076
 
 
1077
(be _remote ((@Obj . @))
 
1078
   (@ not (val (-> @Sockets 2)))
 
1079
   T
 
1080
   (fail) )
 
1081
 
 
1082
(be _remote ((@Obj . @))
 
1083
   (@Obj let (Box (-> @Sockets 2)  Lst (val Box))
 
1084
      (rot Lst)
 
1085
      (loop
 
1086
         (T ((cdar Lst)) @)
 
1087
         (NIL (set Box (setq Lst (cdr Lst)))) ) ) )
 
1088
 
 
1089
(repeat)
 
1090
 
 
1091
############ lib/xm.l ############
 
1092
 
 
1093
# Check or write header
 
1094
(de xml? (Flg)
 
1095
   (if Flg
 
1096
      (prinl "<?xml version=\"1.0\" encoding=\"utf-8\"?>")
 
1097
      (skip)
 
1098
      (prog1
 
1099
         (head '("<" "?" "x" "m" "l") (till ">"))
 
1100
         (char) ) ) )
 
1101
 
 
1102
# Generate/Parse XML data
 
1103
(de xml (Lst N)
 
1104
   (if Lst
 
1105
      (let Tag (pop 'Lst)
 
1106
         (space (default N 0))
 
1107
         (prin "<" Tag)
 
1108
         (for X (pop 'Lst)
 
1109
            (prin " " (car X) "=\"")
 
1110
            (escXml (cdr X))
 
1111
            (prin "\"") )
 
1112
         (nond
 
1113
            (Lst (prinl "/>"))
 
1114
            ((or (cdr Lst) (pair (car Lst)))
 
1115
               (prin ">")
 
1116
               (escXml (car Lst))
 
1117
               (prinl "</" Tag ">") )
 
1118
            (NIL
 
1119
               (prinl ">")
 
1120
               (for X Lst
 
1121
                  (if (pair X)
 
1122
                     (xml X (+ 3 N))
 
1123
                     (space (+ 3 N))
 
1124
                     (escXml X)
 
1125
                     (prinl) ) )
 
1126
               (space N)
 
1127
               (prinl "</" Tag ">") ) ) )
 
1128
      (skip)
 
1129
      (unless (= "<" (char))
 
1130
         (quit "Bad XML") )
 
1131
      (_xml (till " /<>" T)) ) )
 
1132
 
 
1133
(de _xml (Tok)
 
1134
   (use X
 
1135
      (make
 
1136
         (link (intern Tok))
 
1137
         (let L
 
1138
            (make
 
1139
               (loop
 
1140
                  (NIL (skip) (quit "XML parse error"))
 
1141
                  (T (member @ '`(chop "/>")))
 
1142
                  (NIL (setq X (intern (till "=" T))))
 
1143
                  (char)
 
1144
                  (unless (= "\"" (char))
 
1145
                     (quit "XML parse error" X) )
 
1146
                  (link (cons X (pack (xmlEsc (till "\"")))))
 
1147
                  (char) ) )
 
1148
            (if (= "/" (char))
 
1149
               (prog (char) (and L (link L)))
 
1150
               (link L)
 
1151
               (loop
 
1152
                  (NIL (skip) (quit "XML parse error" Tok))
 
1153
                  (T (and (= "<" (setq X (char))) (= "/" (peek)))
 
1154
                     (char)
 
1155
                     (unless (= Tok (till " /<>" T))
 
1156
                        (quit "Unbalanced XML" Tok) )
 
1157
                     (char) )
 
1158
                  (if (= "<" X)
 
1159
                     (and (_xml (till " /<>" T)) (link @))
 
1160
                     (link
 
1161
                        (pack (xmlEsc (trim (cons X (till "^J<"))))) ) ) ) ) ) ) ) )
 
1162
 
 
1163
(de xmlEsc (L)
 
1164
   (use (@X @Z)
 
1165
      (make
 
1166
         (while L
 
1167
            (ifn (match '("&" @X ";" @Z) L)
 
1168
               (link (pop 'L))
 
1169
               (link
 
1170
                  (cond
 
1171
                     ((= @X '`(chop "quot")) "\"")
 
1172
                     ((= @X '`(chop "amp")) "&")
 
1173
                     ((= @X '`(chop "lt")) "<")
 
1174
                     ((= @X '`(chop "gt")) ">")
 
1175
                     ((= @X '`(chop "apos")) "'")
 
1176
                     ((= "#" (car @X))
 
1177
                        (char
 
1178
                           (if (= "x" (cadr @X))
 
1179
                              (hex (cddr @X))
 
1180
                              (format (cdr @X)) ) ) )
 
1181
                     (T @X) ) )
 
1182
               (setq L @Z) ) ) ) ) )
 
1183
 
 
1184
(de escXml (X)
 
1185
   (for C (chop X)
 
1186
      (if (member C '`(chop "\"&<"))
 
1187
         (prin "&#" (char C) ";")
 
1188
         (prin C) ) ) )
 
1189
 
 
1190
 
 
1191
# Access functions
 
1192
(de body (Lst . @)
 
1193
   (while (and (setq Lst (cddr Lst)) (args))
 
1194
      (setq Lst (assoc (next) Lst)) )
 
1195
   Lst )
 
1196
 
 
1197
(de attr (Lst Key . @)
 
1198
   (while (args)
 
1199
      (setq
 
1200
         Lst (assoc Key (cddr Lst))
 
1201
         Key (next) ) )
 
1202
   (cdr (assoc Key (cadr Lst))) )
 
1203
 
 
1204
############ lib/xmlrpc.l ############
 
1205
 
 
1206
# (xmlrpc "localhost" 8080 "foo.bar" 'int 41 'string "abc" ..)
 
1207
(de xmlrpc (Host Port Meth . @)
 
1208
   (let? Sock (connect Host Port)
 
1209
      (let Xml (tmp 'xmlrpc)
 
1210
         (out Xml
 
1211
            (xml? T)
 
1212
            (xml
 
1213
               (list 'methodCall NIL
 
1214
                  (list 'methodName NIL Meth)
 
1215
                  (make
 
1216
                     (link 'params NIL)
 
1217
                     (while (args)
 
1218
                        (link
 
1219
                           (list 'param NIL
 
1220
                              (list 'value NIL (list (next) NIL (next))) ) ) ) ) ) ) )
 
1221
         (prog1
 
1222
            (out Sock
 
1223
               (prinl "POST /RPC2 HTTP/1.0^M")
 
1224
               (prinl "Host: " Host "^M")
 
1225
               (prinl "User-Agent: PicoLisp^M")
 
1226
               (prinl "Content-Type: text/xml^M")
 
1227
               (prinl "Accept-Charset: utf-8^M")
 
1228
               (prinl "Content-Length: " (car (info Xml)) "^M")
 
1229
               (prinl "^M")
 
1230
               (in Xml (echo))
 
1231
               (flush)
 
1232
               (in Sock
 
1233
                  (while (line))
 
1234
                  (let? L (and (xml?) (xml))
 
1235
                     (when (== 'methodResponse (car L))
 
1236
                        (xmlrpcValue
 
1237
                           (car (body L 'params 'param 'value)) ) ) ) ) )
 
1238
            (close Sock) ) ) ) )
 
1239
 
 
1240
(de xmlrpcKey (Str)
 
1241
   (or (format Str) (intern Str)) )
 
1242
 
 
1243
(de xmlrpcValue (Lst)
 
1244
   (let X (caddr Lst)
 
1245
      (case (car Lst)
 
1246
         (string X)
 
1247
         ((i4 int) (format X))
 
1248
         (boolean (= "1" X))
 
1249
         (double (format X *Scl))
 
1250
         (array
 
1251
            (when (== 'data (car X))
 
1252
               (mapcar
 
1253
                  '((L)
 
1254
                     (and (== 'value (car L)) (xmlrpcValue (caddr L))) )
 
1255
                  (cddr X) ) ) )
 
1256
         (struct
 
1257
            (extract
 
1258
               '((L)
 
1259
                  (when (== 'member (car L))
 
1260
                     (cons
 
1261
                        (xmlrpcKey (caddr (assoc 'name L)))
 
1262
                        (xmlrpcValue (caddr (assoc 'value L))) ) ) )
 
1263
               (cddr Lst) ) ) ) ) )
 
1264
 
 
1265
############ lib/http.l ############
 
1266
 
 
1267
### HTTP-Client ###
 
1268
(de client (Host Port How . Prg)
 
1269
   (let? Sock (connect Host Port)
 
1270
      (prog1
 
1271
         (out Sock
 
1272
            (if (atom How)
 
1273
               (prinl "GET /" How " HTTP/1.0^M")
 
1274
               (prinl "POST /" (car How) " HTTP/1.0^M")
 
1275
               (prinl "Content-Length: " (size (cdr How)) "^M") )
 
1276
            (prinl "User-Agent: PicoLisp^M")
 
1277
            (prinl "Host: " Host "^M")
 
1278
            (prinl "Accept-Charset: utf-8^M")
 
1279
            (prinl "^M")
 
1280
            (and (pair How) (prin (cdr @)))
 
1281
            (flush)
 
1282
            (in Sock (run Prg 1)) )
 
1283
         (close Sock) ) ) )
 
1284
 
 
1285
############ Native Java ############
 
1286
 
 
1287
(de javac (Cls Ext Impl . @)
 
1288
   (let (J (pack "tmp/" Cls ".java")  C (pack "tmp/" Cls ".class"))
 
1289
      (call 'mkdir "-p" "tmp/")
 
1290
      (out J
 
1291
         (while (args)
 
1292
            (prinl "import " (next) ";") )
 
1293
         (prinl "public class " Cls
 
1294
            (and Ext (pack " extends " @))
 
1295
            (and Impl (pack " implements " (glue ", " Impl)))
 
1296
            " {"  )
 
1297
         (here "/**/")
 
1298
         (prinl "}") )
 
1299
      (call "javac" "-O" "-g:none" J)
 
1300
      (push1 '*Bye (list 'call "rm" J C)) ) )
 
1301
 
 
1302
### Debug ###
 
1303
`*Dbg
 
1304
 
 
1305
############ lib/debug.l ############
 
1306
 
 
1307
# Browsing
 
1308
(de doc (Sym Browser)
 
1309
   (let (L (chop Sym)  C (car L))
 
1310
      (and
 
1311
         (member C '("*" "+"))
 
1312
         (cadr L)
 
1313
         (setq C @) )
 
1314
      (cond
 
1315
         ((>= "Z" C "A"))
 
1316
         ((>= "z" C "a") (setq C (uppc C)))
 
1317
         (T (setq C "_")) )
 
1318
      (call (or Browser (sys "BROWSER") 'w3m)
 
1319
         (pack
 
1320
            "file:"
 
1321
            (and (= `(char '/) (char (path "@"))) "//")
 
1322
            (path "@doc/ref")
 
1323
            C ".html#" Sym ) ) ) )
 
1324
 
 
1325
(de more ("M" "Fun")
 
1326
   (let *Dbg NIL
 
1327
      (if (pair "M")
 
1328
         ((default "Fun" print) (pop '"M"))
 
1329
         (println (type "M"))
 
1330
         (setq
 
1331
            "Fun" (list '(X) (list 'pp 'X (lit "M")))
 
1332
            "M" (mapcar car (filter pair (val "M"))) ) )
 
1333
      (loop
 
1334
         (flush)
 
1335
         (T (atom "M") (prinl))
 
1336
         (T (line) T)
 
1337
         ("Fun" (pop '"M")) ) ) )
 
1338
 
 
1339
(de depth (Idx)  #> (max . average)
 
1340
   (let (C 0  D 0  N 0)
 
1341
      (cons
 
1342
         (recur (Idx N)
 
1343
            (ifn Idx
 
1344
               0
 
1345
               (inc 'C)
 
1346
               (inc 'D (inc 'N))
 
1347
               (inc
 
1348
                  (max
 
1349
                     (recurse (cadr Idx) N)
 
1350
                     (recurse (cddr Idx) N) ) ) ) )
 
1351
         (or (=0 C) (*/ D C)) ) ) )
 
1352
 
 
1353
(de what (S)
 
1354
   (let *Dbg NIL
 
1355
      (setq S (chop S))
 
1356
      (filter
 
1357
         '(("X") (match S (chop "X")))
 
1358
         (all) ) ) )
 
1359
 
 
1360
 
 
1361
(de who ("X" . "*Prg")
 
1362
   (let (*Dbg NIL  "Who" '("Who" @ @@ @@@))
 
1363
      (make (mapc "who" (all))) ) )
 
1364
 
 
1365
(de "who" ("Y")
 
1366
   (unless (or (ext? "Y") (memq "Y" "Who"))
 
1367
      (push '"Who" "Y")
 
1368
      (ifn (= `(char "+") (char "Y"))
 
1369
         (and (pair (val "Y")) ("nest" @) (link "Y"))
 
1370
         (for "Z" (val "Y")
 
1371
            (if (atom "Z")
 
1372
               (and ("match" "Z") (link "Y"))
 
1373
               (when ("nest" (cdr "Z"))
 
1374
                  (link (cons (car "Z") "Y")) ) ) )
 
1375
         (maps
 
1376
            '(("Z")
 
1377
               (if (atom "Z")
 
1378
                  (and ("match" "Z") (link "Y"))
 
1379
                  (when ("nest" (car "Z"))
 
1380
                     (link (cons (cdr "Z") "Y")) ) ) )
 
1381
            "Y" ) ) ) )
 
1382
 
 
1383
(de "nest" ("Y")
 
1384
   ("nst1" "Y")
 
1385
   ("nst2" "Y") )
 
1386
 
 
1387
(de "nst1" ("Y")
 
1388
   (let "Z" (setq "Y" (strip "Y"))
 
1389
      (loop
 
1390
         (T (atom "Y") (and (sym? "Y") ("who" "Y")))
 
1391
         (and (sym? (car "Y")) ("who" (car "Y")))
 
1392
         (and (pair (car "Y")) ("nst1" @))
 
1393
         (T (== "Z" (setq "Y" (cdr "Y")))) ) ) )
 
1394
 
 
1395
(de "nst2" ("Y")
 
1396
   (let "Z" (setq "Y" (strip "Y"))
 
1397
      (loop
 
1398
         (T (atom "Y") ("match" "Y"))
 
1399
         (T (or ("match" (car "Y")) ("nst2" (car "Y")))
 
1400
            T )
 
1401
         (T (== "Z" (setq "Y" (cdr "Y")))) ) ) )
 
1402
 
 
1403
(de "match" ("D")
 
1404
   (and
 
1405
      (cond
 
1406
         ((str? "X") (and (str? "D") (= "X" "D")))
 
1407
         ((sym? "X") (== "X" "D"))
 
1408
         (T (match "X" "D")) )
 
1409
      (or
 
1410
         (not "*Prg")
 
1411
         (let *Dbg (up 2 *Dbg) (run "*Prg")) ) ) )
 
1412
 
 
1413
 
 
1414
(de can (X)
 
1415
   (let *Dbg NIL
 
1416
      (extract
 
1417
         '(("Y")
 
1418
            (and
 
1419
               (= `(char "+") (char "Y"))
 
1420
               (asoq X (val "Y"))
 
1421
               (cons X "Y") ) )
 
1422
         (all) ) ) )
 
1423
 
 
1424
 
 
1425
# Class dependencies
 
1426
(de dep ("C")
 
1427
   (let *Dbg NIL
 
1428
      (dep1 0 "C")
 
1429
      (dep2 3 "C")
 
1430
      "C" ) )
 
1431
 
 
1432
(de dep1 (N "C")
 
1433
   (for "X" (type "C")
 
1434
      (dep1 (+ 3 N) "X") )
 
1435
   (space N)
 
1436
   (println "C") )
 
1437
 
 
1438
(de dep2 (N "C")
 
1439
   (for "X" (all)
 
1440
      (when
 
1441
         (and
 
1442
            (= `(char "+") (char "X"))
 
1443
            (memq "C" (type "X")) )
 
1444
         (space N)
 
1445
         (println "X")
 
1446
         (dep2 (+ 3 N) "X") ) ) )
 
1447
 
 
1448
# Single-Stepping
 
1449
(de _dbg (Lst)
 
1450
   (or
 
1451
      (atom (car Lst))
 
1452
      (num? (caar Lst))
 
1453
      (flg? (caar Lst))
 
1454
      (== '! (caar Lst))
 
1455
      (set Lst (cons '! (car Lst))) ) )
 
1456
 
 
1457
(de _dbg2 (Lst)
 
1458
   (map
 
1459
      '((L)
 
1460
         (if (and (pair (car L)) (flg? (caar L)))
 
1461
            (map _dbg (cdar L))
 
1462
            (_dbg L) ) )
 
1463
      Lst ) )
 
1464
 
 
1465
(de dbg (Lst)
 
1466
   (when (pair Lst)
 
1467
      (case (pop 'Lst)
 
1468
         ((case state)
 
1469
            (_dbg Lst)
 
1470
            (for L (cdr Lst)
 
1471
               (map _dbg (cdr L)) ) )
 
1472
         ((cond nond)
 
1473
            (for L Lst
 
1474
               (map _dbg L) ) )
 
1475
         (quote
 
1476
            (when (fun? Lst)
 
1477
               (map _dbg (cdr Lst)) ) )
 
1478
         ((job use let let? recur)
 
1479
            (map _dbg (cdr Lst)) )
 
1480
         (loop
 
1481
            (_dbg2 Lst) )
 
1482
         ((bind do)
 
1483
            (_dbg Lst)
 
1484
            (_dbg2 (cdr Lst)) )
 
1485
         (for
 
1486
            (and (pair (car Lst)) (map _dbg (cdar Lst)))
 
1487
            (_dbg2 (cdr Lst)) )
 
1488
         (T (map _dbg Lst)) )
 
1489
      T ) )
 
1490
 
 
1491
(de d () (let *Dbg NIL (dbg ^)))
 
1492
 
 
1493
(de debug ("X" C)
 
1494
   (ifn (traced? "X" C)
 
1495
      (let *Dbg NIL
 
1496
         (when (pair "X")
 
1497
            (setq C (cdr "X")  "X" (car "X")) )
 
1498
         (or
 
1499
            (dbg (if C (method "X" C) (getd "X")))
 
1500
            (quit "Can't debug" "X") ) )
 
1501
      (untrace "X" C)
 
1502
      (debug "X" C)
 
1503
      (trace "X" C) ) )
 
1504
 
 
1505
(de ubg (Lst)
 
1506
   (when (pair Lst)
 
1507
      (map
 
1508
         '((L)
 
1509
            (when (pair (car L))
 
1510
               (when (== '! (caar L))
 
1511
                  (set L (cdar L)) )
 
1512
               (ubg (car L)) ) )
 
1513
         Lst )
 
1514
      T ) )
 
1515
 
 
1516
(de u () (let *Dbg NIL (ubg ^)))
 
1517
 
 
1518
(de unbug ("X" C)
 
1519
   (let *Dbg NIL
 
1520
      (when (pair "X")
 
1521
         (setq C (cdr "X")  "X" (car "X")) )
 
1522
      (or
 
1523
         (ubg (if C (method "X" C) (getd "X")))
 
1524
         (quit "Can't unbug" "X") ) ) )
 
1525
 
 
1526
# Tracing
 
1527
(de traced? ("X" C)
 
1528
   (setq "X"
 
1529
      (if C
 
1530
         (method "X" C)
 
1531
         (getd "X") ) )
 
1532
   (and
 
1533
      (pair "X")
 
1534
      (pair (cadr "X"))
 
1535
      (== '$ (caadr "X")) ) )
 
1536
 
 
1537
# Convert ((X Y) A B) --> ((X Y) ($ foo (X Y) A B))
 
1538
(de trace ("X" C)
 
1539
   (let *Dbg NIL
 
1540
      (when (pair "X")
 
1541
         (setq C (cdr "X")  "X" (car "X")) )
 
1542
      (if C
 
1543
         (unless (traced? "X" C)
 
1544
            (or (method "X" C) (quit "Can't trace" "X"))
 
1545
            (con @
 
1546
               (cons
 
1547
                  (conc
 
1548
                     (list '$ (cons "X" C) (car @))
 
1549
                     (cdr @) ) ) ) )
 
1550
         (unless (traced? "X")
 
1551
            (and (sym? (getd "X")) (quit "Can't trace" "X"))
 
1552
            (and (num? (getd "X")) (expr "X"))
 
1553
            (set "X"
 
1554
               (list
 
1555
                  (car (getd "X"))
 
1556
                  (conc (list '$ "X") (getd "X")) ) ) ) )
 
1557
      "X" ) )
 
1558
 
 
1559
# Convert ((X Y) ($ foo (X Y) A B)) --> ((X Y) A B)
 
1560
(de untrace ("X" C)
 
1561
   (let *Dbg NIL
 
1562
      (when (pair "X")
 
1563
         (setq C (cdr "X")  "X" (car "X")) )
 
1564
      (if C
 
1565
         (when (traced? "X" C)
 
1566
            (con
 
1567
               (method "X" C)
 
1568
               (cdddr (cadr (method "X" C))) ) )
 
1569
         (when (traced? "X")
 
1570
            (let X (set "X" (cddr (cadr (getd "X"))))
 
1571
               (and
 
1572
                  (== '@ (pop 'X))
 
1573
                  (= 1 (length X))
 
1574
                  (= 2 (length (car X)))
 
1575
                  (== 'pass (caar X))
 
1576
                  (sym? (cdadr X))
 
1577
                  (subr "X") ) ) ) )
 
1578
      "X" ) )
 
1579
 
 
1580
(de *NoTrace
 
1581
   @ @@ @@@
 
1582
   pp show more
 
1583
   what who can dep d e debug u unbug trace untrace )
 
1584
 
 
1585
(de traceAll (Excl)
 
1586
   (let *Dbg NIL
 
1587
      (for "X" (all)
 
1588
         (or
 
1589
            (memq "X" Excl)
 
1590
            (memq "X" *NoTrace)
 
1591
            (= `(char "*") (char "X"))
 
1592
            (cond
 
1593
               ((= `(char "+") (char "X"))
 
1594
                  (mapc trace
 
1595
                     (extract
 
1596
                        '(("Y")
 
1597
                           (and
 
1598
                              (pair "Y")
 
1599
                              (fun? (cdr "Y"))
 
1600
                              (cons (car "Y") "X") ) )
 
1601
                        (val "X") ) ) )
 
1602
               ((pair (getd "X"))
 
1603
                  (trace "X") ) ) ) ) ) )
 
1604
 
 
1605
# Process Listing
 
1606
(de proc @
 
1607
   (apply call
 
1608
      (make (while (args) (link "-C" (next))))
 
1609
      'ps "-H" "-o" "pid,ppid,start,size,pcpu,wchan,cmd" ) )
 
1610
 
 
1611
# Benchmarking
 
1612
(de bench Prg
 
1613
   (let U (usec)
 
1614
      (prog1 (run Prg 1)
 
1615
         (out 2
 
1616
            (prinl
 
1617
               (format (*/ (- (usec) U) 1000) 3)
 
1618
               " sec" ) ) ) ) )
 
1619
 
 
1620
############ lib/lint.l ############
 
1621
 
 
1622
(de noLint (X V)
 
1623
   (if V
 
1624
      (push1 '*NoLint (cons X V))
 
1625
      (or (memq X *NoLint) (push '*NoLint X)) ) )
 
1626
 
 
1627
(de global? (S)
 
1628
   (or
 
1629
      (memq S '(NIL ^ @ @@ @@@ This T))
 
1630
      (member (char S) '(`(char '*) `(char '+))) ) )
 
1631
 
 
1632
(de local? (S)
 
1633
   (or
 
1634
      (str? S)
 
1635
      (member (char S) '(`(char '*) `(char '_))) ) )
 
1636
 
 
1637
(de dlsym? (S)
 
1638
   (and
 
1639
      (car (setq S (split (chop S) ':)))
 
1640
      (cadr S)
 
1641
      (low? (caar S)) ) )
 
1642
 
 
1643
(de lint1 ("X")
 
1644
   (cond
 
1645
      ((atom "X")
 
1646
         (when (sym? "X")
 
1647
            (cond
 
1648
               ((memq "X" "*L") (setq "*Use" (delq "X" "*Use")))
 
1649
               ((local? "X") (lint2 (val "X")))
 
1650
               (T
 
1651
                  (or
 
1652
                     (getd "X")
 
1653
                     (global? "X")
 
1654
                     (member (cons "*X" "X") *NoLint)
 
1655
                     (memq "X" "*Bnd")
 
1656
                     (push '"*Bnd" "X") ) ) ) ) )
 
1657
      ((num? (car "X")))
 
1658
      (T
 
1659
         (case (car "X")
 
1660
            ((: ::))
 
1661
            (; (lint1 (cadr "X")))
 
1662
            (quote
 
1663
               (let F (fun? (cdr "X"))
 
1664
                  (if (or (and (pair F) (not (fin @))) (== '@ F))
 
1665
                     (use "*L" (lintFun (cdr "X")))
 
1666
                     (lint2 (cdr "X")) ) ) )
 
1667
            ((de dm)
 
1668
               (let "*X" (cadr "X")
 
1669
                  (lintFun (cddr "X")) ) )
 
1670
            (recur
 
1671
               (let recurse (cdr "X")
 
1672
                  (lintFun recurse) ) )
 
1673
            (task
 
1674
               (lint1 (cadr "X"))
 
1675
               (let "Y" (cddr "X")
 
1676
                  (use "*L"
 
1677
                     (while (num? (car "Y"))
 
1678
                        (pop '"Y") )
 
1679
                     (while (and (car "Y") (sym? @))
 
1680
                        (lintVar (pop '"Y"))
 
1681
                        (pop '"Y") )
 
1682
                     (mapc lint1 "Y") ) ) )
 
1683
            (let?
 
1684
               (use "*L"
 
1685
                  (lintVar (cadr "X"))
 
1686
                  (mapc lint1 (cddr "X")) ) )
 
1687
            (let
 
1688
               (use "*L"
 
1689
                  (if (atom (cadr "X"))
 
1690
                     (lintVar (cadr "X"))
 
1691
                     (for (L (cadr "X") L (cddr L))
 
1692
                        (lintDup (car L)
 
1693
                           (extract '((X F) (and F X))
 
1694
                              (cddr L)
 
1695
                              '(T NIL .) ) )
 
1696
                        (lintVar (car L))
 
1697
                        (lint1 (cadr L)) ) )
 
1698
                  (mapc lint1 (cddr "X")) ) )
 
1699
            (use
 
1700
               (use "*L"
 
1701
                  (if (atom (cadr "X"))
 
1702
                     (lintVar (cadr "X"))
 
1703
                     (mapc lintVar (cadr "X")) )
 
1704
                  (mapc lint1 (cddr "X")) ) )
 
1705
            (for
 
1706
               (use "*L"
 
1707
                  (let "Y" (cadr "X")
 
1708
                     (cond
 
1709
                        ((atom "Y")          # (for X (1 2 ..) ..)
 
1710
                           (lint1 (caddr "X"))
 
1711
                           (lintVar "Y")
 
1712
                           (lintLoop (cdddr "X")) )
 
1713
                        ((atom (cdr "Y"))    # (for (I . X) (1 2 ..) ..)
 
1714
                           (lintVar (car "Y"))
 
1715
                           (lint1 (caddr "X"))
 
1716
                           (lintVar (cdr "Y"))
 
1717
                           (lintLoop (cdddr "X")) )
 
1718
                        ((atom (car "Y"))    # (for (X (1 2 ..) ..) ..)
 
1719
                           (lint1 (cadr "Y"))
 
1720
                           (lintVar (car "Y"))
 
1721
                           (mapc lint1 (cddr "Y"))
 
1722
                           (lintLoop (cddr "X")) )
 
1723
                        (T                   # (for ((I . L) (1 2 ..) ..) ..)
 
1724
                           (lintVar (caar "Y"))
 
1725
                           (lint1 (cadr "Y"))
 
1726
                           (lintVar (cdar "Y"))
 
1727
                           (mapc lint1 (cddr "Y"))
 
1728
                           (lintLoop (cddr "X")) ) ) ) ) )
 
1729
            ((case state)
 
1730
               (lint1 (cadr "X"))
 
1731
               (for "X" (cddr "X")
 
1732
                  (mapc lint1 (cdr "X")) ) )
 
1733
            ((cond nond)
 
1734
               (for "X" (cdr "X")
 
1735
                  (mapc lint1 "X") ) )
 
1736
            (loop
 
1737
               (lintLoop (cdr "X")) )
 
1738
            (do
 
1739
               (lint1 (cadr "X"))
 
1740
               (lintLoop (cddr "X")) )
 
1741
            (=:
 
1742
               (lint1 (last (cddr "X"))) )
 
1743
            ((dec inc pop push push1 queue fifo val idx accu)
 
1744
               (_lintq '(T)) )
 
1745
            ((cut port)
 
1746
               (_lintq '(NIL T)) )
 
1747
            (set
 
1748
               (_lintq '(T NIL .)) )
 
1749
            (xchg
 
1750
               (_lintq '(T T .)) )
 
1751
            (T
 
1752
               (cond
 
1753
                  ((pair (car "X"))
 
1754
                     (lint1 @)
 
1755
                     (mapc lint2 (cdr "X")) )
 
1756
                  ((memq (car "X") "*L")
 
1757
                     (setq "*Use" (delq (car "X") "*Use"))
 
1758
                     (mapc lint2 (cdr "X")) )
 
1759
                  ((fun? (val (car "X")))
 
1760
                     (if (num? @)
 
1761
                        (mapc lint1 (cdr "X"))
 
1762
                        (when (local? (car "X"))
 
1763
                           (lint2 (val (car "X"))) )
 
1764
                        (let "Y" (car (getd (pop '"X")))
 
1765
                           (while (and (pair "X") (pair "Y"))
 
1766
                              (lint1 (pop '"X"))
 
1767
                              (pop '"Y") )
 
1768
                           (if (or (== '@ "Y") (= "Prg" "Y") (= "*Prg" "Y"))
 
1769
                              (mapc lint1 "X")
 
1770
                              (lint2 "X") ) ) ) )
 
1771
                  (T
 
1772
                     (or
 
1773
                        (str? (car "X"))
 
1774
                        (dlsym? (car "X"))
 
1775
                        (== '@ (car "X"))
 
1776
                        (memq (car "X") *NoLint)
 
1777
                        (memq (car "X") "*Def")
 
1778
                        (push '"*Def" (car "X")) )
 
1779
                     (mapc lint1 (cdr "X")) ) ) ) ) ) ) )
 
1780
 
 
1781
(de lint2 (X Mark)
 
1782
   (cond
 
1783
      ((memq X Mark))
 
1784
      ((atom X)
 
1785
         (and (memq X "*L") (setq "*Use" (delq X "*Use"))) )
 
1786
      (T (lint2 (car X))
 
1787
         (lint2 (cdr X) (cons X Mark)) ) ) )
 
1788
 
 
1789
(de lintVar (X Flg)
 
1790
   (cond
 
1791
      ((or (not (sym? X)) (memq X '(NIL ^ meth quote T)))
 
1792
         (push '"*Var" X) )
 
1793
      ((not (global? X))
 
1794
         (or
 
1795
            Flg
 
1796
            (member (cons "*X" X) *NoLint)
 
1797
            (memq X "*Use")
 
1798
            (push '"*Use" X) )
 
1799
         (push '"*L" X) ) ) )
 
1800
 
 
1801
(de lintDup (X Lst)
 
1802
   (and
 
1803
      (memq X Lst)
 
1804
      (not (member (cons "*X" X) *NoLint))
 
1805
      (push '"*Dup" X) ) )
 
1806
 
 
1807
(de lintLoop ("Lst")
 
1808
   (for "Y" "Lst"
 
1809
      (if (and (pair "Y") (or (=T (car "Y")) (not (car "Y"))))
 
1810
         (mapc lint1 (cdr "Y"))
 
1811
         (lint1 "Y") ) ) )
 
1812
 
 
1813
(de _lintq (Lst)
 
1814
   (mapc
 
1815
      '((X Flg)
 
1816
         (lint1 (if Flg (strip X) X)) )
 
1817
      (cdr "X")
 
1818
      Lst ) )
 
1819
 
 
1820
(de lintFun ("Lst")
 
1821
   (let "A" (and (pair "Lst") (car "Lst"))
 
1822
      (while (pair "A")
 
1823
         (lintDup (car "A") (cdr "A"))
 
1824
         (lintVar (pop '"A") T) )
 
1825
      (when "A"
 
1826
         (lintVar "A") )
 
1827
      (mapc lint1 (cdr "Lst")) ) )
 
1828
 
 
1829
(de lint ("X" "C")
 
1830
   (let ("*L" NIL  "*Var" NIL  "*Dup" NIL  "*Def" NIL  "*Bnd" NIL  "*Use" NIL)
 
1831
      (when (pair "X")
 
1832
         (setq  "C" (cdr "X")  "X" (car "X")) )
 
1833
      (cond
 
1834
         ("C"  # Method
 
1835
            (let "*X" (cons "X" "C")
 
1836
               (lintFun (method "X" "C")) ) )
 
1837
         ((pair (val "X"))  # Function
 
1838
            (let "*X" "X"
 
1839
               (lintFun (val "X")) ) )
 
1840
         ((info "X")  # File name
 
1841
            (let "*X" "X"
 
1842
               (in "X" (while (read) (lint1 @))) ) )
 
1843
         (T (quit "Can't lint" "X")) )
 
1844
      (when (or "*Var" "*Dup" "*Def" "*Bnd" "*Use")
 
1845
         (make
 
1846
            # Bad variables
 
1847
            (and "*Var" (link (cons 'var "*Var")))
 
1848
            # Duplicate parameters
 
1849
            (and "*Dup" (link (cons 'dup "*Dup")))
 
1850
            # Undefined functions
 
1851
            (and "*Def" (link (cons 'def "*Def")))
 
1852
            # Unbound variables
 
1853
            (and "*Bnd" (<> `(char '_) (char "X")) (link (cons 'bnd "*Bnd")))
 
1854
            # Unused variables
 
1855
            (and "*Use" (link (cons 'use "*Use"))) ) ) ) )
 
1856
 
 
1857
(de lintAll @
 
1858
   (let *Dbg NIL
 
1859
      (make
 
1860
         (for "X" (all)
 
1861
            (cond
 
1862
               ((= `(char "+") (char "X"))
 
1863
                  (for "Y" (val "X")
 
1864
                     (and
 
1865
                        (pair "Y")
 
1866
                        (fun? (cdr "Y"))
 
1867
                        (lint (car "Y") "X")
 
1868
                        (link (cons (cons (car "Y") "X") @)) ) ) )
 
1869
               ((and (not (global? "X")) (pair (getd "X")) (lint "X"))
 
1870
                  (link (cons "X" @)) ) ) )
 
1871
         (while (args)
 
1872
            (and (lint (next)) (link (cons (arg) @))) ) ) ) )
 
1873
 
 
1874
# vi:et:ts=3:sw=3