lib.l (6746B)
1 # 12sep07abu 2 # (c) Software Lab. Alexander Burger 3 4 (de macro "Prg" 5 (run (fill "Prg")) ) 6 7 (de recur recurse 8 (run (cdr recurse)) ) 9 10 (de curry "Z" 11 (let ("X" (pop '"Z") "Y" (pop '"Z") "P" (filter pat? "X")) 12 (if2 "P" (diff "X" "P") 13 (list "Y" (cons 'job (lit (env @)) (fill "Z" "P"))) 14 (cons "Y" (fill "Z" "P")) 15 (list "Y" (cons 'job (lit (env @)) "Z")) 16 (cons "Y" "Z") ) ) ) 17 18 (====) 19 20 (de getd ("X") 21 (and 22 (sym? "X") 23 (fun? (val "X")) 24 (val "X") ) ) 25 26 (de expr ("F") 27 (set "F" 28 (list '@ (list 'pass (box (getd "F")))) ) ) 29 30 (de subr ("F") 31 (set "F" 32 (getd (cadr (cadr (getd "F")))) ) ) 33 34 (de undef ("X" "C") 35 (when (pair "X") 36 (setq "C" (cdr "X") "X" (car "X")) ) 37 (ifn "C" 38 (prog1 (val "X") (set "X")) 39 (prog1 40 (cdr (asoq "X" (val "C"))) 41 (set "C" 42 (delq (asoq "X" (val "C")) (val "C")) ) ) ) ) 43 44 (de redef "Lst" 45 (let ("Old" (car "Lst") "New" (name "Old")) 46 (set 47 "New" (val "Old") 48 "Old" "New" 49 "Old" (fill (cdr "Lst") "Old") ) 50 "New" ) ) 51 52 (de daemon ("X" . Prg) 53 (prog1 54 (if (pair "X") 55 (method (car "X") (cdr "X")) 56 (or (pair (getd "X")) (expr "X")) ) 57 (con @ (append Prg (cdr @))) ) ) 58 59 (de patch ("Lst" "Pat" . "Prg") 60 (bind (fish pat? "Pat") 61 (recur ("Lst") 62 (loop 63 (cond 64 ((match "Pat" (car "Lst")) 65 (set "Lst" (run "Prg")) ) 66 ((pair (car "Lst")) 67 (recurse @) ) ) 68 (NIL (cdr "Lst")) 69 (T (atom (cdr "Lst")) 70 (when (match "Pat" (cdr "Lst")) 71 (con "Lst" (run "Prg")) ) ) 72 (setq "Lst" (cdr "Lst")) ) ) ) ) 73 74 (====) 75 76 (de cache ("Var" "Str" . Prg) 77 (cond 78 ((not (setq "Var" (car (idx "Var" "Str" T)))) 79 (set "Str" "Str" "Str" (run Prg 1)) ) 80 ((== "Var" (val "Var")) 81 (set "Var" (run Prg 1)) ) 82 (T (val "Var")) ) ) 83 84 (====) 85 86 (de scl (*Scl . "Prg") 87 (run "Prg") ) 88 89 (====) 90 91 ### I/O ### 92 (de tab (Lst . @) 93 (for N Lst 94 (let V (next) 95 (and (gt0 N) (space (- N (length V)))) 96 (prin V) 97 (and (lt0 N) (space (- 0 N (length V)))) ) ) 98 (prinl) ) 99 100 (de beep () 101 (prin "^G") ) 102 103 (de msg (X . @) 104 (out NIL 105 (print X) 106 (pass prinl) 107 (flush) ) 108 X ) 109 110 ### List ### 111 (de insert (N Lst X) 112 (conc 113 (cut (dec N) 'Lst) 114 (cons X) 115 Lst ) ) 116 117 (de remove (N Lst) 118 (conc 119 (cut (dec N) 'Lst) 120 (cdr Lst) ) ) 121 122 (de place (N Lst X) 123 (conc 124 (cut (dec N) 'Lst) 125 (cons X) 126 (cdr Lst) ) ) 127 128 (de uniq (Lst) 129 (let R NIL 130 (filter 131 '((X) (not (idx 'R X T))) 132 Lst ) ) ) 133 134 (de group (Lst) 135 (make 136 (while Lst 137 (if (assoc (caar Lst) (made)) 138 (conc @ (cons (cdr (pop 'Lst)))) 139 (link 140 (cons (caar Lst) (cons (cdr (pop 'Lst)))) ) ) ) ) ) 141 142 ### Symbol ### 143 (de loc (S X) 144 (if (and (str? X) (= S X)) 145 X 146 (and 147 (pair X) 148 (or 149 (loc S (car X)) 150 (loc S (cdr X)) ) ) ) ) 151 152 ### OOP ### 153 (de class Lst 154 (let L (val (setq *Class (car Lst))) 155 (def *Class 156 (recur (L) 157 (if (atom (car L)) 158 (cdr Lst) 159 (cons (car L) (recurse (cdr L))) ) ) ) ) ) 160 161 (de object ("Sym" "Typ" . @) 162 (def "Sym" "Typ") 163 (putl "Sym") 164 (while (args) 165 (put "Sym" (next) (next)) ) 166 "Sym" ) 167 168 (de extend X 169 (setq *Class (car X)) ) 170 171 # Class variables 172 (de var X 173 (put *Class (car X) (cdr X)) ) 174 175 (de var: X 176 (apply meta X This) ) 177 178 ### Pretty Printing ### 179 (de "*PP" 180 T NIL if if2 ifn when unless while until do case state for 181 with catch finally ! setq default push job use let let? 182 prog1 recur redef =: in out tab new ) 183 (de "*PP1" if2 let let? for redef) 184 (de "*PP2" setq default) 185 186 (de pretty (X N . @) 187 (setq N (abs (space (or N 0)))) 188 (while (args) 189 (printsp (next)) ) 190 (if (or (atom X) (>= 12 (size X))) 191 (print X) 192 (while (== 'quote (car X)) 193 (prin "'") 194 (pop 'X) ) 195 (let Z X 196 (prin "(") 197 (when (memq (print (pop 'X)) "*PP") 198 (cond 199 ((memq (car Z) "*PP1") 200 (if (and (pair (car X)) (pair (cdar X))) 201 (when (>= 12 (size (car X))) 202 (space) 203 (print (pop 'X)) ) 204 (space) 205 (print (pop 'X)) 206 (when (or (atom (car X)) (>= 12 (size (car X)))) 207 (space) 208 (print (pop 'X)) ) ) ) 209 ((memq (car Z) "*PP2") 210 (inc 'N 3) 211 (loop 212 (prinl) 213 (pretty (cadr X) N (car X)) 214 (NIL (setq X (cddr X))) ) ) 215 ((or (atom (car X)) (>= 12 (size (car X)))) 216 (space) 217 (print (pop 'X)) ) ) ) 218 (when X 219 (loop 220 (T (== Z X) (prin " .")) 221 (T (atom X) (prin " . ") (print X)) 222 (prinl) 223 (pretty (pop 'X) (+ 3 N)) 224 (NIL X) ) 225 (space) ) 226 (prin ")") ) ) ) 227 228 (de pp ("X" C) 229 (let *Dbg NIL 230 (when (pair "X") 231 (setq C (cdr "X")) ) 232 (prin "(") 233 (printsp (if C 'dm 'de)) 234 (prog1 235 (printsp "X") 236 (setq "X" 237 (if C 238 (method (if (pair "X") (car "X") "X") C) 239 (val "X") ) ) 240 (cond 241 ((atom "X") (print '. "X")) 242 ((atom (cdr "X")) 243 (if (cdr "X") 244 (print (car "X") '. @) 245 (print (car "X")) ) ) 246 (T (print (pop '"X")) 247 (while (pair "X") 248 (prinl) 249 (pretty (pop '"X") 3) ) 250 (when "X" 251 (prin " . ") 252 (print "X") ) 253 (space) ) ) 254 (prinl ")") ) ) ) 255 256 (de show ("X" . @) 257 (let *Dbg NIL 258 (setq "X" (apply get (rest) "X")) 259 (when (sym? "X") 260 (print "X" (val "X")) 261 (prinl) 262 (maps 263 '((X) 264 (space 3) 265 (if (atom X) 266 (println X) 267 (println (cdr X) (car X)) ) ) 268 "X" ) ) 269 "X" ) ) 270 271 (de view (X L) 272 (let (Z X *Dbg) 273 (loop 274 (T (atom X) (println X)) 275 (if (atom (car X)) 276 (println '+-- (pop 'X)) 277 (print '+---) 278 (view 279 (pop 'X) 280 (append L (cons (if X "| " " "))) ) ) 281 (NIL X) 282 (mapc prin L) 283 (T (== Z X) (println '*)) 284 (println '|) 285 (mapc prin L) ) ) ) 286 287 # vi:et:ts=3:sw=3