picolisp

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

commit 1136904575380001a977ad4d2868dd785710bb1f
parent 59b9560bfb7bddea44005587fd7cb364f4c71f61
Author: Commit-Bot <unknown>
Date:   Wed, 17 Nov 2010 17:42:43 +0000

Automatic commit from picoLisp.tgz, From: Wed, 17 Nov 2010 17:42:43 GMT
Diffstat:
MINSTALL | 4++--
Derl | 2--
Mersatz/README | 12+++---------
Aersatz/lib.l | 1805+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Mersatz/mkJar | 6+++---
Mersatz/picolisp | 4++--
Mersatz/picolisp.jar | 0
Mlib/xm.l | 4++--
Msrc64/version.l | 4++--
9 files changed, 1819 insertions(+), 22 deletions(-)

diff --git a/INSTALL b/INSTALL @@ -1,4 +1,4 @@ -12nov10abu +17nov10abu (c) Software Lab. Alexander Burger @@ -91,7 +91,7 @@ or simply type an empy line (Return). If you just want to test the ready-to-run Ersatz PicoLisp (it needs a Java runtime system), use - $ ./erl + $ ersatz/picolisp : instead of 'dbg'. diff --git a/erl b/erl @@ -1,2 +0,0 @@ -#!/bin/sh -exec ${0%/*}/ersatz/picolisp -"on *Dbg" ${0%/*}/lib.l @lib/misc.l @lib/pilog.l @lib/debug.l @lib/lint.l "$@" diff --git a/ersatz/README b/ersatz/README @@ -1,4 +1,4 @@ -12nov10abu +17nov10abu (c) Software Lab. Alexander Burger @@ -33,14 +33,8 @@ Ersatz PicoLisp can be started - analog to 'bin/picolisp' - as $ ersatz/picolisp -or, analog to 'dbg' with initial libraries and debugging environment - - $ ./erl - -If absolutely no "bin/picolisp" can be build, you might install symbolic links -in the "bin/" directory to Ersatz PicoLisp: - - $ (cd bin; ln -s ../ersatz/picolisp && ln -s ../ersatz/picolisp.jar) +This already includes slighly simplfied versions of the standard libraries as +loaded by 'dbg' (without database support, but with Pilog and XML support). Building the JAR file diff --git a/ersatz/lib.l b/ersatz/lib.l @@ -0,0 +1,1805 @@ +# 17nov10abu +# (c) Software Lab. Alexander Burger + +############ lib.l ############ + +(de task (Key . Prg) + (nond + (Prg (del (assoc Key *Run) '*Run)) + ((num? Key) (quit "Bad Key" Key)) + ((assoc Key *Run) + (push '*Run + (conc + (make + (when (lt0 (link Key)) + (link (+ (eval (pop 'Prg) 1))) ) ) + (ifn (sym? (car Prg)) + Prg + (cons + (cons 'job + (cons + (lit + (make + (while (atom (car Prg)) + (link + (cons (pop 'Prg) (eval (pop 'Prg) 1)) ) ) ) ) + Prg ) ) ) ) ) ) ) + (NIL (quit "Key conflict" Key)) ) ) + +(de timeout (N) + (if2 N (assoc -1 *Run) + (set (cdr @) (+ N)) + (push '*Run (list -1 (+ N) '(bye))) + (del @ '*Run) ) ) + +(de macro "Prg" + (run (fill "Prg")) ) + +(de recur recurse + (run (cdr recurse)) ) + +(de curry "Z" + (let ("X" (pop '"Z") "Y" (pop '"Z") "P" (filter pat? "X")) + (if2 "P" (diff "X" "P") + (list "Y" (cons 'job (lit (env @)) (fill "Z" "P"))) + (cons "Y" (fill "Z" "P")) + (list "Y" (cons 'job (lit (env @)) "Z")) + (cons "Y" "Z") ) ) ) + +(====) + +(de expr ("F") + (set "F" + (list '@ (list 'pass (box (getd "F")))) ) ) + +(de subr ("F") + (set "F" + (getd (cadr (cadr (getd "F")))) ) ) + +(de undef ("X" "C") + (when (pair "X") + (setq "C" (cdr "X") "X" (car "X")) ) + (ifn "C" + (prog1 (val "X") (set "X")) + (prog1 + (cdr (asoq "X" (val "C"))) + (set "C" + (delq (asoq "X" (val "C")) (val "C")) ) ) ) ) + +(de redef "Lst" + (let ("Old" (car "Lst") "New" (name "Old")) + (set + "New" (getd "Old") + "Old" "New" + "Old" (fill (cdr "Lst") "Old") ) + "New" ) ) + +(de daemon ("X" . Prg) + (prog1 + (nond + ((pair "X") + (or (pair (getd "X")) (expr "X")) ) + ((pair (cdr "X")) + (method (car "X") (cdr "X")) ) + (NIL + (method (car "X") (get (or (cddr "X") *Class) (cadr "X"))) ) ) + (con @ (append Prg (cdr @))) ) ) + +(de patch ("Lst" "Pat" . "Prg") + (bind (fish pat? "Pat") + (recur ("Lst") + (loop + (cond + ((match "Pat" (car "Lst")) + (set "Lst" (run "Prg")) ) + ((pair (car "Lst")) + (recurse @) ) ) + (NIL (cdr "Lst")) + (T (atom (cdr "Lst")) + (when (match "Pat" (cdr "Lst")) + (con "Lst" (run "Prg")) ) ) + (setq "Lst" (cdr "Lst")) ) ) ) ) + +(====) + +(de cache ("Var" "Str" . Prg) + (nond + ((setq "Var" (car (idx "Var" "Str" T))) + (set "Str" "Str" "Str" (run Prg 1)) ) + ((n== "Var" (val "Var")) + (set "Var" (run Prg 1)) ) + (NIL (val "Var")) ) ) + +(====) + +(de scl (N) + (setq *Scl N) ) + +### I/O ### +(de tab (Lst . @) + (for N Lst + (let V (next) + (and (gt0 N) (space (- N (length V)))) + (prin V) + (and (lt0 N) (args) (space (- 0 N (length V)))) ) ) + (prinl) ) + +(de beep () + (prin "^G") ) + +(de msg (X . @) + (out 2 + (print X) + (pass prinl) + (flush) ) + X ) + +(de script (File . @) + (load File) ) + +(de once Prg + (unless (idx '*Once (file) T) + (run Prg 1) ) ) + +### List ### +(de insert (N Lst X) + (conc + (cut (dec N) 'Lst) + (cons X) + Lst ) ) + +(de remove (N Lst) + (conc + (cut (dec N) 'Lst) + (cdr Lst) ) ) + +(de place (N Lst X) + (conc + (cut (dec N) 'Lst) + (cons X) + (cdr Lst) ) ) + +(de uniq (Lst) + (let R NIL + (filter + '((X) (not (idx 'R X T))) + Lst ) ) ) + +(de group (Lst) + (make + (for X Lst + (if (assoc (car X) (made)) + (conc @ (cons (cdr X))) + (link (list (car X) (cdr X))) ) ) ) ) + +### Symbol ### +(de qsym "Sym" + (cons (val "Sym") (getl "Sym")) ) + +(de loc (S X) + (if (and (str? X) (= S X)) + X + (and + (pair X) + (or + (loc S (car X)) + (loc S (cdr X)) ) ) ) ) + +### OOP ### +(de class Lst + (let L (val (setq *Class (car Lst))) + (def *Class + (recur (L) + (if (atom (car L)) + (cdr Lst) + (cons (car L) (recurse (cdr L))) ) ) ) ) ) + +(de object ("Sym" "Val" . @) + (def "Sym" "Val") + (putl "Sym") + (while (args) + (put "Sym" (next) (next)) ) + "Sym" ) + +(de extend X + (setq *Class (car X)) ) + +# Class variables +(de var X + (put *Class (car X) (cdr X)) ) + +(de var: X + (apply meta X This) ) + +### Pretty Printing ### +(de *PP + T NIL if ifn when unless while until do case state for + with catch finally ! setq default push job use let let? + prog1 later recur redef =: in out ctl tab new ) +(de *PP1 let let? for redef) +(de *PP2 setq default) + +(de pretty (X N . @) + (setq N (abs (space (or N 0)))) + (while (args) + (printsp (next)) ) + (if (or (atom X) (>= 12 (size X))) + (print X) + (while (== 'quote (car X)) + (prin "'") + (pop 'X) ) + (let Z X + (prin "(") + (when (memq (print (pop 'X)) *PP) + (cond + ((memq (car Z) *PP1) + (if (and (pair (car X)) (pair (cdar X))) + (when (>= 12 (size (car X))) + (space) + (print (pop 'X)) ) + (space) + (print (pop 'X)) + (when (or (atom (car X)) (>= 12 (size (car X)))) + (space) + (print (pop 'X)) ) ) ) + ((memq (car Z) *PP2) + (inc 'N 3) + (loop + (prinl) + (pretty (cadr X) N (car X)) + (NIL (setq X (cddr X)) (space)) ) ) + ((or (atom (car X)) (>= 12 (size (car X)))) + (space) + (print (pop 'X)) ) ) ) + (when X + (loop + (T (== Z X) (prin " .")) + (T (atom X) (prin " . ") (print X)) + (prinl) + (pretty (pop 'X) (+ 3 N)) + (NIL X) ) + (space) ) + (prin ")") ) ) ) + +(de pp ("X" C) + (let *Dbg NIL + (and (pair "X") (setq C (cdr "X"))) + (prin "(") + (printsp (if C 'dm 'de)) + (prog1 (printsp "X") + (setq "X" + (if C + (method (if (pair "X") (car "X") "X") C) + (val "X") ) ) + (cond + ((atom "X") (prin ". ") (print "X")) + ((atom (cdr "X")) + (ifn (cdr "X") + (print (car "X")) + (print (car "X")) + (prin " . ") + (print @) ) ) + (T + (let Z "X" + (print (pop '"X")) + (loop + (T (== Z "X") (prin " .")) + (NIL "X") + (T (atom "X") + (prin " . ") + (print "X") ) + (prinl) + (pretty (pop '"X") 3) ) + (space) ) ) ) + (prinl ")") ) ) ) + +(de show ("X" . @) + (let *Dbg NIL + (setq "X" (pass get "X")) + (when (sym? "X") + (print "X" (val "X")) + (prinl) + (maps + '((X) + (space 3) + (if (atom X) + (println X) + (println (cdr X) (car X)) ) ) + "X" ) ) + "X" ) ) + +(de view (X Y) + (let *Dbg NIL + (if (=T Y) + (let N 0 + (recur (N X) + (when X + (recurse (+ 3 N) (cddr X)) + (space N) + (println (car X)) + (recurse (+ 3 N) (cadr X)) ) ) ) + (let Z X + (loop + (T (atom X) (println X)) + (if (atom (car X)) + (println '+-- (pop 'X)) + (print '+---) + (view + (pop 'X) + (append Y (cons (if X "| " " "))) ) ) + (NIL X) + (mapc prin Y) + (T (== Z X) (println '*)) + (println '|) + (mapc prin Y) ) ) ) ) ) + +############ lib/misc.l ############ + +# *Allow *Tmp + +(de *Day . (Mon Tue Wed Thu Fri Sat Sun .)) +(de *Mon . (Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec .)) +(de *mon . (jan feb mar apr may jun jul aug sep oct nov dec .)) + +### Locale ### +(de *Ctry) +(de *Lang) +(de *Sep0 . ".") +(de *Sep3 . ",") +(de *CtryCode) +(de *DateFmt @Y "-" @M "-" @D) +(de *DayFmt "Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday" "Sunday") +(de *MonFmt "January" "February" "March" "April" "May" "June" "July" "August" "September" "October" "November" "December") + +(de locale (Ctry Lang App) # "DE" "de" ["app/loc/"] + (load (if (setq *Ctry Ctry) (pack "@loc/" @ ".l") "@loc/NIL.l")) + (ifn (setq *Lang Lang) + (for S (idx '*Uni) + (set S S) ) + (let L + (sort + (make + ("loc" (pack "@loc/" Lang)) + (and App ("loc" (pack App Lang))) ) ) + (balance '*Uni L T) + (for S L + (set (car (idx '*Uni S)) (val S)) ) ) ) ) + +(de "loc" (F) + (in F + (use X + (while (setq X (read)) + (if (=T X) + ("loc" (read)) + (set (link @) (name (read))) ) ) ) ) ) + +### Math ### +(de sqrt (N F) + (cond + ((lt0 N) (quit "Bad argument" N)) + (N + (let (A 1 B 0) + (while (>= N A) + (setq A (>> -2 A)) ) + (loop + (if (> (inc 'B A) N) + (dec 'B A) + (dec 'N B) + (inc 'B A) ) + (setq B (>> 1 B) A (>> 2 A)) + (T (=0 A)) ) + (and F (> N B) (inc 'B)) + B ) ) ) ) + +# (Knuth Vol.2, p.442) +(de ** (X N) # N th power of X + (let Y 1 + (loop + (when (bit? 1 N) + (setq Y (* Y X)) ) + (T (=0 (setq N (>> 1 N))) + Y ) + (setq X (* X X)) ) ) ) + +(de accu (Var Key Val) + (when Val + (if (assoc Key (val Var)) + (con @ (+ Val (cdr @))) + (push Var (cons Key Val)) ) ) ) + +### String ### +(de align (X . @) + (pack + (if (pair X) + (mapcar + '((X) (need X (chop (next)) " ")) + X ) + (need X (chop (next)) " ") ) ) ) + +(de center (X . @) + (pack + (if (pair X) + (let R 0 + (mapcar + '((X) + (let (S (chop (next)) N (>> 1 (+ X (length S)))) + (prog1 + (need (+ N R) S " ") + (setq R (- X N)) ) ) ) + X ) ) + (let S (chop (next)) + (need (>> 1 (+ X (length S))) S " ") ) ) ) ) + +(de wrap (Max Lst) + (setq Lst (split Lst " " "^J")) + (pack + (make + (while Lst + (if (>= (length (car Lst)) Max) + (link (pop 'Lst) "^J") + (chain + (make + (link (pop 'Lst)) + (loop + (NIL Lst) + (T (>= (+ (length (car Lst)) (sum length (made))) Max) + (link "^J") ) + (link " " (pop 'Lst)) ) ) ) ) ) ) ) ) + +### Number ### +(de pad (N Val) + (pack (need N (chop Val) "0")) ) + +(de money (N Cur) + (if Cur + (pack (format N 2 *Sep0 *Sep3) " " Cur) + (format N 2 *Sep0 *Sep3) ) ) + +(de round (N D) + (if (>= *Scl D) + (format (*/ N (** 10 (- *Scl D))) D *Sep0 *Sep3) + (format N *Scl *Sep0 *Sep3) ) ) + +# Octal notation +(de oct (X) + (cond + ((num? X) + (let (S (and (lt0 X) '-) L (oct1 X)) + (until (=0 (setq X (>> 3 X))) + (push 'L (oct1 X)) ) + (pack S L) ) ) + ((setq X (chop X)) + (let (S (and (= '- (car X)) (pop 'X)) N 0) + (for C X + (setq N (+ (format C) (>> -3 N))) ) + (if S (- N) N) ) ) ) ) + +(de oct1 (N) + (char (+ (& N 7) `(char "0"))) ) + +# Hexadecimal notation +(de hex (X) + (cond + ((num? X) + (let (S (and (lt0 X) '-) L (hex1 X)) + (until (=0 (setq X (>> 4 X))) + (push 'L (hex1 X)) ) + (pack S L) ) ) + ((setq X (chop X)) + (let (S (and (= '- (car X)) (pop 'X)) N 0) + (for C X + (setq C (- (char C) `(char "0"))) + (and (> C 9) (dec 'C 7)) + (and (> C 22) (dec 'C 32)) + (setq N (+ C (>> -4 N))) ) + (if S (- N) N) ) ) ) ) + +(de hex1 (N) + (let C (& 15 N) + (and (> C 9) (inc 'C 7)) + (char (+ C `(char "0"))) ) ) + +### Tree ### +(de balance ("Var" "Lst" "Flg") + (unless "Flg" (set "Var")) + (let "Len" (length "Lst") + (recur ("Lst" "Len") + (unless (=0 "Len") + (let ("N" (>> 1 (inc "Len")) "L" (nth "Lst" "N")) + (idx "Var" (car "L") T) + (recurse "Lst" (dec "N")) + (recurse (cdr "L") (- "Len" "N")) ) ) ) ) ) + +### Allow ### +(de allowed Lst + (setq *Allow (cons NIL (car Lst))) + (balance *Allow (sort (cdr Lst))) ) + +(de allow (X Flg) + (nond + (*Allow) + (Flg (idx *Allow X T)) + ((member X (cdr *Allow)) + (conc *Allow (cons X)) ) ) + X ) + +### Telephone ### +(de telStr (S) + (cond + ((not S)) + ((and *CtryCode (pre? (pack *CtryCode " ") S)) + (pack 0 (cdddr (chop S))) ) + (T (pack "+" S)) ) ) + +(de expTel (S) + (setq S + (make + (for (L (chop S) L) + (ifn (sub? (car L) " -") + (link (pop 'L)) + (let F NIL + (loop + (and (= '- (pop 'L)) (on F)) + (NIL L) + (NIL (sub? (car L) " -") + (link (if F '- " ")) ) ) ) ) ) ) ) + (cond + ((= "+" (car S)) (pack (cdr S))) + ((head '("0" "0") S) + (pack (cddr S)) ) + ((and *CtryCode (= "0" (car S))) + (pack *CtryCode " " (cdr S)) ) ) ) + +### Date ### +# ISO date +(de dat$ (Dat C) + (when (date Dat) + (pack (car @) C (pad 2 (cadr @)) C (pad 2 (caddr @))) ) ) + +(de $dat (S C) + (if C + (and + (= 3 + (length (setq S (split (chop S) C))) ) + (date + (format (car S)) # Year + (or (format (cadr S)) 0) # Month + (or (format (caddr S)) 0) ) ) # Day + (and + (format S) + (date + (/ @ 10000) # Year + (% (/ @ 100) 100) # Month + (% @ 100) ) ) ) ) + +(de datSym (Dat) + (when (date Dat) + (pack + (pad 2 (caddr @)) + (get *mon (cadr @)) + (pad 2 (% (car @) 100)) ) ) ) + +# Localized +(de datStr (D F) + (when (setq D (date D)) + (let + (@Y (if F (pad 2 (% (car D) 100)) (pad 4 (car D))) + @M (pad 2 (cadr D)) + @D (pad 2 (caddr D)) ) + (pack (fill *DateFmt)) ) ) ) + +(de strDat (S) + (use (@Y @M @D) + (and + (match *DateFmt (chop S)) + (date + (format @Y) + (or (format @M) 0) + (or (format @D) 0) ) ) ) ) + +(de expDat (S) + (use (@Y @M @D X) + (unless (match *DateFmt (setq S (chop S))) + (if + (or + (cdr (setq S (split S "."))) + (>= 2 (length (car S))) ) + (setq + @D (car S) + @M (cadr S) + @Y (caddr S) ) + (setq + @D (head 2 (car S)) + @M (head 2 (nth (car S) 3)) + @Y (nth (car S) 5) ) ) ) + (and + (setq @D (format @D)) + (date + (nond + (@Y (car (date (date)))) + ((setq X (format @Y))) + ((>= X 100) + (+ X + (* 100 (/ (car (date (date))) 100)) ) ) + (NIL X) ) + (nond + (@M (cadr (date (date)))) + ((setq X (format @M)) 0) + ((n0 X) (cadr (date (date)))) + (NIL X) ) + @D ) ) ) ) + +# Day of the week +(de day (Dat Lst) + (get + (or Lst *DayFmt) + (inc (% (inc Dat) 7)) ) ) + +# Week of the year +(de week (Dat) + (let W + (- + (_week Dat) + (_week (date (car (date Dat)) 1 4)) + -1 ) + (if (=0 W) 53 W) ) ) + +(de _week (Dat) + (/ (- Dat (% (inc Dat) 7)) 7) ) + +# Last day of month +(de ultimo (Y M) + (dec + (if (= 12 M) + (date (inc Y) 1 1) + (date Y (inc M) 1) ) ) ) + +### Time ### +(de tim$ (Tim F) + (when Tim + (setq Tim (time Tim)) + (pack (pad 2 (car Tim)) ":" (pad 2 (cadr Tim)) + (and F ":") + (and F (pad 2 (caddr Tim))) ) ) ) + +(de $tim (S) + (setq S (split (chop S) ":")) + (unless (or (cdr S) (>= 2 (length (car S)))) + (setq S + (list + (head 2 (car S)) + (head 2 (nth (car S) 3)) + (nth (car S) 5) ) ) ) + (when (format (car S)) + (time @ + (or (format (cadr S)) 0) + (or (format (caddr S)) 0) ) ) ) + +(de stamp (Dat Tim) + (and (=T Dat) (setq Dat (date T))) + (default Dat (date) Tim (time T)) + (pack (dat$ Dat "-") " " (tim$ Tim T)) ) + + +(de dirname (F) + (pack (flip (member '/ (flip (chop F))))) ) + +(de basename (F) + (pack (stem (chop F) '/)) ) + +# Temporary Files +(de tmp @ + (unless *Tmp + (push '*Bye '(call 'rm "-r" *Tmp)) + (push '*Fork '(off *Tmp) '(del '(call 'rm "-r" *Tmp) '*Bye)) + (call 'mkdir "-p" (setq *Tmp (pack "tmp/" *Pid "/"))) ) + (pass pack *Tmp) ) + + +# Print or eval +(de prEval (Prg Ofs) + (default Ofs 1) + (for X Prg + (if (atom X) + (prinl (eval X Ofs)) + (eval X Ofs) ) ) ) + +# Echo here-documents +(de here (S) + (line) + (echo S) ) + + +### Assertions ### +(de assert Prg + (when *Dbg + (cons + (list 'unless + (if (cdr Prg) (cons 'and Prg) (car Prg)) + (list 'quit "'assert' failed" (lit (car Prg))) ) ) ) ) + +(de test (Pat . Prg) + (bind (fish pat? Pat) + (unless (match Pat (run Prg 1)) + (msg Prg) + (quit "'test' failed" Pat) ) ) ) + +############ lib/pilog.l ############ + +# *Rule + +(de be CL + (with (car CL) + (if (== *Rule This) + (=: T (conc (: T) (cons (cdr CL)))) + (=: T (cons (cdr CL))) + (setq *Rule This) ) + This ) ) + +(de repeat () + (conc (get *Rule T) (get *Rule T)) ) + +(de asserta (CL) + (with (car CL) + (=: T (cons (cdr CL) (: T))) ) ) + +(de assertz (CL) + (with (car CL) + (=: T (conc (: T) (cons (cdr CL)))) ) ) + +(de retract (X) + (if (sym? X) + (put X T) + (put (car X) T + (delete (cdr X) (get (car X) T)) ) ) ) + +(de rules @ + (while (args) + (let S (next) + (for ((N . L) (get S T) L) + (prin N " (be ") + (print S) + (for X (pop 'L) + (space) + (print X) ) + (prinl ")") + (T (== L (get S T)) + (println '(repeat)) ) ) + S ) ) ) + +### Pilog Interpreter ### +(de goal ("CL" . @) + (let "Env" '(T) + (while (args) + (push '"Env" + (cons (cons 0 (next)) 1 (next)) ) ) + (while (and "CL" (pat? (car "CL"))) + (push '"Env" + (cons + (cons 0 (pop '"CL")) + (cons 1 (eval (pop '"CL"))) ) ) ) + (cons + (cons + (conc (list 1 (0) NIL "CL" NIL) "Env") ) ) ) ) + +(de fail () + (goal '((NIL))) ) + +(de pilog ("CL" . "Prg") + (for ("Q" (goal "CL") (prove "Q")) + (bind @ (run "Prg")) ) ) + +(de solve ("CL" . "Prg") + (make + (if "Prg" + (for ("Q" (goal "CL") (prove "Q")) + (link (bind @ (run "Prg"))) ) + (for ("Q" (goal "CL") (prove "Q")) + (link @) ) ) ) ) + +(de query ("Q" "Dbg") + (use "R" + (loop + (NIL (prove "Q" "Dbg")) + (T (=T (setq "R" @)) T) + (for X "R" + (space) + (print (car X)) + (print '=) + (print (cdr X)) + (flush) ) + (T (line)) ) ) ) + +(de ? "CL" + (let "L" + (make + (while (nor (pat? (car "CL")) (lst? (car "CL"))) + (link (pop '"CL")) ) ) + (query (goal "CL") "L") ) ) + +### Basic Rules ### +(be repeat) +(repeat) + +(be true) + +(be not @P (1 -> @P) T (fail)) +(be not @P) + +(be call @P + (2 cons (-> @P)) ) + +(be or @L (@C box (-> @L)) (_or @C)) + +(be _or (@C) (3 pop (-> @C))) +(be _or (@C) (@ not (val (-> @C))) T (fail)) +(repeat) + +(be nil (@X) (@ not (-> @X))) + +(be equal (@X @X)) + +(be different (@X @X) T (fail)) +(be different (@ @)) + +(be append (NIL @X @X)) +(be append ((@A . @X) @Y (@A . @Z)) (append @X @Y @Z)) + +(be member (@X (@X . @))) +(be member (@X (@ . @Y)) (member @X @Y)) + +(be delete (@A (@A . @Z) @Z)) +(be delete (@A (@X . @Y) (@X . @Z)) + (delete @A @Y @Z) ) + +(be permute ((@X) (@X))) +(be permute (@L (@X . @Y)) + (delete @X @L @D) + (permute @D @Y) ) + +(be uniq (@B @X) + (@ not (idx (-> @B) (-> @X) T)) ) + +(be asserta (@C) (@ asserta (-> @C))) + +(be assertz (@C) (@ assertz (-> @C))) + +(be retract (@C) + (2 cons (-> @C)) + (@ retract (list (car (-> @C)) (cdr (-> @C)))) ) + +(be clause ("@H" "@B") + ("@A" get (-> "@H") T) + (member "@B" "@A") ) + +(be show (@X) (@ show (-> @X))) + + +(be val (@V . @L) + (@V apply get (-> @L)) + T ) + +(be lst (@V . @L) + (@Lst box (apply get (-> @L))) + (_lst @V @Lst) ) + +(be _lst (@Val @Lst) (@ not (val (-> @Lst))) T (fail)) +(be _lst (@Val @Lst) (@Val pop (-> @Lst))) +(repeat) + +(be map (@V . @L) + (@Lst box (apply get (-> @L))) + (_map @V @Lst) ) + +(be _map (@Val @Lst) (@ not (val (-> @Lst))) T (fail)) +(be _map (@Val @Lst) (@Val prog1 (val (-> @Lst)) (pop (-> @Lst)))) +(repeat) + + +(be isa (@Typ . @L) + (@ or + (not (-> @Typ)) + (isa (-> @Typ) (apply get (-> @L))) ) ) + +(be same (@V . @L) + (@ let V (-> @V) + (or + (not V) + (let L (-> @L) + ("same" (car L) (cdr L)) ) ) ) ) + +(de "same" (X L) + (cond + ((not L) + (if (atom X) + (= V X) + (member V X) ) ) + ((atom X) + ("same" (get X (car L)) (cdr L)) ) + ((atom (car L)) + (pick + '((Y) ("same" (get Y (car L)) (cdr L))) + X ) ) + (T ("same" (apply get (car L) X) (cdr L))) ) ) + +(be bool (@F . @L) + (@ or + (not (-> @F)) + (apply get (-> @L)) ) ) + +(be range (@N . @L) + (@ let N (-> @N) + (or + (not N) + (let L (-> @L) + ("range" (car L) (cdr L)) ) ) ) ) + +(de "range" (X L) + (cond + ((not L) + (if (atom X) + (or + (<= (car N) X (cdr N)) + (>= (car N) X (cdr N)) ) + (find + '((Y) + (or + (<= (car N) Y (cdr N)) + (>= (car N) Y (cdr N)) ) ) + X ) ) ) + ((atom X) + ("range" (get X (car L)) (cdr L)) ) + ((atom (car L)) + (pick + '((Y) ("range" (get Y (car L)) (cdr L))) + X ) ) + (T ("range" (apply get (car L) X) (cdr L))) ) ) + +(be head (@S . @L) + (@ let S (-> @S) + (or + (not S) + (let L (-> @L) + ("head" (car L) (cdr L)) ) ) ) ) + +(de "head" (X L) + (cond + ((not L) + (if (atom X) + (pre? S X) + (find '((Y) (pre? S Y)) X) ) ) + ((atom X) + ("head" (get X (car L)) (cdr L)) ) + ((atom (car L)) + (pick + '((Y) ("head" (get Y (car L)) (cdr L))) + X ) ) + (T ("head" (apply get (car L) X) (cdr L))) ) ) + +(be fold (@S . @L) + (@ let S (-> @S) + (or + (not S) + (let L (-> @L) + ("fold" (car L) (cdr L)) ) ) ) ) + +(de "fold" (X L) + (cond + ((not L) + (let P (fold S) + (if (atom X) + (pre? P (fold X)) + (find '((Y) (pre? P (fold Y))) X) ) ) ) + ((atom X) + ("fold" (get X (car L)) (cdr L)) ) + ((atom (car L)) + (pick + '((Y) ("fold" (get Y (car L)) (cdr L))) + X ) ) + (T ("fold" (apply get (car L) X) (cdr L))) ) ) + +(be part (@S . @L) + (@ let S (-> @S) + (or + (not S) + (let L (-> @L) + ("part" (car L) (cdr L)) ) ) ) ) + +(de "part" (X L) + (cond + ((not L) + (let P (fold S) + (if (atom X) + (sub? P (fold X)) + (find '((Y) (sub? P (fold Y))) X) ) ) ) + ((atom X) + ("part" (get X (car L)) (cdr L)) ) + ((atom (car L)) + (pick + '((Y) ("part" (get Y (car L)) (cdr L))) + X ) ) + (T ("part" (apply get (car L) X) (cdr L))) ) ) + +(be tolr (@S . @L) + (@ let S (-> @S) + (or + (not S) + (let L (-> @L) + ("tolr" (car L) (cdr L)) ) ) ) ) + +(de "tolr" (X L) + (cond + ((not L) + (if (atom X) + (or (sub? S X) (pre? (ext:Snx S) (ext:Snx X))) + (let P (ext:Snx S) + (find + '((Y) + (or (sub? S Y) (pre? P (ext:Snx Y))) ) + X ) ) ) ) + ((atom X) + ("tolr" (get X (car L)) (cdr L)) ) + ((atom (car L)) + (pick + '((Y) ("tolr" (get Y (car L)) (cdr L))) + X ) ) + (T ("tolr" (apply get (car L) X) (cdr L))) ) ) + + +(be _remote ((@Obj . @)) + (@ not (val (-> @Sockets 2))) + T + (fail) ) + +(be _remote ((@Obj . @)) + (@Obj let (Box (-> @Sockets 2) Lst (val Box)) + (rot Lst) + (loop + (T ((cdar Lst)) @) + (NIL (set Box (setq Lst (cdr Lst)))) ) ) ) + +(repeat) + +############ lib/debug.l ############ +# Browsing +(de doc (Sym Browser) + (let (L (chop Sym) C (car L)) + (and + (member C '("*" "+")) + (cadr L) + (setq C @) ) + (cond + ((>= "Z" C "A")) + ((>= "z" C "a") (setq C (uppc C))) + (T (setq C "_")) ) + (call (or Browser (sys "BROWSER") 'w3m) + (pack + "file:" + (and (= `(char '/) (char (path "@"))) "//") + (path "@doc/ref") + C ".html#" Sym ) ) ) ) + +(de more ("M" "Fun") + (let *Dbg NIL + (if (pair "M") + ((default "Fun" print) (pop '"M")) + (println (type "M")) + (setq + "Fun" (list '(X) (list 'pp 'X (lit "M"))) + "M" (mapcar car (filter pair (val "M"))) ) ) + (loop + (flush) + (T (atom "M") (prinl)) + (T (line) T) + ("Fun" (pop '"M")) ) ) ) + +(de depth (Idx) #> (max . average) + (let (C 0 D 0 N 0) + (cons + (recur (Idx N) + (ifn Idx + 0 + (inc 'C) + (inc 'D (inc 'N)) + (inc + (max + (recurse (cadr Idx) N) + (recurse (cddr Idx) N) ) ) ) ) + (or (=0 C) (*/ D C)) ) ) ) + +(de what (S) + (let *Dbg NIL + (setq S (chop S)) + (filter + '(("X") (match S (chop "X"))) + (all) ) ) ) + + +(de who ("X" . "*Prg") + (let (*Dbg NIL "Who" '("Who" @ @@ @@@)) + (make (mapc "who" (all))) ) ) + +(de "who" ("Y") + (unless (or (ext? "Y") (memq "Y" "Who")) + (push '"Who" "Y") + (ifn (= `(char "+") (char "Y")) + (and (pair (val "Y")) ("nest" @) (link "Y")) + (for "Z" (val "Y") + (if (atom "Z") + (and ("match" "Z") (link "Y")) + (when ("nest" (cdr "Z")) + (link (cons (car "Z") "Y")) ) ) ) + (maps + '(("Z") + (if (atom "Z") + (and ("match" "Z") (link "Y")) + (when ("nest" (car "Z")) + (link (cons (cdr "Z") "Y")) ) ) ) + "Y" ) ) ) ) + +(de "nest" ("Y") + ("nst1" "Y") + ("nst2" "Y") ) + +(de "nst1" ("Y") + (let "Z" (setq "Y" (strip "Y")) + (loop + (T (atom "Y") (and (sym? "Y") ("who" "Y"))) + (and (sym? (car "Y")) ("who" (car "Y"))) + (and (pair (car "Y")) ("nst1" @)) + (T (== "Z" (setq "Y" (cdr "Y")))) ) ) ) + +(de "nst2" ("Y") + (let "Z" (setq "Y" (strip "Y")) + (loop + (T (atom "Y") ("match" "Y")) + (T (or ("match" (car "Y")) ("nst2" (car "Y"))) + T ) + (T (== "Z" (setq "Y" (cdr "Y")))) ) ) ) + +(de "match" ("D") + (and + (cond + ((str? "X") (and (str? "D") (= "X" "D"))) + ((sym? "X") (== "X" "D")) + (T (match "X" "D")) ) + (or + (not "*Prg") + (let *Dbg (up 2 *Dbg) (run "*Prg")) ) ) ) + + +(de can (X) + (let *Dbg NIL + (extract + '(("Y") + (and + (= `(char "+") (char "Y")) + (asoq X (val "Y")) + (cons X "Y") ) ) + (all) ) ) ) + + +# Class dependencies +(de dep ("C") + (let *Dbg NIL + (dep1 0 "C") + (dep2 3 "C") + "C" ) ) + +(de dep1 (N "C") + (for "X" (type "C") + (dep1 (+ 3 N) "X") ) + (space N) + (println "C") ) + +(de dep2 (N "C") + (for "X" (all) + (when + (and + (= `(char "+") (char "X")) + (memq "C" (type "X")) ) + (space N) + (println "X") + (dep2 (+ 3 N) "X") ) ) ) + +# Single-Stepping +(de _dbg (Lst) + (or + (atom (car Lst)) + (num? (caar Lst)) + (flg? (caar Lst)) + (== '! (caar Lst)) + (set Lst (cons '! (car Lst))) ) ) + +(de _dbg2 (Lst) + (map + '((L) + (if (and (pair (car L)) (flg? (caar L))) + (map _dbg (cdar L)) + (_dbg L) ) ) + Lst ) ) + +(de dbg (Lst) + (when (pair Lst) + (case (pop 'Lst) + ((case state) + (_dbg Lst) + (for L (cdr Lst) + (map _dbg (cdr L)) ) ) + ((cond nond) + (for L Lst + (map _dbg L) ) ) + (quote + (when (fun? Lst) + (map _dbg (cdr Lst)) ) ) + ((job use let let? recur) + (map _dbg (cdr Lst)) ) + (loop + (_dbg2 Lst) ) + ((bind do) + (_dbg Lst) + (_dbg2 (cdr Lst)) ) + (for + (and (pair (car Lst)) (map _dbg (cdar Lst))) + (_dbg2 (cdr Lst)) ) + (T (map _dbg Lst)) ) + T ) ) + +(de d () (let *Dbg NIL (dbg ^))) + +(de debug ("X" C) + (ifn (traced? "X" C) + (let *Dbg NIL + (when (pair "X") + (setq C (cdr "X") "X" (car "X")) ) + (or + (dbg (if C (method "X" C) (getd "X"))) + (quit "Can't debug" "X") ) ) + (untrace "X" C) + (debug "X" C) + (trace "X" C) ) ) + +(de ubg (Lst) + (when (pair Lst) + (map + '((L) + (when (pair (car L)) + (when (== '! (caar L)) + (set L (cdar L)) ) + (ubg (car L)) ) ) + Lst ) + T ) ) + +(de u () (let *Dbg NIL (ubg ^))) + +(de unbug ("X" C) + (let *Dbg NIL + (when (pair "X") + (setq C (cdr "X") "X" (car "X")) ) + (or + (ubg (if C (method "X" C) (getd "X"))) + (quit "Can't unbug" "X") ) ) ) + +# Tracing +(de traced? ("X" C) + (setq "X" + (if C + (method "X" C) + (getd "X") ) ) + (and + (pair "X") + (pair (cadr "X")) + (== '$ (caadr "X")) ) ) + +# Convert ((X Y) A B) --> ((X Y) ($ foo (X Y) A B)) +(de trace ("X" C) + (let *Dbg NIL + (when (pair "X") + (setq C (cdr "X") "X" (car "X")) ) + (if C + (unless (traced? "X" C) + (or (method "X" C) (quit "Can't trace" "X")) + (con @ + (cons + (conc + (list '$ (cons "X" C) (car @)) + (cdr @) ) ) ) ) + (unless (traced? "X") + (and (sym? (getd "X")) (quit "Can't trace" "X")) + (and (num? (getd "X")) (expr "X")) + (set "X" + (list + (car (getd "X")) + (conc (list '$ "X") (getd "X")) ) ) ) ) + "X" ) ) + +# Convert ((X Y) ($ foo (X Y) A B)) --> ((X Y) A B) +(de untrace ("X" C) + (let *Dbg NIL + (when (pair "X") + (setq C (cdr "X") "X" (car "X")) ) + (if C + (when (traced? "X" C) + (con + (method "X" C) + (cdddr (cadr (method "X" C))) ) ) + (when (traced? "X") + (let X (set "X" (cddr (cadr (getd "X")))) + (and + (== '@ (pop 'X)) + (= 1 (length X)) + (= 2 (length (car X))) + (== 'pass (caar X)) + (sym? (cdadr X)) + (subr "X") ) ) ) ) + "X" ) ) + +(de *NoTrace + @ @@ @@@ + pp show more + what who can dep d e debug u unbug trace untrace ) + +(de traceAll (Excl) + (let *Dbg NIL + (for "X" (all) + (or + (memq "X" Excl) + (memq "X" *NoTrace) + (= `(char "*") (char "X")) + (cond + ((= `(char "+") (char "X")) + (mapc trace + (extract + '(("Y") + (and + (pair "Y") + (fun? (cdr "Y")) + (cons (car "Y") "X") ) ) + (val "X") ) ) ) + ((pair (getd "X")) + (trace "X") ) ) ) ) ) ) + +# Process Listing +(de proc @ + (apply call + (make (while (args) (link "-C" (next)))) + 'ps "-H" "-o" "pid,ppid,start,size,pcpu,wchan,cmd" ) ) + +# Benchmarking +(de bench Prg + (let U (usec) + (prog1 (run Prg 1) + (out 2 + (prinl + (format (*/ (- (usec) U) 1000) 3) + " sec" ) ) ) ) ) + +############ lib/lint.l ############ + +(de noLint (X V) + (if V + (push1 '*NoLint (cons X V)) + (or (memq X *NoLint) (push '*NoLint X)) ) ) + +(de global? (S) + (or + (memq S '(NIL ^ @ @@ @@@ This T)) + (member (char S) '(`(char '*) `(char '+))) ) ) + +(de local? (S) + (or + (str? S) + (member (char S) '(`(char '*) `(char '_))) ) ) + +(de dlsym? (S) + (and + (car (setq S (split (chop S) ':))) + (cadr S) + (low? (caar S)) ) ) + +(de lint1 ("X") + (cond + ((atom "X") + (when (sym? "X") + (cond + ((memq "X" "*L") (setq "*Use" (delq "X" "*Use"))) + ((local? "X") (lint2 (val "X"))) + (T + (or + (getd "X") + (global? "X") + (member (cons "*X" "X") *NoLint) + (memq "X" "*Bnd") + (push '"*Bnd" "X") ) ) ) ) ) + ((num? (car "X"))) + (T + (case (car "X") + ((: ::)) + (; (lint1 (cadr "X"))) + (quote + (let F (fun? (cdr "X")) + (if (or (and (pair F) (not (fin @))) (== '@ F)) + (use "*L" (lintFun (cdr "X"))) + (lint2 (cdr "X")) ) ) ) + ((de dm) + (let "*X" (cadr "X") + (lintFun (cddr "X")) ) ) + (recur + (let recurse (cdr "X") + (lintFun recurse) ) ) + (task + (lint1 (cadr "X")) + (let "Y" (cddr "X") + (use "*L" + (while (num? (car "Y")) + (pop '"Y") ) + (while (and (car "Y") (sym? @)) + (lintVar (pop '"Y")) + (pop '"Y") ) + (mapc lint1 "Y") ) ) ) + (let? + (use "*L" + (lintVar (cadr "X")) + (mapc lint1 (cddr "X")) ) ) + (let + (use "*L" + (if (atom (cadr "X")) + (lintVar (cadr "X")) + (for (L (cadr "X") L (cddr L)) + (lintDup (car L) + (extract '((X F) (and F X)) + (cddr L) + '(T NIL .) ) ) + (lintVar (car L)) + (lint1 (cadr L)) ) ) + (mapc lint1 (cddr "X")) ) ) + (use + (use "*L" + (if (atom (cadr "X")) + (lintVar (cadr "X")) + (mapc lintVar (cadr "X")) ) + (mapc lint1 (cddr "X")) ) ) + (for + (use "*L" + (let "Y" (cadr "X") + (cond + ((atom "Y") # (for X (1 2 ..) ..) + (lint1 (caddr "X")) + (lintVar "Y") + (lintLoop (cdddr "X")) ) + ((atom (cdr "Y")) # (for (I . X) (1 2 ..) ..) + (lintVar (car "Y")) + (lint1 (caddr "X")) + (lintVar (cdr "Y")) + (lintLoop (cdddr "X")) ) + ((atom (car "Y")) # (for (X (1 2 ..) ..) ..) + (lint1 (cadr "Y")) + (lintVar (car "Y")) + (mapc lint1 (cddr "Y")) + (lintLoop (cddr "X")) ) + (T # (for ((I . L) (1 2 ..) ..) ..) + (lintVar (caar "Y")) + (lint1 (cadr "Y")) + (lintVar (cdar "Y")) + (mapc lint1 (cddr "Y")) + (lintLoop (cddr "X")) ) ) ) ) ) + ((case state) + (lint1 (cadr "X")) + (for "X" (cddr "X") + (mapc lint1 (cdr "X")) ) ) + ((cond nond) + (for "X" (cdr "X") + (mapc lint1 "X") ) ) + (loop + (lintLoop (cdr "X")) ) + (do + (lint1 (cadr "X")) + (lintLoop (cddr "X")) ) + (=: + (lint1 (last (cddr "X"))) ) + ((dec inc pop push push1 queue fifo val idx accu) + (_lintq '(T)) ) + ((cut port) + (_lintq '(NIL T)) ) + (set + (_lintq '(T NIL .)) ) + (xchg + (_lintq '(T T .)) ) + (T + (cond + ((pair (car "X")) + (lint1 @) + (mapc lint2 (cdr "X")) ) + ((memq (car "X") "*L") + (setq "*Use" (delq (car "X") "*Use")) + (mapc lint2 (cdr "X")) ) + ((fun? (val (car "X"))) + (if (num? @) + (mapc lint1 (cdr "X")) + (when (local? (car "X")) + (lint2 (val (car "X"))) ) + (let "Y" (car (getd (pop '"X"))) + (while (and (pair "X") (pair "Y")) + (lint1 (pop '"X")) + (pop '"Y") ) + (if (or (== '@ "Y") (= "Prg" "Y") (= "*Prg" "Y")) + (mapc lint1 "X") + (lint2 "X") ) ) ) ) + (T + (or + (str? (car "X")) + (dlsym? (car "X")) + (== '@ (car "X")) + (memq (car "X") *NoLint) + (memq (car "X") "*Def") + (push '"*Def" (car "X")) ) + (mapc lint1 (cdr "X")) ) ) ) ) ) ) ) + +(de lint2 (X Mark) + (cond + ((memq X Mark)) + ((atom X) + (and (memq X "*L") (setq "*Use" (delq X "*Use"))) ) + (T (lint2 (car X)) + (lint2 (cdr X) (cons X Mark)) ) ) ) + +(de lintVar (X Flg) + (cond + ((or (not (sym? X)) (memq X '(NIL ^ meth quote T))) + (push '"*Var" X) ) + ((not (global? X)) + (or + Flg + (member (cons "*X" X) *NoLint) + (memq X "*Use") + (push '"*Use" X) ) + (push '"*L" X) ) ) ) + +(de lintDup (X Lst) + (and + (memq X Lst) + (not (member (cons "*X" X) *NoLint)) + (push '"*Dup" X) ) ) + +(de lintLoop ("Lst") + (for "Y" "Lst" + (if (and (pair "Y") (or (=T (car "Y")) (not (car "Y")))) + (mapc lint1 (cdr "Y")) + (lint1 "Y") ) ) ) + +(de _lintq (Lst) + (mapc + '((X Flg) + (lint1 (if Flg (strip X) X)) ) + (cdr "X") + Lst ) ) + +(de lintFun ("Lst") + (let "A" (and (pair "Lst") (car "Lst")) + (while (pair "A") + (lintDup (car "A") (cdr "A")) + (lintVar (pop '"A") T) ) + (when "A" + (lintVar "A") ) + (mapc lint1 (cdr "Lst")) ) ) + +(de lint ("X" "C") + (let ("*L" NIL "*Var" NIL "*Dup" NIL "*Def" NIL "*Bnd" NIL "*Use" NIL) + (when (pair "X") + (setq "C" (cdr "X") "X" (car "X")) ) + (cond + ("C" # Method + (let "*X" (cons "X" "C") + (lintFun (method "X" "C")) ) ) + ((pair (val "X")) # Function + (let "*X" "X" + (lintFun (val "X")) ) ) + ((info "X") # File name + (let "*X" "X" + (in "X" (while (read) (lint1 @))) ) ) + (T (quit "Can't lint" "X")) ) + (when (or "*Var" "*Dup" "*Def" "*Bnd" "*Use") + (make + # Bad variables + (and "*Var" (link (cons 'var "*Var"))) + # Duplicate parameters + (and "*Dup" (link (cons 'dup "*Dup"))) + # Undefined functions + (and "*Def" (link (cons 'def "*Def"))) + # Unbound variables + (and "*Bnd" (<> `(char '_) (char "X")) (link (cons 'bnd "*Bnd"))) + # Unused variables + (and "*Use" (link (cons 'use "*Use"))) ) ) ) ) + +(de lintAll @ + (let *Dbg NIL + (make + (for "X" (all) + (cond + ((= `(char "+") (char "X")) + (for "Y" (val "X") + (and + (pair "Y") + (fun? (cdr "Y")) + (lint (car "Y") "X") + (link (cons (cons (car "Y") "X") @)) ) ) ) + ((and (not (global? "X")) (pair (getd "X")) (lint "X")) + (link (cons "X" @)) ) ) ) + (while (args) + (and (lint (next)) (link (cons (arg) @))) ) ) ) ) + +############ lib/xm.l ############ + +# Check or write header +(de xml? (Flg) + (if Flg + (prinl "<?xml version=\"1.0\" encoding=\"utf-8\"?>") + (skip) + (prog1 + (head '("<" "?" "x" "m" "l") (till ">")) + (char) ) ) ) + +# Generate/Parse XML data +(de xml (Lst N) + (if Lst + (let Tag (pop 'Lst) + (space (default N 0)) + (prin "<" Tag) + (for X (pop 'Lst) + (prin " " (car X) "=\"") + (escXml (cdr X)) + (prin "\"") ) + (nond + (Lst (prinl "/>")) + ((or (cdr Lst) (pair (car Lst))) + (prin ">") + (escXml (car Lst)) + (prinl "</" Tag ">") ) + (NIL + (prinl ">") + (for X Lst + (if (pair X) + (xml X (+ 3 N)) + (space (+ 3 N)) + (escXml X) + (prinl) ) ) + (space N) + (prinl "</" Tag ">") ) ) ) + (skip) + (unless (= "<" (char)) + (quit "Bad XML") ) + (_xml (till " /<>" T)) ) ) + +(de _xml (Tok) + (use X + (make + (link (intern Tok)) + (let L + (make + (loop + (NIL (skip) (quit "XML parse error")) + (T (member @ '`(chop "/>"))) + (NIL (setq X (intern (till "=" T)))) + (char) + (unless (= "\"" (char)) + (quit "XML parse error" X) ) + (link (cons X (pack (xmlEsc (till "\""))))) + (char) ) ) + (if (= "/" (char)) + (prog (char) (and L (link L))) + (link L) + (loop + (NIL (skip) (quit "XML parse error" Tok)) + (T (and (= "<" (setq X (char))) (= "/" (peek))) + (char) + (unless (= Tok (till " /<>" T)) + (quit "Unbalanced XML" Tok) ) + (char) ) + (if (= "<" X) + (and (_xml (till " /<>" T)) (link @)) + (link + (pack (xmlEsc (trim (cons X (till "^J<"))))) ) ) ) ) ) ) ) ) + +(de xmlEsc (L) + (use (@X @Z) + (make + (while L + (ifn (match '("&" @X ";" @Z) L) + (link (pop 'L)) + (link + (cond + ((= @X '`(chop "quot")) "\"") + ((= @X '`(chop "amp")) "&") + ((= @X '`(chop "lt")) "<") + ((= @X '`(chop "gt")) ">") + ((= @X '`(chop "apos")) "'") + ((= "#" (car @X)) + (char + (if (= "x" (cadr @X)) + (hex (cddr @X)) + (format (cdr @X)) ) ) ) + (T @X) ) ) + (setq L @Z) ) ) ) ) ) + +(de escXml (X) + (for C (chop X) + (if (member C '`(chop "\"&<")) + (prin "&#" (char C) ";") + (prin C) ) ) ) + + +# Access functions +(de body (Lst . @) + (while (and (setq Lst (cddr Lst)) (args)) + (setq Lst (assoc (next) Lst)) ) + Lst ) + +(de attr (Lst Key . @) + (while (args) + (setq + Lst (assoc Key (cddr Lst)) + Key (next) ) ) + (cdr (assoc Key (cadr Lst))) ) + +############ lib/xmlrpc.l ############ + +# (xmlrpc "localhost" 8080 "foo.bar" 'int 41 'string "abc" ..) +(de xmlrpc (Host Port Meth . @) + (let? Sock (connect Host Port) + (let Xml (tmp 'xmlrpc) + (out Xml + (xml? T) + (xml + (list 'methodCall NIL + (list 'methodName NIL Meth) + (make + (link 'params NIL) + (while (args) + (link + (list 'param NIL + (list 'value NIL (list (next) NIL (next))) ) ) ) ) ) ) ) + (prog1 + (out Sock + (prinl "POST /RPC2 HTTP/1.0^M") + (prinl "Host: " Host "^M") + (prinl "User-Agent: PicoLisp^M") + (prinl "Content-Type: text/xml^M") + (prinl "Accept-Charset: utf-8^M") + (prinl "Content-Length: " (car (info Xml)) "^M") + (prinl "^M") + (in Xml (echo)) + (flush) + (in Sock + (while (line)) + (let? L (and (xml?) (xml)) + (when (== 'methodResponse (car L)) + (xmlrpcValue + (car (body L 'params 'param 'value)) ) ) ) ) ) + (close Sock) ) ) ) ) + +(de xmlrpcKey (Str) + (or (format Str) (intern Str)) ) + +(de xmlrpcValue (Lst) + (let X (caddr Lst) + (case (car Lst) + (string X) + ((i4 int) (format X)) + (boolean (= "1" X)) + (double (format X *Scl)) + (array + (when (== 'data (car X)) + (mapcar + '((L) + (and (== 'value (car L)) (xmlrpcValue (caddr L))) ) + (cddr X) ) ) ) + (struct + (extract + '((L) + (when (== 'member (car L)) + (cons + (xmlrpcKey (caddr (assoc 'name L))) + (xmlrpcValue (caddr (assoc 'value L))) ) ) ) + (cddr Lst) ) ) ) ) ) + +# vi:et:ts=3:sw=3 diff --git a/ersatz/mkJar b/ersatz/mkJar @@ -1,8 +1,8 @@ -#!./picolisp ../lib.l -# 14nov10abu +#!./picolisp +# 17nov10abu # (c) Software Lab. Alexander Burger -(load "@ext.l" "@src64/version.l") +(load "../src64/version.l") # Build Ersatz PicoLisp diff --git a/ersatz/picolisp b/ersatz/picolisp @@ -1,5 +1,5 @@ #!/bin/sh -# 12nov10abu +# 17nov10abu # Run Ersatz PicoLisp -exec java -DPID=$$ -jar ${0%/*}/picolisp.jar "$@" +exec java -DPID=$$ -jar ${0%/*}/picolisp.jar -"on *Dbg" ${0%/*}/lib.l "$@" diff --git a/ersatz/picolisp.jar b/ersatz/picolisp.jar Binary files differ. diff --git a/lib/xm.l b/lib/xm.l @@ -1,4 +1,4 @@ -# 30apr10abu +# 17nov10abu # (c) Software Lab. Alexander Burger # Check or write header @@ -72,7 +72,7 @@ (pack (xmlEsc (trim (cons X (till "^J<"))))) ) ) ) ) ) ) ) ) (de xmlEsc (L) - (use (@A @X @Z) + (use (@X @Z) (make (while L (ifn (match '("&" @X ";" @Z) L) diff --git a/src64/version.l b/src64/version.l @@ -1,6 +1,6 @@ -# 16nov10abu +# 17nov10abu # (c) Software Lab. Alexander Burger -(de *Version 3 0 4 9) +(de *Version 3 0 4 10) # vi:et:ts=3:sw=3