/arc.arc
Unknown | 1918 lines | 1534 code | 384 blank | 0 comment | 0 complexity | 1621970a85d0ee1da21ed634d460914b MD5 | raw file
Large files files are truncated, but you can click here to view the full file
1; Main Arc lib. Ported to Scheme version Jul 06. 2 3; don't like names of conswhen and consif 4 5; need better way of generating strings; too many calls to string 6; maybe strings with escape char for evaluation 7; make foo~bar equiv of foo:~bar (in expand-ssyntax) 8; add sigs of ops defined in ac.scm 9; get hold of error types within arc 10; does macex have to be defined in scheme instead of using def below? 11; write disp, read, write in arc 12; could I get all of macros up into arc.arc? 13; warn when shadow a global name 14; some simple regexp/parsing plan 15 16; compromises in this implementation: 17; no objs in code 18; (mac testlit args (listtab args)) breaks when called 19; separate string type 20; (= (cdr (cdr str)) "foo") couldn't work because no way to get str tail 21; not sure this is a mistake; strings may be subtly different from 22; lists of chars 23 24(assign current-load-file* "arc.arc") 25(assign source-file* (table)) 26(assign source* (table)) 27(assign help* (table)) 28 29(assign do (annotate 'mac 30 (fn args `((fn () ,@args))))) 31 32(sref sig 'args 'do) 33(sref source-file* current-load-file* 'do) 34 35(assign safeset (annotate 'mac 36 (fn (var val) 37 `(do (if (bound ',var) 38 (do (disp "*** redefining " (stderr)) 39 (disp ',var (stderr)) 40 (disp #\newline (stderr)))) 41 (assign ,var ,val))))) 42 43(sref sig '(var val) 'safeset) 44(sref source-file* current-load-file* 'safeset) 45 46(assign docify-body (fn (body) 47 (if (if (is (type car.body) 'string) cdr.body) body 48 (cons nil body)))) 49 50(sref sig '(body) 'docify-body) 51(sref source-file* current-load-file* 'docify-body) 52 53(assign def (annotate 'mac 54 (fn (name parms . body) 55 ((fn ((doc . body)) 56 `(do (sref sig ',parms ',name) 57 (sref help* ',doc ',name) 58 (sref source-file* current-load-file* ',name) 59 (sref source* '(def ,name ,parms ,@body) ',name) 60 (safeset ,name (fn ,parms ,@body)))) 61 (docify-body body))))) 62 63(sref sig '(name parms . body) 'def) 64(sref source-file* current-load-file* 'def) 65 66(def caar (xs) (car:car xs)) 67(def cadr (xs) (car:cdr xs)) 68(def cddr (xs) (cdr:cdr xs)) 69(def cdar (xs) (cdr:car xs)) 70(def cadar (xs) (car:cdar xs)) 71 72(def no (x) (is x nil)) 73 74(def acons (x) (is (type x) 'cons)) 75 76(def atom (x) (no (acons x))) 77 78; Can return to this def once Rtm gets ac to make all rest args 79; nil-terminated lists. 80 81; (def list args args) 82 83(def copylist (xs) 84 (if (no xs) 85 nil 86 (cons (car xs) (copylist (cdr xs))))) 87 88(def list args (copylist args)) 89 90(def idfn (x) x) 91 92; Maybe later make this internal. Useful to let xs be a fn? 93 94(def map1 (f xs) 95 (if (no xs) 96 nil 97 (cons (f (car xs)) (map1 f (cdr xs))))) 98 99(def pair (xs (o f list)) 100 (if (no xs) 101 nil 102 (no (cdr xs)) 103 (list (list (car xs))) 104 (cons (f (car xs) (cadr xs)) 105 (pair (cddr xs) f)))) 106 107(assign mac (annotate 'mac 108 (fn (name parms . body) 109 ((fn ((doc . body)) 110 `(do (sref sig ',parms ',name) 111 (sref help* ',doc ',name) 112 (sref source-file* current-load-file* ',name) 113 (sref source* '(mac ,name ,parms ,@body) ',name) 114 (safeset ,name (annotate 'mac (fn ,parms ,@body))))) 115 (docify-body body))))) 116 117(sref sig '(name parms . body) 'mac) 118(sref source-file* current-load-file* 'mac) 119 120(mac make-br-fn (body) `(fn (_) ,body)) 121 122(mac and args 123 (if args 124 (if (cdr args) 125 `(if ,(car args) (and ,@(cdr args))) 126 (car args)) 127 't)) 128 129(def assoc (key al) 130 (if (atom al) 131 nil 132 (and (acons (car al)) (is (caar al) key)) 133 (car al) 134 (assoc key (cdr al)))) 135 136(def alref (al key) (cadr (assoc key al))) 137 138(mac with (parms . body) 139 `((fn ,(map1 car (pair parms)) 140 ,@body) 141 ,@(map1 cadr (pair parms)))) 142 143(mac let (var val . body) 144 `(with (,var ,val) ,@body)) 145 146(mac withs (parms . body) 147 (if (no parms) 148 `(do ,@body) 149 `(let ,(car parms) ,(cadr parms) 150 (withs ,(cddr parms) ,@body)))) 151 152; Rtm prefers to overload + to do this 153 154(def join args 155 (if (no args) 156 nil 157 (let a (car args) 158 (if (no a) 159 (apply join (cdr args)) 160 (cons (car a) (apply join (cdr a) (cdr args))))))) 161 162; Need rfn for use in macro expansions. 163 164(mac rfn (name parms . body) 165 `(let ,name nil 166 (assign ,name (fn ,parms ,@body)))) 167 168(mac afn (parms . body) 169 `(let self nil 170 (assign self (fn ,parms ,@body)))) 171 172; Ac expands x:y:z into (compose x y z), ~x into (complement x) 173 174; Only used when the call to compose doesn't occur in functional position. 175; Composes in functional position are transformed away by ac. 176 177(mac compose args 178 (let g (uniq) 179 `(fn ,g 180 ,((afn (fs) 181 (if (cdr fs) 182 (list (car fs) (self (cdr fs))) 183 `(apply ,(if (car fs) (car fs) 'idfn) ,g))) 184 args)))) 185 186; Ditto: complement in functional position optimized by ac. 187 188(mac complement (f) 189 (let g (uniq) 190 `(fn ,g (no (apply ,f ,g))))) 191 192(def rev (xs) 193 ((afn (xs acc) 194 (if (no xs) 195 acc 196 (self (cdr xs) (cons (car xs) acc)))) 197 xs nil)) 198 199(def isnt (x y) (no (is x y))) 200 201(mac w/uniq (names . body) 202 (if (acons names) 203 `(with ,(apply + nil (map1 (fn (n) (list n '(uniq))) 204 names)) 205 ,@body) 206 `(let ,names (uniq) ,@body))) 207 208(mac or args 209 (and args 210 (w/uniq g 211 `(let ,g ,(car args) 212 (if ,g ,g (or ,@(cdr args))))))) 213 214(def alist (x) (or (no x) (is (type x) 'cons))) 215 216(mac in (x . choices) 217 (w/uniq g 218 `(let ,g ,x 219 (or ,@(map1 (fn (c) `(is ,g ,c)) choices))))) 220 221; bootstrapping version; overloaded later as a generic function 222(def iso (x y) 223 (or (is x y) 224 (and (acons x) 225 (acons y) 226 (iso (car x) (car y)) 227 (iso (cdr x) (cdr y))))) 228 229(mac when (test . body) 230 `(if ,test (do ,@body))) 231 232(mac unless (test . body) 233 `(if (no ,test) (do ,@body))) 234 235(mac while (test . body) 236 (w/uniq (gf gp) 237 `((rfn ,gf (,gp) 238 (when ,gp ,@body (,gf ,test))) 239 ,test))) 240 241(def empty (seq) 242 (or (no seq) 243 (and (or (is (type seq) 'string) (is (type seq) 'table)) 244 (is (len seq) 0)))) 245 246(def reclist (f xs) 247 (and xs (or (f xs) (reclist f (cdr xs))))) 248 249(def recstring (test s (o start 0)) 250 ((afn (i) 251 (and (< i (len s)) 252 (or (test i) 253 (self (+ i 1))))) 254 start)) 255 256(def testify (x) 257 (if (isa x 'fn) x [is _ x])) 258 259; Like keep, seems like some shouldn't testify. But find should, 260; and all probably should. 261 262(def some (test seq) 263 (let f (testify test) 264 (if (alist seq) 265 (reclist f:car seq) 266 (recstring f:seq seq)))) 267 268(def all (test seq) 269 (~some (complement (testify test)) seq)) 270 271(def mem (test seq) 272 (let f (testify test) 273 (reclist [if (f:car _) _] seq))) 274 275(def find (test seq) 276 (let f (testify test) 277 (if (alist seq) 278 (reclist [if (f:car _) (car _)] seq) 279 (recstring [if (f:seq _) (seq _)] seq)))) 280 281(def isa (x y) (is (type x) y)) 282 283; Possible to write map without map1, but makes News 3x slower. 284 285;(def map (f . seqs) 286; (if (some1 no seqs) 287; nil 288; (no (cdr seqs)) 289; (let s1 (car seqs) 290; (cons (f (car s1)) 291; (map f (cdr s1)))) 292; (cons (apply f (map car seqs)) 293; (apply map f (map cdr seqs))))) 294 295 296(def map (f . seqs) 297 (if (some [isa _ 'string] seqs) 298 (withs (n (apply min (map len seqs)) 299 new (newstring n)) 300 ((afn (i) 301 (if (is i n) 302 new 303 (do (sref new (apply f (map [_ i] seqs)) i) 304 (self (+ i 1))))) 305 0)) 306 (no (cdr seqs)) 307 (map1 f (car seqs)) 308 ((afn (seqs) 309 (if (some no seqs) 310 nil 311 (cons (apply f (map1 car seqs)) 312 (self (map1 cdr seqs))))) 313 seqs))) 314 315(def mappend (f . args) 316 (apply + nil (apply map f args))) 317 318(def firstn (n xs) 319 (if (no n) xs 320 (and (> n 0) xs) (cons (car xs) (firstn (- n 1) (cdr xs))) 321 nil)) 322 323(def nthcdr (n xs) 324 (if (no n) xs 325 (> n 0) (nthcdr (- n 1) (cdr xs)) 326 xs)) 327 328; Generalization of pair: (tuples x) = (pair x) 329 330(def tuples (xs (o n 2)) 331 (if (no xs) 332 nil 333 (cons (firstn n xs) 334 (tuples (nthcdr n xs) n)))) 335 336; If ok to do with =, why not with def? But see if use it. 337 338(mac defs args 339 `(do ,@(map [cons 'def _] (tuples args 3)))) 340 341(def caris (x val) 342 (and (acons x) (is (car x) val))) 343 344(def warn (msg . args) 345 (disp (+ "Warning: " msg ". ")) 346 (map [do (write _) (disp " ")] args) 347 (disp #\newline)) 348 349(mac atomic body 350 `(atomic-invoke (fn () ,@body))) 351 352(mac atlet args 353 `(atomic (let ,@args))) 354 355(mac atwith args 356 `(atomic (with ,@args))) 357 358(mac atwiths args 359 `(atomic (withs ,@args))) 360 361; setforms returns (vars get set) for a place based on car of an expr 362; vars is a list of gensyms alternating with expressions whose vals they 363; should be bound to, suitable for use as first arg to withs 364; get is an expression returning the current value in the place 365; set is an expression representing a function of one argument 366; that stores a new value in the place 367 368; A bit gross that it works based on the *name* in the car, but maybe 369; wrong to worry. Macros live in expression land. 370 371; seems meaningful to e.g. (push 1 (pop x)) if (car x) is a cons. 372; can't in cl though. could I define a setter for push or pop? 373 374(assign setter (table)) 375 376(mac defset (name parms . body) 377 (w/uniq gexpr 378 `(sref setter 379 (fn (,gexpr) 380 (let ,parms (cdr ,gexpr) 381 ,@body)) 382 ',name))) 383 384(defset car (x) 385 (w/uniq g 386 (list (list g x) 387 `(car ,g) 388 `(fn (val) (scar ,g val))))) 389 390(defset cdr (x) 391 (w/uniq g 392 (list (list g x) 393 `(cdr ,g) 394 `(fn (val) (scdr ,g val))))) 395 396(defset caar (x) 397 (w/uniq g 398 (list (list g x) 399 `(caar ,g) 400 `(fn (val) (scar (car ,g) val))))) 401 402(defset cadr (x) 403 (w/uniq g 404 (list (list g x) 405 `(cadr ,g) 406 `(fn (val) (scar (cdr ,g) val))))) 407 408(defset cddr (x) 409 (w/uniq g 410 (list (list g x) 411 `(cddr ,g) 412 `(fn (val) (scdr (cdr ,g) val))))) 413 414; Note: if expr0 macroexpands into any expression whose car doesn't 415; have a setter, setforms assumes it's a data structure in functional 416; position. Such bugs will be seen only when the code is executed, when 417; sref complains it can't set a reference to a function. 418 419(def setforms (expr0) 420 (let expr (macex expr0) 421 (if (isa expr 'sym) 422 (if (ssyntax expr) 423 (setforms (ssexpand expr)) 424 (w/uniq (g h) 425 (list (list g expr) 426 g 427 `(fn (,h) (assign ,expr ,h))))) 428 ; make it also work for uncompressed calls to compose 429 (and (acons expr) (metafn (car expr))) 430 (setforms (expand-metafn-call (ssexpand (car expr)) (cdr expr))) 431 (and (acons expr) (acons (car expr)) (is (caar expr) 'get)) 432 (setforms (list (cadr expr) (cadr (car expr)))) 433 (let f (setter (car expr)) 434 (if f 435 (f expr) 436 ; assumed to be data structure in fn position 437 (do (when (caris (car expr) 'fn) 438 (warn "Inverting what looks like a function call" 439 expr0 expr)) 440 (w/uniq (g h) 441 (let argsyms (map [uniq] (cdr expr)) 442 (list (+ (list g (car expr)) 443 (mappend list argsyms (cdr expr))) 444 `(,g ,@argsyms) 445 `(fn (,h) (sref ,g ,h ,(car argsyms)))))))))))) 446 447(def metafn (x) 448 (or (ssyntax x) 449 (and (acons x) (in (car x) 'compose 'complement)))) 450 451(def expand-metafn-call (f args) 452 (if (is (car f) 'compose) 453 ((afn (fs) 454 (if (caris (car fs) 'compose) ; nested compose 455 (self (join (cdr (car fs)) (cdr fs))) 456 (cdr fs) 457 (list (car fs) (self (cdr fs))) 458 (cons (car fs) args))) 459 (cdr f)) 460 (is (car f) 'no) 461 (err "Can't invert " (cons f args)) 462 (cons f args))) 463 464(def expand= (place val) 465 (if (and (isa place 'sym) (~ssyntax place)) 466 `(assign ,place ,val) 467 (let (vars prev setter) (setforms place) 468 (w/uniq g 469 `(atwith ,(+ vars (list g val)) 470 (,setter ,g)))))) 471 472(def expand=list (terms) 473 `(do ,@(map (fn ((p v)) (expand= p v)) ; [apply expand= _] 474 (pair terms)))) 475 476(mac = args 477 (expand=list args)) 478 479(mac loop (start test update . body) 480 (w/uniq (gfn gparm) 481 `(do ,start 482 ((rfn ,gfn (,gparm) 483 (if ,gparm 484 (do ,@body ,update (,gfn ,test)))) 485 ,test)))) 486 487(mac for (v init max . body) 488 (w/uniq (gi gm) 489 `(with (,v nil ,gi ,init ,gm (+ ,max 1)) 490 (loop (assign ,v ,gi) (< ,v ,gm) (assign ,v (+ ,v 1)) 491 ,@body)))) 492 493(mac down (v init min . body) 494 (w/uniq (gi gm) 495 `(with (,v nil ,gi ,init ,gm (- ,min 1)) 496 (loop (assign ,v ,gi) (> ,v ,gm) (assign ,v (- ,v 1)) 497 ,@body)))) 498 499(mac repeat (n . body) 500 `(for ,(uniq) 1 ,n ,@body)) 501 502; could bind index instead of gensym 503 504(def walk (seq func) 505 (if alist.seq 506 ((afn (l) 507 (when (acons l) 508 (func (car l)) 509 (self (cdr l)))) seq) 510 (isa seq 'table) 511 (maptable (fn (k v) (func (list k v))) seq) 512 ; else 513 (for i 0 (- (len seq) 1) 514 (func (seq i))))) 515 516(mac each (var expr . body) 517 `(walk ,expr (fn (,var) ,@body))) 518 519; ; old definition of 'each. possibly faster, but not extendable. 520; (mac each (var expr . body) 521; (w/uniq (gseq gf gv) 522; `(let ,gseq ,expr 523; (if (alist ,gseq) 524; ((rfn ,gf (,gv) 525; (when (acons ,gv) 526; (let ,var (car ,gv) ,@body) 527; (,gf (cdr ,gv)))) 528; ,gseq) 529; (isa ,gseq 'table) 530; (maptable (fn ,var ,@body) 531; ,gseq) 532; (for ,gv 0 (- (len ,gseq) 1) 533; (let ,var (,gseq ,gv) ,@body)))))) 534 535; (nthcdr x y) = (cut y x). 536 537(def cut (seq start (o end)) 538 (let end (if (no end) (len seq) 539 (< end 0) (+ (len seq) end) 540 end) 541 (if (isa seq 'string) 542 (let s2 (newstring (- end start)) 543 (for i 0 (- end start 1) 544 (= (s2 i) (seq (+ start i)))) 545 s2) 546 (firstn (- end start) (nthcdr start seq))))) 547 548(mac whilet (var test . body) 549 (w/uniq (gf gp) 550 `((rfn ,gf (,gp) 551 (let ,var ,gp 552 (when ,var ,@body (,gf ,test)))) 553 ,test))) 554 555(def last (xs) 556 (if (cdr xs) 557 (last (cdr xs)) 558 (car xs))) 559 560(def rem (test seq) 561 (let f (testify test) 562 (if (alist seq) 563 ((afn (s) 564 (if (no s) nil 565 (f (car s)) (self (cdr s)) 566 (cons (car s) (self (cdr s))))) 567 seq) 568 (coerce (rem test (coerce seq 'cons)) 'string)))) 569 570; Seems like keep doesn't need to testify-- would be better to 571; be able to use tables as fns. But rem does need to, because 572; often want to rem a table from a list. So maybe the right answer 573; is to make keep the more primitive, not rem. 574 575(def keep (test seq) 576 (rem (complement (testify test)) seq)) 577 578;(def trues (f seq) 579; (rem nil (map f seq))) 580 581(def trues (f xs) 582 (and xs 583 (let fx (f (car xs)) 584 (if fx 585 (cons fx (trues f (cdr xs))) 586 (trues f (cdr xs)))))) 587 588(mac do1 args 589 (w/uniq g 590 `(let ,g ,(car args) 591 ,@(cdr args) 592 ,g))) 593 594; Would like to write a faster case based on table generated by a macro, 595; but can't insert objects into expansions in Mzscheme. 596 597(mac caselet (var expr . args) 598 (let ex (afn (args) 599 (if (no (cdr args)) 600 (car args) 601 `(if (is ,var ',(car args)) 602 ,(cadr args) 603 ,(self (cddr args))))) 604 `(let ,var ,expr ,(ex args)))) 605 606(mac case (expr . args) 607 `(caselet ,(uniq) ,expr ,@args)) 608 609(mac push (x place) 610 (w/uniq gx 611 (let (binds val setter) (setforms place) 612 `(let ,gx ,x 613 (atwiths ,binds 614 (,setter (cons ,gx ,val))))))) 615 616(mac swap (place1 place2) 617 (w/uniq (g1 g2) 618 (with ((binds1 val1 setter1) (setforms place1) 619 (binds2 val2 setter2) (setforms place2)) 620 `(atwiths ,(+ binds1 (list g1 val1) binds2 (list g2 val2)) 621 (,setter1 ,g2) 622 (,setter2 ,g1))))) 623 624(mac rotate places 625 (with (vars (map [uniq] places) 626 forms (map setforms places)) 627 `(atwiths ,(mappend (fn (g (binds val setter)) 628 (+ binds (list g val))) 629 vars 630 forms) 631 ,@(map (fn (g (binds val setter)) 632 (list setter g)) 633 (+ (cdr vars) (list (car vars))) 634 forms)))) 635 636(mac pop (place) 637 (w/uniq g 638 (let (binds val setter) (setforms place) 639 `(atwiths ,(+ binds (list g val)) 640 (do1 (car ,g) 641 (,setter (cdr ,g))))))) 642 643(def adjoin (x xs (o test iso)) 644 (if (some [test x _] xs) 645 xs 646 (cons x xs))) 647 648(mac pushnew (x place . args) 649 (w/uniq gx 650 (let (binds val setter) (setforms place) 651 `(atwiths ,(+ (list gx x) binds) 652 (,setter (adjoin ,gx ,val ,@args)))))) 653 654(mac pull (test place) 655 (w/uniq g 656 (let (binds val setter) (setforms place) 657 `(atwiths ,(+ (list g test) binds) 658 (,setter (rem ,g ,val)))))) 659 660(mac togglemem (x place . args) 661 (w/uniq gx 662 (let (binds val setter) (setforms place) 663 `(atwiths ,(+ (list gx x) binds) 664 (,setter (if (mem ,gx ,val) 665 (rem ,gx ,val) 666 (adjoin ,gx ,val ,@args))))))) 667 668(mac ++ (place (o i 1)) 669 (if (isa place 'sym) 670 `(= ,place (+ ,place ,i)) 671 (w/uniq gi 672 (let (binds val setter) (setforms place) 673 `(atwiths ,(+ binds (list gi i)) 674 (,setter (+ ,val ,gi))))))) 675 676(mac -- (place (o i 1)) 677 (if (isa place 'sym) 678 `(= ,place (- ,place ,i)) 679 (w/uniq gi 680 (let (binds val setter) (setforms place) 681 `(atwiths ,(+ binds (list gi i)) 682 (,setter (- ,val ,gi))))))) 683 684; E.g. (++ x) equiv to (zap + x 1) 685 686(mac zap (op place . args) 687 (with (gop (uniq) 688 gargs (map [uniq] args) 689 mix (afn seqs 690 (if (some no seqs) 691 nil 692 (+ (map car seqs) 693 (apply self (map cdr seqs)))))) 694 (let (binds val setter) (setforms place) 695 `(atwiths ,(+ binds (list gop op) (mix gargs args)) 696 (,setter (,gop ,val ,@gargs)))))) 697 698; Can't simply mod pr to print strings represented as lists of chars, 699; because empty string will get printed as nil. Would need to rep strings 700; as lists of chars annotated with 'string, and modify car and cdr to get 701; the rep of these. That would also require hacking the reader. 702 703(def pr args 704 (map1 disp args) 705 (car args)) 706 707(def prt args 708 (map1 [if _ (disp _)] args) 709 (car args)) 710 711(def prn args 712 (do1 (apply pr args) 713 (pr #\newline))) ; writec doesn't implicitly flush 714 715(mac wipe args 716 `(do ,@(map (fn (a) `(= ,a nil)) args))) 717 718(mac set args 719 `(do ,@(map (fn (a) `(= ,a t)) args))) 720 721; Destructuring means ambiguity: are pat vars bound in else? (no) 722 723(mac iflet (var expr then . rest) 724 (w/uniq gv 725 `(let ,gv ,expr 726 (if ,gv (let ,var ,gv ,then) ,@rest)))) 727 728(mac whenlet (var expr . body) 729 `(iflet ,var ,expr (do ,@body))) 730 731(mac aif (expr . body) 732 `(let it ,expr 733 (if it 734 ,@(if (cddr body) 735 `(,(car body) (aif ,@(cdr body))) 736 body)))) 737 738(mac awhen (expr . body) 739 `(let it ,expr (if it (do ,@body)))) 740 741(mac aand args 742 (if (no args) 743 't 744 (no (cdr args)) 745 (car args) 746 `(let it ,(car args) (and it (aand ,@(cdr args)))))) 747 748(mac accum (accfn . body) 749 (w/uniq gacc 750 `(withs (,gacc nil ,accfn [push _ ,gacc]) 751 ,@body 752 (rev ,gacc)))) 753 754; Repeatedly evaluates its body till it returns nil, then returns vals. 755 756(mac drain (expr (o eof nil)) 757 (w/uniq (gacc gdone gres) 758 `(with (,gacc nil ,gdone nil) 759 (while (no ,gdone) 760 (let ,gres ,expr 761 (if (is ,gres ,eof) 762 (= ,gdone t) 763 (push ,gres ,gacc)))) 764 (rev ,gacc)))) 765 766; For the common C idiom while x = snarfdata != stopval. 767; Rename this if use it often. 768 769(mac whiler (var expr endval . body) 770 (w/uniq gf 771 `(withs (,var nil ,gf (testify ,endval)) 772 (while (no (,gf (= ,var ,expr))) 773 ,@body)))) 774 775;(def macex (e) 776; (if (atom e) 777; e 778; (let op (and (atom (car e)) (eval (car e))) 779; (if (isa op 'mac) 780; (apply (rep op) (cdr e)) 781; e)))) 782 783(def consif (x y) (if x (cons x y) y)) 784 785(def string args 786 (apply + "" (map [coerce _ 'string] args))) 787 788(def flat x 789 ((afn (x acc) 790 (if (no x) acc 791 (atom x) (cons x acc) 792 (self (car x) (self (cdr x) acc)))) 793 x nil)) 794 795(mac check (x test (o alt)) 796 (w/uniq gx 797 `(let ,gx ,x 798 (if (,test ,gx) ,gx ,alt)))) 799 800(def pos (test seq (o start 0)) 801 (let f (testify test) 802 (if (alist seq) 803 ((afn (seq n) 804 (if (no seq) 805 nil 806 (f (car seq)) 807 n 808 (self (cdr seq) (+ n 1)))) 809 (nthcdr start seq) 810 start) 811 (recstring [if (f (seq _)) _] seq start)))) 812 813(def even (n) (is (mod n 2) 0)) 814 815(def odd (n) (no (even n))) 816 817(mac after (x . ys) 818 `(protect (fn () ,x) (fn () ,@ys))) 819 820(let expander 821 (fn (f var name body) 822 `(let ,var (,f ,name) 823 (after (do ,@body) (close ,var)))) 824 825 (mac w/infile (var name . body) 826 (expander 'infile var name body)) 827 828 (mac w/outfile (var name . body) 829 (expander 'outfile var name body)) 830 831 (mac w/instring (var str . body) 832 (expander 'instring var str body)) 833 834 (mac w/socket (var port . body) 835 (expander 'open-socket var port body)) 836 ) 837 838(mac w/outstring (var . body) 839 `(let ,var (outstring) ,@body)) 840 841; what happens to a file opened for append if arc is killed in 842; the middle of a write? 843 844(mac w/appendfile (var name . body) 845 `(let ,var (outfile ,name 'append) 846 (after (do ,@body) (close ,var)))) 847 848; rename this simply "to"? - prob not; rarely use 849 850(mac w/stdout (str . body) 851 `(call-w/stdout ,str (fn () ,@body))) 852 853(mac w/stdin (str . body) 854 `(call-w/stdin ,str (fn () ,@body))) 855 856(mac tostring body 857 (w/uniq gv 858 `(w/outstring ,gv 859 (w/stdout ,gv ,@body) 860 (inside ,gv)))) 861 862(mac fromstring (str . body) 863 (w/uniq gv 864 `(w/instring ,gv ,str 865 (w/stdin ,gv ,@body)))) 866 867(def readstring1 (s (o eof nil)) (w/instring i s (read i eof))) 868 869(def read ((o x (stdin)) (o eof nil)) 870 (if (isa x 'string) (readstring1 x eof) (sread x eof))) 871 872; inconsistency between names of readfile[1] and writefile 873 874(def readfile (name) (w/infile s name (drain (read s)))) 875 876(def readfile1 (name) (w/infile s name (read s))) 877 878(def readall (src (o eof nil)) 879 ((afn (i) 880 (let x (read i eof) 881 (if (is x eof) 882 nil 883 (cons x (self i))))) 884 (if (isa src 'string) (instring src) src))) 885 886(def allchars (str) 887 (tostring (whiler c (readc str nil) no 888 (writec c)))) 889 890(def filechars (name) 891 (w/infile s name (allchars s))) 892 893(def writefile (val file) 894 (let tmpfile (+ file ".tmp") 895 (w/outfile o tmpfile (write val o)) 896 (mvfile tmpfile file)) 897 val) 898 899(= ac-denil ($ ac-denil)) 900(= ac-global-name ($ ac-global-name)) 901(= ac-niltree ($ ac-niltree)) 902 903; for when we can't use assign 904 905(mac ac-set-global (name val) 906 (w/uniq (gname v) 907 `(with (,gname (ac-global-name ,name) 908 ,v ,val) 909 ($ (namespace-set-variable-value! ,gname ,v)) 910 nil))) 911 912(= scheme-f (read "#f")) 913(= scheme-t (read "#t")) 914 915(= redef =) 916 917(= defined-variables* (table)) 918 919(redef ac-defined-var? 920 (fn (name) 921 (if defined-variables*.name scheme-t scheme-f))) 922 923(mac defvar (name impl) 924 `(do (ac-set-global ',name ,impl) 925 (set (defined-variables* ',name)) 926 nil)) 927 928(mac defvar-impl (name) 929 (let gname (ac-global-name name) 930 `($ ,gname))) 931 932(mac undefvar (name) 933 `(do (wipe (defined-variables* ',name)) 934 (ac-set-global ',name nil))) 935 936(mac parameterize(var val . body) 937 (w/uniq f 938 `(let ,f (fn() ,@body) 939 (parameterize-sub ,var ,val ,f)))) 940 941(def thread-cell(var (o inherit)) 942 ($:make-thread-cell ,var ,(if inherit scheme-t scheme-f))) 943 944(mac thread-local(name val) 945 (w/uniq storage 946 `(defvar ,name 947 (let ,storage (thread-cell ,val) 948 (fn args 949 (if args 950 (ac-niltree:$:thread-cell-set! ,storage (car args)) 951 (ac-niltree:$:thread-cell-ref ,storage))))))) 952 953(def sym (x) (coerce x 'sym)) 954 955(def int (x (o b 10)) (coerce x 'int b)) 956 957(def stringify(sym) 958 (coerce sym 'string)) 959(def symize args 960 (coerce (apply + args) 'sym)) 961(def globalize l 962 (symize l "*")) 963 964(mac rand-choice exprs 965 `(case (rand ,(len exprs)) 966 ,@(let key -1 967 (mappend [list (++ key) _] 968 exprs)))) 969 970(mac n-of (n expr) 971 (w/uniq ga 972 `(let ,ga nil 973 (repeat ,n (push ,expr ,ga)) 974 (rev ,ga)))) 975 976; rejects bytes >= 248 lest digits be overrepresented 977 978(def rand-string (n) 979 (let c "0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ" 980 (with (nc 62 s (newstring n) i 0) 981 (w/infile str "/dev/urandom" 982 (while (< i n) 983 (let x (readb str) 984 (unless (> x 247) 985 (= (s i) (c (mod x nc))) 986 (++ i))))) 987 s))) 988 989(mac forlen (var s . body) 990 `(for ,var 0 (- (len ,s) 1) ,@body)) 991 992(mac on (var s . body) 993 (if (is var 'index) 994 (err "Can't use index as first arg to on.") 995 (w/uniq gs 996 `(let ,gs ,s 997 (forlen index ,gs 998 (let ,var (,gs index) 999 ,@body)))))) 1000 1001(def best (f seq) 1002 (if (no seq) 1003 nil 1004 (let wins (car seq) 1005 (each elt (cdr seq) 1006 (if (f elt wins) (= wins elt))) 1007 wins))) 1008 1009(def max args (best > args)) 1010(def min args (best < args)) 1011 1012; (mac max2 (x y) 1013; (w/uniq (a b) 1014; `(with (,a ,x ,b ,y) (if (> ,a ,b) ,a ,b)))) 1015 1016(def most (f seq) 1017 (unless (no seq) 1018 (withs (wins (car seq) topscore (f wins)) 1019 (each elt (cdr seq) 1020 (let score (f elt) 1021 (if (> score topscore) (= wins elt topscore score)))) 1022 wins))) 1023 1024; Insert so that list remains sorted. Don't really want to expose 1025; these but seem to have to because can't include a fn obj in a 1026; macroexpansion. 1027 1028(def insert-sorted (test elt seq) 1029 (if (no seq) 1030 (list elt) 1031 (test elt (car seq)) 1032 (cons elt seq) 1033 (cons (car seq) (insert-sorted test elt (cdr seq))))) 1034 1035(mac insort (test elt seq) 1036 `(zap [insert-sorted ,test ,elt _] ,seq)) 1037 1038(def reinsert-sorted (test elt seq) 1039 (if (no seq) 1040 (list elt) 1041 (is elt (car seq)) 1042 (reinsert-sorted test elt (cdr seq)) 1043 (test elt (car seq)) 1044 (cons elt (rem elt seq)) 1045 (cons (car seq) (reinsert-sorted test elt (cdr seq))))) 1046 1047(mac insortnew (test elt seq) 1048 `(zap [reinsert-sorted ,test ,elt _] ,seq)) 1049 1050; Could make this look at the sig of f and return a fn that took the 1051; right no of args and didn't have to call apply (or list if 1 arg). 1052 1053(def memo (f) 1054 (with (cache (table) nilcache (table)) 1055 (fn args 1056 (or (cache args) 1057 (and (no (nilcache args)) 1058 (aif (apply f args) 1059 (= (cache args) it) 1060 (do (set (nilcache args)) 1061 nil))))))) 1062 1063 1064(mac defmemo (name parms . body) 1065 `(safeset ,name (memo (fn ,parms ,@body)))) 1066 1067(def <= args 1068 (or (no args) 1069 (no (cdr args)) 1070 (and (no (> (car args) (cadr args))) 1071 (apply <= (cdr args))))) 1072 1073(def >= args 1074 (or (no args) 1075 (no (cdr args)) 1076 (and (no (< (car args) (cadr args))) 1077 (apply >= (cdr args))))) 1078 1079(def whitec (c) 1080 (in c #\space #\newline #\tab #\return)) 1081 1082(def nonwhite (c) (no (whitec c))) 1083 1084(def letter (c) (or (<= #\a c #\z) (<= #\A c #\Z))) 1085 1086(def digit (c) (<= #\0 c #\9)) 1087 1088(def alphadig (c) (or (letter c) (digit c))) 1089 1090(def punc (c) 1091 (in c #\. #\, #\; #\: #\! #\?)) 1092 1093; a version of readline that accepts both lf and crlf endings 1094; adapted from Andrew Wilcox's code (http://awwx.ws/readline) by Michael 1095; Arntzenius <daekharel@gmail.com> 1096 1097(def readline ((o str (stdin))) 1098 (awhen (readc str) 1099 (tostring 1100 ((afn (c) 1101 (if (is c #\return) (when (is peekc.str #\newline) readc.str) 1102 (is c #\newline) nil 1103 (do (writec c) 1104 (aif readc.str self.it)))) 1105 it)))) 1106 1107; Don't currently use this but suspect some code could. 1108 1109(mac summing (sumfn . body) 1110 (w/uniq (gc gt) 1111 `(let ,gc 0 1112 (let ,sumfn (fn (,gt) (if ,gt (++ ,gc))) 1113 ,@body) 1114 ,gc))) 1115 1116(def sum (f xs) 1117 (let n 0 1118 (each x xs (++ n (f x))) 1119 n)) 1120 1121(def treewise (f base tree) 1122 (if (atom tree) 1123 (base tree) 1124 (f (treewise f base (car tree)) 1125 (treewise f base (cdr tree))))) 1126 1127(def carif (x) (if (atom x) x (car x))) 1128 1129; Could prob be generalized beyond printing. 1130 1131(def prall (elts (o init "") (o sep ", ")) 1132 (when elts 1133 (pr init (car elts)) 1134 (map [pr sep _] (cdr elts)) 1135 elts)) 1136 1137(def prs args 1138 (prall args "" #\space)) 1139 1140(def tree-subst (old new tree) 1141 (if (is tree old) 1142 new 1143 (atom tree) 1144 tree 1145 (cons (tree-subst old new (car tree)) 1146 (tree-subst old new (cdr tree))))) 1147 1148(def ontree (f tree) 1149 (f tree) 1150 (unless (atom tree) 1151 (ontree f (car tree)) 1152 (ontree f (cdr tree)))) 1153 1154(def dotted (x) 1155 (if (atom x) 1156 nil 1157 (and (cdr x) (or (atom (cdr x)) 1158 (dotted (cdr x)))))) 1159 1160(def fill-table (table data) 1161 (each (k v) (pair data) (= (table k) v)) 1162 table) 1163 1164(def keys (h) 1165 (accum a (each (k v) h (a k)))) 1166 1167(def vals (h) 1168 (accum a (each (k v) h (a v)))) 1169 1170; These two should really be done by coerce. Wrap coerce? 1171 1172(def tablist (h) 1173 (accum a (maptable (fn args (a args)) h))) 1174 1175(def listtab (al) 1176 (let h (table) 1177 (map (fn ((k v)) (= (h k) v)) 1178 al) 1179 h)) 1180 1181(mac obj args 1182 `(listtab (list ,@(map (fn ((k v)) 1183 `(list ',k ,v)) 1184 (pair args))))) 1185 1186(def load-table (file (o eof)) 1187 (w/infile i file (read-table i eof))) 1188 1189(def read-table ((o i (stdin)) (o eof)) 1190 (let e (read i eof) 1191 (if (alist e) (listtab e) e))) 1192 1193(def load-tables (file) 1194 (w/infile i file 1195 (w/uniq eof 1196 (drain (read-table i eof) eof)))) 1197 1198(def save-table (h file) 1199 (writefile (tablist h) file)) 1200 1201(def write-table (h (o o (stdout))) 1202 (write (tablist h) o)) 1203 1204(def copy (x . args) 1205 (let x2 (case (type x) 1206 sym x 1207 cons (copylist x) ; (apply (fn args args) x) 1208 string (let new (newstring (len x)) 1209 (forlen i x 1210 (= (new i) (x i))) 1211 new) 1212 table (let new (table) 1213 (each (k v) x 1214 (= (new k) v)) 1215 new) 1216 (err "Can't copy " x)) 1217 (map (fn ((k v)) (= (x2 k) v)) 1218 (pair args)) 1219 x2)) 1220 1221(def shr (n m) 1222 (shl n (- m))) 1223 1224(def abs (n) 1225 (if (< n 0) (- n) n)) 1226 1227; The problem with returning a list instead of multiple values is that 1228; you can't act as if the fn didn't return multiple vals in cases where 1229; you only want the first. Not a big problem. 1230 1231(def round (n) 1232 (withs (base (trunc n) rem (abs (- n base))) 1233 (if (> rem 1/2) ((if (> n 0) + -) base 1) 1234 (< rem 1/2) base 1235 (odd base) ((if (> n 0) + -) base 1) 1236 base))) 1237 1238(def roundup (n) 1239 (withs (base (trunc n) rem (abs (- n base))) 1240 (if (>= rem 1/2) 1241 ((if (> n 0) + -) base 1) 1242 base))) 1243 1244(def nearest (n quantum) 1245 (* (roundup (/ n quantum)) quantum)) 1246 1247(def avg (ns) (/ (apply + ns) (len ns))) 1248 1249(def med (ns (o test >)) 1250 ((sort test ns) (round (/ (len ns) 2)))) 1251 1252; Use mergesort on assumption that mostly sorting mostly sorted lists 1253; benchmark: (let td (n-of 10000 (rand 100)) (time (sort < td)) 1) 1254 1255(def sort (test seq) 1256 (if (alist seq) 1257 (mergesort test (copy seq)) 1258 (coerce (mergesort test (coerce seq 'cons)) (type seq)))) 1259 1260; Destructive stable merge-sort, adapted from slib and improved 1261; by Eli Barzilay for MzLib; re-written in Arc. 1262 1263(def mergesort (less? lst) 1264 (with (n (len lst)) 1265 (if (<= n 1) lst 1266 ; ; check if the list is already sorted 1267 ; ; (which can be a common case, eg, directory lists). 1268 ; (let loop ([last (car lst)] [next (cdr lst)]) 1269 ; (or (null? next) 1270 ; (and (not (less? (car next) last)) 1271 ; (loop (car next) (cdr next))))) 1272 ; lst 1273 ((afn (n) 1274 (if (> n 2) 1275 ; needs to evaluate L->R 1276 (withs (j (/ (if (even n) n (- n 1)) 2) ; faster than round 1277 a (self j) 1278 b (self (- n j))) 1279 (merge less? a b)) 1280 ; the following case just inlines the length 2 case, 1281 ; it can be removed (and use the above case for n>1) 1282 ; and the code still works, except a little slower 1283 (is n 2) 1284 (with (x (car lst) y (cadr lst) p lst) 1285 (= lst (cddr lst)) 1286 (when (less? y x) (scar p y) (scar (cdr p) x)) 1287 (scdr (cdr p) nil) 1288 p) 1289 (is n 1) 1290 (with (p lst) 1291 (= lst (cdr lst)) 1292 (scdr p nil) 1293 p) 1294 nil)) 1295 n)))) 1296 1297; Also by Eli. 1298 1299(def merge (less? x y) 1300 (if (no x) y 1301 (no y) x 1302 (let lup nil 1303 (assign lup 1304 (fn (r x y r-x?) ; r-x? for optimization -- is r connected to x? 1305 (if (less? (car y) (car x)) 1306 (do (if r-x? (scdr r y)) 1307 (if (cdr y) (lup y x (cdr y) nil) (scdr y x))) 1308 ; (car x) <= (car y) 1309 (do (if (no r-x?) (scdr r x)) 1310 (if (cdr x) (lup x (cdr x) y t) (scdr x y)))))) 1311 (if (less? (car y) (car x)) 1312 (do (if (cdr y) (lup y x (cdr y) nil) (scdr y x)) 1313 y) 1314 ; (car x) <= (car y) 1315 (do (if (cdr x) (lup x (cdr x) y t) (scdr x y)) 1316 x))))) 1317 1318(def bestn (n f seq) 1319 (firstn n (sort f seq))) 1320 1321(def split (seq pos) 1322 (list (cut seq 0 pos) (cut seq pos))) 1323 1324(mac time (expr) 1325 (w/uniq (t1 t2) 1326 `(let ,t1 (msec) 1327 (do1 ,expr 1328 (let ,t2 (msec) 1329 (prn "time: " (- ,t2 ,t1) " msec.")))))) 1330 1331(mac jtime (expr) 1332 `(do1 'ok (time ,expr))) 1333 1334(mac time10 (expr) 1335 `(time (repeat 10 ,expr))) 1336 1337(def union (f xs ys) 1338 (+ xs (rem (fn (y) (some [f _ y] xs)) 1339 ys))) 1340 1341(= templates* (table)) 1342 1343(mac deftem (tem . fields) 1344 (withs (name (carif tem) includes (if (acons tem) (cdr tem))) 1345 `(= (templates* ',name) 1346 (+ (mappend templates* ',(rev includes)) 1347 (list ,@(map (fn ((k v)) `(list ',k (fn () ,v))) 1348 (pair fields))))))) 1349 1350(mac addtem (name . fields) 1351 `(= (templates* ',name) 1352 (union (fn (x y) (is (car x) (car y))) 1353 (list ,@(map (fn ((k v)) `(list ',k (fn () ,v))) 1354 (pair fields))) 1355 (templates* ',name)))) 1356 1357(def inst (tem . args) 1358 (let x (table) 1359 (each (k v) (if (acons tem) tem (templates* tem)) 1360 (unless (no v) (= (x k) (v)))) 1361 (each (k v) (pair args) 1362 (= (x k) v)) 1363 x)) 1364 1365; To write something to be read by temread, (write (tablist x)) 1366 1367(def temread (tem (o str (stdin))) 1368 (templatize tem (read str))) 1369 1370; Converts alist to inst; ugly; maybe should make this part of coerce. 1371; Note: discards fields not defined by the template. 1372 1373(def templatize (tem raw) 1374 (with (x (inst tem) fields (if (acons tem) tem (templates* tem))) 1375 (each (k v) raw 1376 (when (assoc k fields) 1377 (= (x k) v))) 1378 x)) 1379 1380(def temload (tem file) 1381 (w/infile i file (temread tem i))) 1382 1383(def temloadall (tem file) 1384 (map (fn (pairs) (templatize tem pairs)) 1385 (w/infile in file (readall in)))) 1386 1387 1388(def number (n) (in (type n) 'int 'num)) 1389 1390(def since (t1) (- (seconds) t1)) 1391 1392(def minutes-since (t1) (/ (since t1) 60)) 1393(def hours-since (t1) (/ (since t1) 3600)) 1394(def days-since (t1) (/ (since t1) 86400)) 1395 1396; could use a version for fns of 1 arg at least 1397 1398(def cache (timef valf) 1399 (with (cached nil gentime nil) 1400 (fn () 1401 (unless (and cached (< (since gentime) (timef))) 1402 (= cached (valf) 1403 gentime (seconds))) 1404 cached))) 1405 1406(mac defcache (name lasts . body) 1407 `(safeset ,name (cache (fn () ,lasts) 1408 (fn () ,@body)))) 1409 1410(mac errsafe (expr) 1411 `(on-err (fn (c) nil) 1412 (fn () ,expr))) 1413 1414(def saferead (arg) (errsafe:read arg)) 1415 1416(def safe-load-table (filename) 1417 (or (errsafe:load-table filename) 1418 (table))) 1419 1420(def ensure-dir (path) 1421 (unless (dir-exists path) 1422 (system (string "mkdir -p " path)))) 1423 1424(def date ((o s (seconds))) 1425 (rev (nthcdr 3 (timedate s)))) 1426 1427(def datestring ((o s (seconds))) 1428 (let (y m d) (date s) 1429 (string y "-" (if (< m 10) "0") m "-" (if (< d 10) "0") d))) 1430 1431(def count (test x) 1432 (with (n 0 testf (testify test)) 1433 (each elt x 1434 (if (testf elt) (++ n))) 1435 n)) 1436 1437(def ellipsize (str (o limit 80)) 1438 (if (<= (len str) limit) 1439 str 1440 (+ (cut str 0 limit) "..."))) 1441 1442(def rand-elt (seq) 1443 (seq (rand (len seq)))) 1444 1445(mac until (test . body) 1446 `(while (no ,test) ,@body)) 1447 1448(def before (x y seq (o i 0)) 1449 (with (xp (pos x seq i) yp (pos y seq i)) 1450 (and xp (or (no yp) (< xp yp))))) 1451 1452(def orf fns 1453 (fn args 1454 ((afn (fs) 1455 (and fs (or (apply (car fs) args) (self (cdr fs))))) 1456 fns))) 1457 1458(def andf fns 1459 (fn args 1460 ((afn (fs) 1461 (if (no fs) t 1462 (no (cdr fs)) (apply (car fs) args) 1463 (and (apply (car fs) args) (self (cdr fs))))) 1464 fns))) 1465 1466(def atend (i s) 1467 (> i (- (len s) 2))) 1468 1469(def multiple (x y) 1470 (is 0 (mod x y))) 1471 1472(mac nor args `(no (or ,@args))) 1473(mac nand args `(no (and ,@args))) 1474 1475; Consider making the default sort fn take compare's two args (when do 1476; you ever have to sort mere lists of numbers?) and rename current sort 1477; as prim-sort or something. 1478 1479; Could simply modify e.g. > so that (> len) returned the same thing 1480; as (compare > len). 1481 1482(def compare (comparer scorer) 1483 (fn (x y) (comparer (scorer x) (scorer y)))) 1484 1485; Cleaner thus, but may only ever need in 2 arg case. 1486 1487;(def compare (comparer scorer) 1488; (fn args (apply comparer map scorer args))) 1489 1490; (def only (f g . args) (aif (apply g args) (f it))) 1491 1492(def only (f) 1493 (fn args (if (car args) (apply f args)))) 1494 1495(mac conswhen (f x y) 1496 (w/uniq (gf gx) 1497 `(with (,gf ,f ,gx ,x) 1498 (if (,gf ,gx) (cons ,gx ,y) ,y)))) 1499 1500; Could combine with firstn if put f arg last, default to (fn (x) t). 1501 1502(def retrieve (n f xs) 1503 (if (no n) (keep f xs) 1504 (or (<= n 0) (no xs)) nil 1505 (f (car xs)) (cons (car xs) (retrieve (- n 1) f (cdr xs))) 1506 (retrieve n f (cdr xs)))) 1507 1508(def dedup (xs) 1509 (with (h (table) acc nil) 1510 (each x xs 1511 (unless (h x) 1512 (push x acc) 1513 (set (h x)))) 1514 (rev acc))) 1515 1516(def single (x) (and (acons x) (no (cdr x)))) 1517 1518(def intersperse (x ys) 1519 (and ys (cons (car ys) 1520 (mappend [list x _] (cdr ys))))) 1521 1522(def counts (seq (o c (table))) 1523 (if (no seq) 1524 c 1525 (do (++ (c (car seq) 0)) 1526 (counts (cdr seq) c)))) 1527 1528(def tree-counts (tree (o c (table))) 1529 (counts (flat tree) c)) 1530 1531(def commonest (seq) 1532 (with (winner nil n 0) 1533 (each (k v) (counts seq) 1534 (when (> v n) (= winner k n v))) 1535 (list winner n))) 1536 1537(def reduce (f xs) 1538 (if (cddr xs) 1539 (reduce f (cons (f (car xs) (cadr xs)) (cddr xs))) 1540 (apply f xs))) 1541 1542(def rreduce (f xs) 1543 (if (cddr xs) 1544 (f (car xs) (rreduce f (cdr xs))) 1545 (apply f xs))) 1546 1547(let argsym (uniq) 1548 1549 (def parse-format (str) 1550 (accum a 1551 (with (chars nil i -1) 1552 (w/instring s str 1553 (whilet c (readc s) 1554 (case c 1555 #\# (do (a (coerce (rev chars) 'string)) 1556 (wipe chars) 1557 (a (read s))) 1558 #\~ (do (a (coerce (rev chars) 'string)) 1559 (wipe chars) 1560 (readc s) 1561 (a (list argsym (++ i)))) 1562 (push c chars)))) 1563 (when chars 1564 (a (coerce (rev chars) 'string)))))) 1565 1566 (mac prf (str . args) 1567 `(let ,argsym (list ,@args) 1568 (pr ,@(parse-format str)))) 1569) 1570 1571(wipe load-file-stack*) 1572(def load (file) 1573 (push current-load-file* load-file-stack*) 1574 (= current-load-file* file) 1575 (after (w/infile f file 1576 (w/uniq eof 1577 (whiler e (read f eof) eof 1578 (eval e)))) 1579 (= current-load-file* (pop load-file-stack*)))) 1580 1581(def positive (x) 1582 (and (number x) (> x 0))) 1583 1584(mac w/table (var . body) 1585 `(let ,var (table) ,@body ,var)) 1586 1587(def ero args 1588 (w/stdout (stderr) 1589 (each a args 1590 (write a) 1591 (writec #\space)) 1592 (writec #\newline)) 1593 (car args)) 1594 1595(def queue () (list nil nil 0)) 1596 1597; Despite call to atomic, once had some sign this wasn't thread-safe. 1598; Keep an eye on it. 1599 1600(def enq (obj q) 1601 (atomic 1602 (++ (q 2)) 1603 (if (no (car q)) 1604 (= (cadr q) (= (car q) (list obj))) 1605 (= (cdr (cadr q)) (list obj) 1606 (cadr q) (cdr (cadr q)))) 1607 (car q))) 1608 1609(def deq (q) 1610 (atomic (unless (is (q 2) 0) (-- (q 2))) 1611 (pop (car q)))) 1612 1613; Should redef len to do this, and make queues lists annotated queue. 1614 1615(def qlen (q) (q 2)) 1616 1617(def qlist (q) (car q)) 1618 1619(def enq-limit (val q (o limit 1000)) 1620 (atomic 1621 (unless (< (qlen q) limit) 1622 (deq q)) 1623 (enq val q))) 1624 1625(def median (ns) 1626 ((sort > ns) (trunc (/ (len ns) 2)))) 1627 1628(mac noisy-each (n var val . body) 1629 (w/uniq (gn gc) 1630 `(with (,gn ,n ,gc 0) 1631 (each ,var ,val 1632 (when (multiple (++ ,gc) ,gn) 1633 (pr ".") 1634 (flushout) 1635 ) 1636 ,@body) 1637 (prn) 1638 (flushout)))) 1639 1640(mac point (name . body) 1641 (w/uniq (g p) 1642 `(ccc (fn (,g) 1643 (let ,name (fn ((o ,p)) (,g ,p)) 1644 ,@body))))) 1645 1646(mac catch body 1647 `(point throw ,@body)) 1648 1649(def downcase (x) 1650 (let downc (fn (c) 1651 (let n (coerce c 'int) 1652 (if (or (< 64 n 91) (< 191 n 215) (< 215 n 223)) 1653 (coerce (+ n 32) 'char) 1654 c))) 1655 (case (type x) 1656 string (map downc x) 1657 char (downc x) 1658 sym (if x (sym (map downc (coerce x 'string)))) 1659 (err "Can't downcase" x)))) 1660 1661(def upcase (x) 1662 (let upc (fn (c) 1663 (let n (coerce c 'int) 1664 (if (or (< 96 n 123) (< 223 n 247) (< 247 n 255)) 1665 (coerce (- n 32) 'char) 1666 c))) 1667 (case (type x) 1668 string (map upc x) 1669 char (upc x) 1670 ; it's arguable whether (upcase nil) should be nil or NIL, but pg has 1671 ; chosen NIL, so in the name of compatibility: 1672 sym (if x (sym (map upc (coerce x 'string))) 'NIL) 1673 (err "Can't upcase" x)))) 1674 1675(def inc (x (o n 1)) 1676 (coerce (+ (coerce x 'int) n) (type x))) 1677 1678(def range (start end) 1679 (if (> start end) 1680 nil 1681 (cons start (range (inc start) end)))) 1682 1683(def mismatch (s1 s2) 1684 (catch 1685 (on c s1 1686 (when (isnt c (s2 index)) 1687 (throw index))))) 1688 1689(def memtable (ks) 1690 (let h (table) 1691 (each k ks (set (h k))) 1692 h)) 1693 1694(= bar* " | ") 1695 1696(mac w/bars body 1697 (w/uniq (out needbars) 1698 `(let ,needbars nil 1699 (do ,@(map (fn (e) 1700 `(let ,out (tostring ,e) 1701 (unless (is ,out "") 1702 (if ,needbars 1703 (pr bar* ,out) 1704 (do (set ,needbars) 1705 (pr ,out)))))) 1706 body))))) 1707 1708(def len< (x n) (< (len x) n)) 1709 1710(def len> (x n) (> (len x) n)) 1711 1712(mac thread body 1713 `(new-thread (fn () ,@body))) 1714(def kill-thread(th) 1715 (atomic ($:kill-thread th))) 1716(def break-thread(th) 1717 (atomic ($:break-thread th))) 1718 1719(def thread-send(thd v) 1720 (ac-niltree:$:thread-send thd v)) 1721(def thread-receive() 1722 (ac-niltree:$:thread-receive)) 1723(def thread-try-receive() 1724 (ac-niltree:$:thread-try-receive)) 1725(def thread-rewind-receive args 1726 (ac-niltree:$:thread-rewind-receive (ac-denil ,args))) 1727 1728(mac trav (x . fs) 1729 (w/uniq g 1730 `((afn (,g) 1731 (when ,g 1732 ,@(map [list _ g] fs))) 1733 ,x))) 1734 1735(mac or= (place expr) 1736 (let (binds val setter) (setforms place) 1737 `(atwiths ,binds 1738 (or ,val (,setter ,expr))))) 1739 1740(= vtables* (table)) 1741(mac defgeneric(name args . body) 1742 `(do 1743 (or= (vtables* ',name) (table)) 1744 (def ,name allargs 1745 (aif (aand (vtables* ',name) (it (type car.allargs))) 1746 (apply it allargs) 1747 (aif (pickles* (type car.allargs)) 1748 (apply ,name (map it allargs)) 1749 (let ,args allargs 1750 ,@body)))))) 1751 1752(mac defmethod(name args type . body) 1753 `(= ((vtables* ',name) ',type) 1754 (fn ,args 1755 ,@body))) 1756 1757(= pickles* (table)) 1758(mac pickle(type f) 1759 `(= (pickles* ',type) 1760 ,f)) 1761 1762; Could take n args, but have never once needed that. 1763(defgeneric iso(x y) 1764 (is x y)) 1765 1766(defmethod iso(x y) cons 1767 (and (acons x) 1768 (acons y) 1769 (iso car.x car.y) 1770 (iso cdr.x cdr.y))) 1771 1772(defmethod iso(x y) table 1773 (and (isa x 'table) 1774 (isa y 'table) 1775 (is (len keys.x) (len keys.y)) 1776 (all 1777 (fn((k v)) 1778 (iso y.k v)) 1779 tablist.x))) 1780 1781(= hooks* (table)) 1782 1783(def hook (name . args) 1784 (aif (hooks* name) (apply it args))) 1785 1786(mac defhook (name . rest) 1787 `(= (hooks* ',name) (fn ,@rest))) 1788 1789(mac out (expr) `(pr ,(tostring (eval expr)))) 1790 1791; if renamed this would be more natural for (map [_ user] pagefns*) 1792 1793(def get (index) [_ index]) 1794 1795(= savers* (table)) 1796 1797(mac fromdisk (var file init load save) 1798 (w/uniq (gf gv) 1799 `(unless (bound ',var) 1800 (do1 (= ,var (iflet ,gf (file-exists ,file) 1801 (,load ,gf) 1802 ,init)) 1803 (= (savers* ',var) (fn (,gv) (,save ,gv ,file))))))) 1804 1805(mac diskvar (var file) 1806 `(fromdisk ,var ,file nil readfile1 writefile)) 1807 1808(mac disktable (var file) 1809 `(fromdisk ,var ,file (table) load-table save-table)) 1810 1811(mac todisk (var (o expr var)) 1812 `((savers* ',var) 1813 ,(if (is var expr) var `(= ,var ,expr)))) 1814 1815(mac evtil (expr test) 1816 (w/uniq gv 1817 `(let ,gv ,expr 1818 (while (no (,test ,gv)) 1819 (= ,gv ,expr)) 1820 ,gv))) 1821 1822(def rand-key (h) 1823 (if (empty h) 1824 nil 1825 (let n (rand (len h)) 1826 (catch 1827 (each (k v) h 1828 (when (is (-- n) -1) 1829 (throw k))))))) 1830 1831(def ratio (test xs) 1832 (if (empty xs) 1833 0 1834 (/ (count test xs) (len xs)))) 1835 1836(mac ret (var val . body) 1837 `(let ,var ,val ,@body ,var)) 1838 1839(def butlast (x) 1840 (cut x 0 (- (len x) 1))) 1841 1842(mac between (var expr within . body) 1843 (w/uniq first 1844 `(let ,first t 1845 (each ,var ,expr 1846 (if ,first 1847 (wipe ,first) 1848 ,within) 1849 ,@body)))) 1850 1851(mac tofile (name . body) 1852 (w/uniq str `(w/outfile ,str ,name (w/stdout ,str ,@body)))) 1853 1854(mac ontofile (name . body) 1855 (w/uniq str `(w/appendfile ,str ,name (w/stdout ,str ,@body)))) 1856 1857(mac fromfile (name . body) 1858 (w/uniq str `(w/infile ,str ,name (w/stdin ,str ,@body)))) 1859 1860(def cars (xs) (map car xs)) 1861(def cdrs (xs) (map cdr xs)) 1862 1863(mac mapeach (var lst . body) 1864 `(map (fn (,var) ,@body) ,lst)) 1865 1866(wipe current-load-file*) 1867 1868(load "help/arc.arc") 1869 1870; any logical reason I can't say (push x (if foo y z)) ? 1871; eval would have to always ret 2 things, the val and where it came from 1872; idea: implicit tables of tables; setf empty field, becomes table 1873; or should setf on a table just take n args? 1874 1875; idea: use constants in functional position for currying? 1876; (1 foo) would mean (fn args (apply foo 1 args)) 1877; another solution would be to declare certain symbols curryable, and 1878; if > was, >_10 would mean [> _ 10] 1879; or just say what the hell and make _ ssyntax for currying 1880; idea: make >10 ssyntax for [> _ 10] 1881; solution to the "problem" of improper lists: allow any atom as a list 1882; terminator, not just nil. means list recursion should terminate on 1883; atom rather than nil, (def empty (x) (or (atom x) (is x ""))) 1884; table should be able to take an optional initial-value. handle in sref. 1885; warn about code of form (if (= )) -- probably mean is 1886; warn when a fn has a parm that's already defined as a macro. 1887; (def foo (after) (after)) 1888; idea: a fn (nothing) that returns a special gensym which is ignored 1889; by map, so can use map in cases when don't want all the vals 1890; idea: anaph macro so instead of (aand x y) say (anaph and x y) 1891; idea: foo.bar!baz as an abbrev for (foo bar 'baz) 1892; or something a bit more semantic? 1893; could uniq be (def uniq () (annotate 'symbol (list 'u))) again? 1894; idea: use x- for (car x) and -x for (cdr x) (but what about math -?) 1895; idea: get rid of strings and just use symbols 1896; could a string be (#\a #\b . "") ? 1897; better err msg when , outside of a bq 1898; idea: parameter (p foo) means in body foo is (pair arg) 1899; idea: make ('string x) equiv to (coerce x 'string) ? or isa? 1900; quoted atoms in car valuable unused semantic space 1901; idea: if (defun foo (x y) ...), make (foo 1) return (fn (y) (foo 1 y)) 1902; probably would lead to lots of errors when call with missing args 1903; but would be really dense with . notation, (foo.1 2) 1904; or use special ssyntax for currying: (foo@1 2) 1905; remember, can also double; could use foo::bar to mean something 1906; wild idea: inline defs for repetitive code 1907; same args as fn you're in 1908; variant of compose where first fn only applied to first arg? 1909; (> (len x) y) means (>+len x …
Large files files are truncated, but you can click here to view the full file