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