lib.l (11594B)
1 # 31jul13abu 2 # (c) Software Lab. Alexander Burger 3 4 (de task (Key . Prg) 5 (nond 6 (Prg (del (assoc Key *Run) '*Run)) 7 ((num? Key) (quit "Bad Key" Key)) 8 ((assoc Key *Run) 9 (push '*Run 10 (conc 11 (make 12 (when (lt0 (link Key)) 13 (link (+ (eval (pop 'Prg) 1))) ) ) 14 (ifn (sym? (car Prg)) 15 Prg 16 (cons 17 (cons 'job 18 (cons 19 (lit 20 (make 21 (while (atom (car Prg)) 22 (link 23 (cons (pop 'Prg) (eval (pop 'Prg) 1)) ) ) ) ) 24 Prg ) ) ) ) ) ) ) 25 (NIL (quit "Key conflict" Key)) ) ) 26 27 (de forked () 28 (let N (caar *Run) 29 (when (gt0 N) 30 (push '*Fork (list 'close N)) ) 31 (push '*Fork (list 'task N)) ) ) 32 33 (de timeout (N) 34 (if2 N (assoc -1 *Run) 35 (set (cdr @) (+ N)) 36 (push '*Run (list -1 (+ N) '(bye))) 37 (del @ '*Run) ) ) 38 39 (de abort ("N" . "Prg") 40 (catch 'abort 41 (alarm "N" (throw 'abort)) 42 (finally (alarm 0) (run "Prg")) ) ) 43 44 (de macro "Prg" 45 (run (fill "Prg")) ) 46 47 (de later ("@Var" . "@Prg") 48 (macro 49 (task (pipe (pr (prog . "@Prg"))) 50 (setq "@Var" (in @ (rd))) 51 (task (close @)) ) ) 52 "@Var" ) 53 54 (de recur recurse 55 (run (cdr recurse)) ) 56 57 (de curry "Z" 58 (let ("X" (pop '"Z") "Y" (pop '"Z") "P" (filter pat? "X")) 59 (if2 "P" (diff "X" "P") 60 (list "Y" (cons 'job (lit (env @)) (fill "Z" "P"))) 61 (cons "Y" (fill "Z" "P")) 62 (list "Y" (cons 'job (lit (env @)) "Z")) 63 (cons "Y" "Z") ) ) ) 64 65 (====) 66 67 ### Definitions ### 68 (de expr ("F") 69 (set "F" 70 (list '@ (list 'pass (box (getd "F")))) ) ) 71 72 (de subr ("F") 73 (set "F" 74 (getd (cadr (cadr (getd "F")))) ) ) 75 76 (de undef ("X" "C") 77 (when (pair "X") 78 (setq "C" (cdr "X") "X" (car "X")) ) 79 (ifn "C" 80 (prog1 (val "X") (set "X")) 81 (prog1 82 (cdr (asoq "X" (val "C"))) 83 (set "C" 84 (delq (asoq "X" (val "C")) (val "C")) ) ) ) ) 85 86 (de redef "Lst" 87 (let ("Old" (car "Lst") "New" (name "Old")) 88 (set 89 "New" (getd "Old") 90 "Old" "New" 91 "Old" (fill (cdr "Lst") "Old") ) 92 "New" ) ) 93 94 (de daemon ("X" . Prg) 95 (prog1 96 (nond 97 ((pair "X") 98 (or (pair (getd "X")) (expr "X")) ) 99 ((pair (cdr "X")) 100 (method (car "X") (cdr "X")) ) 101 (NIL 102 (method (car "X") (get (or (cddr "X") *Class) (cadr "X"))) ) ) 103 (con @ (append Prg (cdr @))) ) ) 104 105 (de patch ("Lst" "Pat" . "Prg") 106 (bind (fish pat? "Pat") 107 (recur ("Lst") 108 (loop 109 (cond 110 ((match "Pat" (car "Lst")) 111 (set "Lst" (run "Prg")) ) 112 ((pair (car "Lst")) 113 (recurse @) ) ) 114 (NIL (cdr "Lst")) 115 (T (atom (cdr "Lst")) 116 (when (match "Pat" (cdr "Lst")) 117 (con "Lst" (run "Prg")) ) ) 118 (setq "Lst" (cdr "Lst")) ) ) ) ) 119 120 (====) 121 122 (de cache ("Var" "Str" . Prg) 123 (nond 124 ((setq "Var" (car (idx "Var" "Str" T))) 125 (set "Str" "Str" "Str" (run Prg 1)) ) 126 ((n== "Var" (val "Var")) 127 (set "Var" (run Prg 1)) ) 128 (NIL (val "Var")) ) ) 129 130 (====) 131 132 ### I/O ### 133 (de tab (Lst . @) 134 (for N Lst 135 (let V (next) 136 (and (gt0 N) (space (- N (length V)))) 137 (prin V) 138 (and (lt0 N) (args) (space (- 0 N (length V)))) ) ) 139 (prinl) ) 140 141 (de beep () 142 (prin "^G") ) 143 144 (de msg (X . @) 145 (out 2 146 (print X) 147 (pass prinl) 148 (flush) ) 149 X ) 150 151 (de script (File . @) 152 (load File) ) 153 154 (de once Prg 155 (unless (idx '*Once (file) T) 156 (run Prg 1) ) ) 157 158 (de pil @ 159 (when (== "Pil" '"Pil") 160 (call 'mkdir "-p" (setq "Pil" `(pack (sys "HOME") "/.pil/"))) ) 161 (pass pack "Pil") ) 162 163 (de rc (File Key . @) 164 (ctl File 165 (let Lst (in File (read)) 166 (ifn (args) 167 (cdr (assoc Key Lst)) 168 (let Val (next) 169 (if (assoc Key Lst) 170 (con @ Val) 171 (push 'Lst (cons Key Val)) ) 172 (protect 173 (out File (println Lst)) ) 174 Val ) ) ) ) ) 175 176 (de acquire (File) 177 (ctl File 178 (let P (in File (rd)) 179 (or 180 (= P *Pid) 181 (unless (and P (kill P 0)) 182 (out File (pr *Pid)) ) ) ) ) ) 183 184 (de release (File) 185 (ctl File (out File)) ) 186 187 # Temporary Files 188 (de tmp @ 189 (unless *Tmp 190 (push '*Bye '(call 'rm "-r" *Tmp)) 191 (push '*Fork '(off *Tmp) '(del '(call 'rm "-r" *Tmp) '*Bye)) 192 (call 'mkdir "-p" (setq *Tmp (pil "tmp/" *Pid "/"))) ) 193 (pass pack *Tmp) ) 194 195 ### List ### 196 (de insert (N Lst X) 197 (conc 198 (cut (dec N) 'Lst) 199 (cons X) 200 Lst ) ) 201 202 (de remove (N Lst) 203 (conc 204 (cut (dec N) 'Lst) 205 (cdr Lst) ) ) 206 207 (de place (N Lst X) 208 (conc 209 (cut (dec N) 'Lst) 210 (cons X) 211 (cdr Lst) ) ) 212 213 (de uniq (Lst) 214 (let R NIL 215 (filter 216 '((X) (not (idx 'R X T))) 217 Lst ) ) ) 218 219 (de group (Lst) 220 (make 221 (for X Lst 222 (if (assoc (car X) (made)) 223 (conc @ (cons (cdr X))) 224 (link (list (car X) (cdr X))) ) ) ) ) 225 226 ### Symbol ### 227 (de qsym "Sym" 228 (cons (val "Sym") (getl "Sym")) ) 229 230 (de loc (S X) 231 (if (and (str? X) (= S X)) 232 X 233 (and 234 (pair X) 235 (or 236 (loc S (car X)) 237 (loc S (cdr X)) ) ) ) ) 238 239 (de local Lst 240 (mapc zap Lst) ) 241 242 (de import Lst 243 (for Sym Lst 244 (unless (== Sym (intern Sym)) 245 (quit "Import conflict" Sym) ) ) ) 246 247 ### OOP ### 248 (de class Lst 249 (let L (val (setq *Class (car Lst))) 250 (def *Class 251 (recur (L) 252 (if (atom (car L)) 253 (cdr Lst) 254 (cons (car L) (recurse (cdr L))) ) ) ) ) ) 255 256 (de object ("Sym" "Val" . @) 257 (putl "Sym") 258 (def "Sym" "Val") 259 (while (args) 260 (put "Sym" (next) (next)) ) 261 "Sym" ) 262 263 (de extend X 264 (setq *Class (car X)) ) 265 266 # Class variables 267 (de var X 268 (if (pair (car X)) 269 (put (cdar X) (caar X) (cdr X)) 270 (put *Class (car X) (cdr X)) ) ) 271 272 (de var: X 273 (apply meta X This) ) 274 275 ### Math ### 276 (de scl ("N" . "Prg") 277 (if "Prg" 278 (let *Scl "N" (run "Prg")) 279 (setq *Scl "N") ) ) 280 281 (de sqrt (N F) 282 (cond 283 ((lt0 N) (quit "Bad argument" N)) 284 (N 285 (let (A 1 B 0) 286 (while (>= N A) 287 (setq A (>> -2 A)) ) 288 (loop 289 (if (> (inc 'B A) N) 290 (dec 'B A) 291 (dec 'N B) 292 (inc 'B A) ) 293 (setq B (>> 1 B) A (>> 2 A)) 294 (T (=0 A)) ) 295 (and F (> N B) (inc 'B)) 296 B ) ) ) ) 297 298 # (Knuth Vol.2, p.442) 299 (de ** (X N) # N th power of X 300 (let Y 1 301 (loop 302 (when (bit? 1 N) 303 (setq Y (* Y X)) ) 304 (T (=0 (setq N (>> 1 N))) 305 Y ) 306 (setq X (* X X)) ) ) ) 307 308 (de accu (Var Key Val) 309 (when Val 310 (if (assoc Key (val Var)) 311 (con @ (+ Val (cdr @))) 312 (push Var (cons Key Val)) ) ) ) 313 314 ### Pretty Printing ### 315 (de *PP 316 T NIL if ifn when unless while until do case casq state for 317 with catch finally co ! setq default push bind job use let let? 318 prog1 later recur redef =: in out ctl tab new ) 319 (de *PP1 let let? for redef) 320 (de *PP2 setq default) 321 (de *PP3 if2) 322 323 (de pretty (X N . @) 324 (setq N (abs (space (or N 0)))) 325 (while (args) 326 (printsp (next)) ) 327 (if (or (atom X) (>= 12 (size X))) 328 (print X) 329 (while (== 'quote (car X)) 330 (prin "'") 331 (pop 'X) ) 332 (let Z X 333 (prin "(") 334 (cond 335 ((memq (print (pop 'X)) *PP) 336 (cond 337 ((memq (car Z) *PP1) 338 (if (and (pair (car X)) (pair (cdar X))) 339 (when (>= 12 (size (car X))) 340 (space) 341 (print (pop 'X)) ) 342 (space) 343 (print (pop 'X)) 344 (when (or (atom (car X)) (>= 12 (size (car X)))) 345 (space) 346 (print (pop 'X)) ) ) ) 347 ((memq (car Z) *PP2) 348 (inc 'N 3) 349 (loop 350 (prinl) 351 (pretty (cadr X) N (car X)) 352 (NIL (setq X (cddr X)) (space)) ) ) 353 ((or (atom (car X)) (>= 12 (size (car X)))) 354 (space) 355 (print (pop 'X)) ) ) ) 356 ((and (memq (car Z) *PP3) (>= 12 (size (head 2 X)))) 357 (space) 358 (print (pop 'X) (pop 'X)) ) ) 359 (when X 360 (loop 361 (T (== Z X) (prin " .")) 362 (T (atom X) (prin " . ") (print X)) 363 (prinl) 364 (pretty (pop 'X) (+ 3 N)) 365 (NIL X) ) 366 (space) ) 367 (prin ")") ) ) ) 368 369 (de pp ("X" C) 370 (let *Dbg NIL 371 (and (pair "X") (setq C (cdr "X"))) 372 (prin "(") 373 (printsp (if C 'dm 'de)) 374 (prog1 (printsp "X") 375 (setq "X" 376 (if C 377 (method (if (pair "X") (car "X") "X") C) 378 (val "X") ) ) 379 (cond 380 ((atom "X") (prin ". ") (print "X")) 381 ((atom (cdr "X")) 382 (ifn (cdr "X") 383 (print (car "X")) 384 (print (car "X")) 385 (prin " . ") 386 (print @) ) ) 387 (T 388 (let Z "X" 389 (print (pop '"X")) 390 (loop 391 (T (== Z "X") (prin " .")) 392 (NIL "X") 393 (T (atom "X") 394 (prin " . ") 395 (print "X") ) 396 (prinl) 397 (pretty (pop '"X") 3) ) 398 (space) ) ) ) 399 (prinl ")") ) ) ) 400 401 (de show ("X" . @) 402 (let *Dbg NIL 403 (setq "X" (pass get "X")) 404 (when (sym? "X") 405 (print "X" (val "X")) 406 (prinl) 407 (maps 408 '((X) 409 (space 3) 410 (if (atom X) 411 (println X) 412 (println (cdr X) (car X)) ) ) 413 "X" ) ) 414 "X" ) ) 415 416 (de view (X Y) 417 (let *Dbg NIL 418 (if (=T Y) 419 (let N 0 420 (recur (N X) 421 (when X 422 (recurse (+ 3 N) (cddr X)) 423 (space N) 424 (println (car X)) 425 (recurse (+ 3 N) (cadr X)) ) ) ) 426 (let Z X 427 (loop 428 (T (atom X) (println X)) 429 (if (atom (car X)) 430 (println '+-- (pop 'X)) 431 (print '+---) 432 (view 433 (pop 'X) 434 (append Y (cons (if X "| " " "))) ) ) 435 (NIL X) 436 (mapc prin Y) 437 (T (== Z X) (println '*)) 438 (println '|) 439 (mapc prin Y) ) ) ) ) ) 440 441 ### Check ### 442 # Assertions 443 (de assert Prg 444 (when *Dbg 445 (cons 446 (list 'unless 447 (if (cdr Prg) (cons 'and Prg) (car Prg)) 448 (list 'quit "'assert' failed" (lit (car Prg))) ) ) ) ) 449 450 # Unit tests 451 (de test (Pat . Prg) 452 (bind (fish pat? Pat) 453 (unless (match Pat (run Prg 1)) 454 (msg Prg) 455 (quit "'test' failed" Pat) ) ) ) 456 457 ### Debug ### 458 `*Dbg 459 (if (info (pil "editor")) 460 (load (pil "editor")) 461 (load "@lib/led.l" "@lib/edit.l") ) 462 (load "@lib/debug.l" "@lib/lint.l") 463 (noLint 'later (loc "@Prg" later)) 464 465 # vi:et:ts=3:sw=3