PageRenderTime 45ms CodeModel.GetById 18ms app.highlight 13ms RepoModel.GetById 1ms app.codeStats 0ms

/arc.arc

http://github.com/alimoeeny/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