PageRenderTime 120ms CodeModel.GetById 15ms app.highlight 92ms RepoModel.GetById 1ms app.codeStats 1ms

/ac.scm

http://github.com/alimoeeny/arc
Scheme | 1509 lines | 1021 code | 292 blank | 196 comment | 0 complexity | bb6de53b704e929ad53e666910dbfaa2 MD5 | raw file
   1; Arc Compiler.
   2
   3(module ac mzscheme
   4
   5(provide (all-defined))
   6(require (lib "port.ss"))
   7(require (lib "process.ss"))
   8(require (lib "pretty.ss"))
   9(require (lib "foreign.ss"))
  10(unsafe!)
  11
  12(define (ac-global-name s)
  13  (string->symbol (string-append "_" (symbol->string s))))
  14
  15(define-syntax defarc
  16  (syntax-rules ()
  17    ((defarc (name . args) body ...)
  18     (defarc name (name . args) body ...))
  19    ((defarc arc-name (scheme-name . args) body ...)
  20     (begin
  21       (xdef arc-name (lambda args body ...))
  22       (defarc arc-name scheme-name)))
  23    ((defarc arc-name scheme-name)
  24     (define (scheme-name . args)
  25       (apply (namespace-variable-value (ac-global-name 'arc-name)) args)))
  26    ((defarc name)
  27     (defarc name name))))
  28
  29; compile an Arc expression into a Scheme expression,
  30; both represented as s-expressions.
  31; env is a list of lexically bound variables, which we
  32; need in order to decide whether set should create a global.
  33
  34(defarc (ac s env)
  35  (cond ((string? s) (ac-string s env))
  36        ((literal? s) s)
  37        ((eqv? s 'nil) (list 'quote 'nil))
  38        ((ssyntax? s) (ac (expand-ssyntax s) env))
  39        ((symbol? s) (ac-var-ref s env))
  40        ((ssyntax? (xcar s)) (ac (cons (expand-ssyntax (car s)) (cdr s)) env))
  41        ((eq? (xcar s) '$) (ac-$ (cadr s) env))
  42        ((eq? (xcar s) 'quote) (list 'quote (ac-niltree (cadr s))))
  43        ((eq? (xcar s) 'quasiquote) (ac-qq (cadr s) env))
  44        ((eq? (xcar s) 'if) (ac-if (cdr s) env))
  45        ((eq? (xcar s) 'fn) (ac-fn (cadr s) (cddr s) env))
  46        ((eq? (xcar s) 'assign) (ac-set (cdr s) env))
  47        ; the next three clauses could be removed without changing semantics
  48        ; ... except that they work for macros (so prob should do this for
  49        ; every elt of s, not just the car)
  50        ((eq? (xcar (xcar s)) 'compose) (ac (decompose (cdar s) (cdr s)) env))
  51        ((eq? (xcar (xcar s)) 'complement) 
  52         (ac (list 'no (cons (cadar s) (cdr s))) env))
  53        ((eq? (xcar (xcar s)) 'andf) (ac-andf s env))
  54        ((pair? s) (ac-call (car s) (cdr s) env))
  55        (#t (err "Bad object in expression" s))))
  56
  57(define (ac-string s env)
  58  (if (ar-bflag 'atstrings)
  59      (if (atpos s 0)
  60          (ac (cons 'string (map (lambda (x)
  61                                   (if (string? x)
  62                                       (unescape-ats x)
  63                                       x))
  64                                 (codestring s)))
  65              env)
  66          (unescape-ats s))
  67      (string-copy s)))          ; avoid immutable strings
  68
  69(defarc ac-literal (literal? x)
  70  (or (boolean? x)
  71      (char? x)
  72      (string? x)
  73      (number? x)
  74      (eq? x '())))
  75
  76(define (ssyntax? x)
  77  (and (symbol? x)
  78       (not (or (eqv? x '+) (eqv? x '++) (eqv? x '_)))
  79       (let ((name (symbol->string x)))
  80         (has-ssyntax-char? name (- (string-length name) 1)))))
  81
  82(define (has-ssyntax-char? string i)
  83  (and (>= i 0)
  84       (or (let ((c (string-ref string i)))
  85             (or (eqv? c #\:) (eqv? c #\~) 
  86                 (eqv? c #\&)
  87                 ;(eqv? c #\_) 
  88                 (eqv? c #\.)  (eqv? c #\!)))
  89           (has-ssyntax-char? string (- i 1)))))
  90
  91(define (read-from-string str)
  92  (let ((port (open-input-string str)))
  93    (let ((val (read port)))
  94      (close-input-port port)
  95      val)))
  96
  97; Though graphically the right choice, can't use _ for currying
  98; because then _!foo becomes a function.  Maybe use <>.  For now
  99; leave this off and see how often it would have been useful.
 100
 101; Might want to make ~ have less precedence than &, because
 102; ~foo&bar prob should mean (andf (complement foo) bar), not 
 103; (complement (andf foo bar)).
 104
 105(define (expand-ssyntax sym)
 106  ((cond ((or (insym? #\: sym) (insym? #\~ sym)) expand-compose)
 107         ((or (insym? #\. sym) (insym? #\! sym)) expand-sexpr)
 108         ((insym? #\& sym) expand-and)
 109     ;   ((insym? #\_ sym) expand-curry)
 110         (#t (error "Unknown ssyntax" sym)))
 111   sym))
 112
 113(define (expand-compose sym)
 114  (let ((elts (map (lambda (tok)
 115                     (if (eqv? (car tok) #\~)
 116                         (if (null? (cdr tok))
 117                             'no
 118                             `(complement ,(chars->value (cdr tok))))
 119                         (chars->value tok)))
 120                   (tokens (lambda (c) (eqv? c #\:))
 121                           (symbol->chars sym) 
 122                           '() 
 123                           '() 
 124                           #f))))
 125    (if (null? (cdr elts))
 126        (car elts)
 127        (cons 'compose elts))))
 128
 129(define (expand-and sym)
 130  (let ((elts (map chars->value
 131                   (tokens (lambda (c) (eqv? c #\&))
 132                           (symbol->chars sym)
 133                           '()
 134                           '()
 135                           #f))))
 136    (if (null? (cdr elts))
 137        (car elts)
 138        (cons 'andf elts))))
 139
 140; How to include quoted arguments?  Can't treat all as quoted, because 
 141; never want to quote fn given as first.  Do we want to allow quote chars 
 142; within symbols?  Could be ugly.  
 143
 144; If release, fix the fact that this simply uses v0... as vars.  Should
 145; make these vars gensyms.
 146
 147(define (expand-curry sym)
 148  (let ((expr (exc (map (lambda (x) 
 149                          (if (pair? x) (chars->value x) x))
 150                        (tokens (lambda (c) (eqv? c #\_)) 
 151                                (symbol->chars sym) 
 152                                '() 
 153                                '() 
 154                                #t))
 155                    0)))
 156    (list 'fn 
 157          (keep (lambda (s) 
 158                  (and (symbol? s) 
 159                       (eqv? (string-ref (symbol->string s) 0) 
 160                             #\v)))
 161                expr)
 162          expr)))
 163
 164(define (keep f xs)
 165  (cond ((null? xs) '())
 166        ((f (car xs)) (cons (car xs) (keep f (cdr xs))))
 167        (#t (keep f (cdr xs)))))
 168
 169(define (exc elts n)
 170  (cond ((null? elts)
 171         '())
 172        ((eqv? (car elts) #\_)
 173         (cons (string->symbol (string-append "v" (number->string n)))
 174               (exc (cdr elts) (+ n 1))))
 175        (#t
 176         (cons (car elts) (exc (cdr elts) n)))))
 177
 178(define (expand-sexpr sym)
 179  (build-sexpr (reverse (tokens (lambda (c) (or (eqv? c #\.) (eqv? c #\!)))
 180                                (symbol->chars sym)
 181                                '()
 182                                '()
 183                                #t))
 184               sym))
 185
 186(define (build-sexpr toks orig)
 187  (cond ((null? toks)
 188         'get)
 189        ((null? (cdr toks))
 190         (chars->value (car toks)))
 191        (#t
 192         (list (build-sexpr (cddr toks) orig)
 193               (if (eqv? (cadr toks) #\!)
 194                   (list 'quote (chars->value (car toks)))
 195                   (if (or (eqv? (car toks) #\.) (eqv? (car toks) #\!))
 196                       (err "Bad ssyntax" orig)
 197                       (chars->value (car toks))))))))
 198
 199(define (insym? char sym) (member char (symbol->chars sym)))
 200
 201(define (symbol->chars x) (string->list (symbol->string x)))
 202
 203(define (chars->value chars) (read-from-string (list->string chars)))
 204
 205(define (tokens test source token acc keepsep?)
 206  (cond ((null? source)
 207         (reverse (if (pair? token) 
 208                      (cons (reverse token) acc)
 209                      acc)))
 210        ((test (car source))
 211         (tokens test
 212                 (cdr source)
 213                 '()
 214                 (let ((rec (if (null? token)
 215                            acc
 216                            (cons (reverse token) acc))))
 217                   (if keepsep?
 218                       (cons (car source) rec)
 219                       rec))
 220                 keepsep?))
 221        (#t
 222         (tokens test
 223                 (cdr source)
 224                 (cons (car source) token)
 225                 acc
 226                 keepsep?))))
 227
 228(defarc (ac-defined-var? s)
 229  #f)
 230
 231(define (ac-var-ref s env)
 232  (cond ((lex? s env)        s)
 233        ((ac-defined-var? s) (list (ac-global-name s)))
 234        (#t                  (ac-global-name s))))
 235
 236; lowering into mzscheme, with (unquote <foo>) lifting us back into arc
 237
 238(define (ac-$ args env)
 239  (ac-qqx args
 240    (lambda (x) (ac x env))
 241    (lambda (x) (error 'ac-$ "Can't use ,@ from within $ in: ~a" args))))
 242
 243; quasiquote
 244
 245(define (ac-qq args env)
 246  (list 'quasiquote (ac-qqx args
 247                      (lambda (x) (list 'unquote (ac x env)))
 248                      (lambda (x) (list 'unquote-splicing
 249                                    (list 'ar-nil-terminate (ac x env)))))))
 250
 251; process the argument of a quasiquote. keep track of
 252; depth of nesting. handle unquote only at top level (level = 1).
 253; complete form, e.g. x or (fn x) or (unquote (fn x))
 254
 255(define (ac-qqx x unq splice)
 256  (cond
 257    ((not (pair? x)) x)
 258    ((eqv? (car x) 'unquote) (unq (cadr x)))
 259    ((eqv? (car x) 'unquote-splicing) (splice (cadr x)))
 260    ((eqv? (car x) 'quasiquote)
 261      (list 'quasiquote
 262        (ac-qqx (cadr x)
 263          (lambda (e) (list 'unquote (ac-qqx e unq splice)))
 264          (lambda (e) (list 'unquote-splicing (ac-qqx e unq splice))))))
 265    (#t (imap (lambda (e) (ac-qqx e unq splice)) x))))
 266
 267; like map, but don't demand '()-terminated list
 268
 269(define (imap f l)
 270  (cond ((pair? l)
 271         (cons (f (car l)) (imap f (cdr l))))
 272        ((null? l)
 273         '())
 274        (#t (f l))))
 275
 276; (if) -> nil
 277; (if x) -> x
 278; (if t a ...) -> a
 279; (if nil a b) -> b
 280; (if nil a b c) -> (if b c)
 281
 282(define (ac-if args env)
 283  (cond ((null? args) ''nil)
 284        ((null? (cdr args)) (ac (car args) env))
 285        (#t `(if (not (ar-false? ,(ac (car args) env)))
 286                 ,(ac (cadr args) env)
 287                 ,(ac-if (cddr args) env)))))
 288
 289(define (ac-dbname! name env)
 290  (if (symbol? name)
 291      (cons (list name) env)
 292      env))
 293
 294(define (ac-dbname env)
 295  (cond ((null? env) #f)
 296        ((pair? (car env)) (caar env))
 297        (#t (ac-dbname (cdr env)))))
 298
 299; translate fn directly into a lambda if it has ordinary
 300; parameters, otherwise use a rest parameter and parse it.
 301
 302(define (ac-fn args body env)
 303  (if (ac-complex-args? args)
 304      (ac-complex-fn args body env)
 305      (ac-nameit
 306       (ac-dbname env)
 307       `(lambda ,(let ((a (ac-denil args))) (if (eqv? a 'nil) '() a))
 308          ,@(ac-body* body (append (ac-arglist args) env))))))
 309
 310; does an fn arg list use optional parameters or destructuring?
 311; a rest parameter is not complex
 312
 313(define (ac-complex-args? args)
 314  (cond ((eqv? args '()) #f)
 315        ((symbol? args) #f)
 316        ((and (pair? args) (symbol? (car args)))
 317         (ac-complex-args? (cdr args)))
 318        (#t #t)))
 319
 320; translate a fn with optional or destructuring args
 321; (fn (x (o y x) (o z 21) (x1 x2) . rest) ...)
 322; arguments in top-level list are mandatory (unless optional),
 323; but it's OK for parts of a list you're destructuring to
 324; be missing.
 325
 326(define (ac-complex-fn args body env)
 327  (let* ((ra (gensym))
 328         (z (ac-complex-args args env ra #t)))
 329    `(lambda ,ra
 330       (let* ,z
 331         ,@(ac-body* body (append (ac-complex-getargs z) env))))))
 332
 333; returns a list of two-element lists, first is variable name,
 334; second is (compiled) expression. to be used in a let.
 335; caller should extract variables and add to env.
 336; ra is the rest argument to the fn.
 337; is-params indicates that args are function arguments
 338;   (not destructuring), so they must be passed or be optional.
 339
 340(define (ac-complex-args args env ra is-params)
 341  (cond ((or (eqv? args '()) (eqv? args 'nil)) '())
 342        ((symbol? args) (list (list args ra)))
 343        ((pair? args)
 344         (let* ((x (if (and (pair? (car args)) (eqv? (caar args) 'o))
 345                       (ac-complex-opt (cadar args) 
 346                                       (if (pair? (cddar args))
 347                                           (caddar args) 
 348                                           'nil)
 349                                       env 
 350                                       ra)
 351                       (ac-complex-args
 352                        (car args)
 353                        env
 354                        (if is-params
 355                            `(car ,ra)
 356                            `(ar-xcar ,ra))
 357                        #f)))
 358                (xa (ac-complex-getargs x)))
 359           (append x (ac-complex-args (cdr args)
 360                                      (append xa env)
 361                                      `(ar-xcdr ,ra)
 362                                      is-params))))
 363        (#t (err "Can't understand fn arg list" args))))
 364
 365; (car ra) is the argument
 366; so it's not present if ra is nil or '()
 367
 368(define (ac-complex-opt var expr env ra)
 369  (list (list var `(if (pair? ,ra) (car ,ra) ,(ac expr env)))))
 370
 371; extract list of variables from list of two-element lists.
 372
 373(define (ac-complex-getargs a)
 374  (map (lambda (x) (car x)) a))
 375
 376; (a b . c) -> (a b c)
 377; a -> (a)
 378
 379(define (ac-arglist a)
 380  (cond ((null? a) '())
 381        ((symbol? a) (list a))
 382        ((symbol? (cdr a)) (list (car a) (cdr a)))
 383        (#t (cons (car a) (ac-arglist (cdr a))))))
 384
 385(define (ac-body body env)
 386  (map (lambda (x) (ac x env)) body))
 387
 388; like ac-body, but spits out a nil expression if empty
 389
 390(define (ac-body* body env)
 391  (if (null? body)
 392      (list (list 'quote 'nil))
 393      (ac-body body env)))
 394
 395; (set v1 expr1 v2 expr2 ...)
 396
 397(define (ac-set x env)
 398  `(begin ,@(ac-setn x env)))
 399
 400(define (ac-setn x env)
 401  (if (null? x)
 402      '()
 403      (cons (ac-set1 (ac-macex (car x)) (cadr x) env)
 404            (ac-setn (cddr x) env))))
 405
 406; trick to tell Scheme the name of something, so Scheme
 407; debugging and profiling make more sense.
 408
 409(define (ac-nameit name v)
 410  (if (symbol? name)
 411      (let ((n (string->symbol (string-append " " (symbol->string name)))))
 412        (list 'let `((,n ,v)) n))
 413      v))
 414
 415; = replaced by set, which is only for vars
 416; = now defined in arc (is it?)
 417; name is to cause fns to have their arc names for debugging
 418
 419(define (ac-set1 a b1 env)
 420  (if (symbol? a)
 421      (let ((b (ac b1 (ac-dbname! a env))))
 422        (list 'let `((zz ,b))
 423               (cond ((eqv? a 'nil) (err "Can't rebind nil"))
 424                     ((eqv? a 't) (err "Can't rebind t"))
 425                     ((lex? a env) `(set! ,a zz))
 426                     ((ac-defined-var? a) `(,(ac-global-name a) zz))
 427                     (#t `(namespace-set-variable-value! ',(ac-global-name a) 
 428                                                         zz)))
 429               'zz))
 430      (err "First arg to set must be a symbol" a)))
 431
 432; given a list of Arc expressions, return a list of Scheme expressions.
 433; for compiling passed arguments.
 434
 435(define (ac-args names exprs env)
 436  (if (null? exprs)
 437      '()
 438      (cons (ac (car exprs)
 439                (ac-dbname! (if (pair? names) (car names) #f) env))
 440            (ac-args (if (pair? names) (cdr names) '())
 441                     (cdr exprs)
 442                     env))))
 443
 444; generate special fast code for ordinary two-operand
 445; calls to the following functions. this is to avoid
 446; calling e.g. ar-is with its &rest and apply.
 447
 448(define ac-binaries
 449  '((is ar-is2)
 450    (< ar-<2)
 451    (> ar->2)
 452    (+ ar-+2)))
 453
 454; (foo bar) where foo is a global variable bound to a procedure.
 455
 456(define (ac-global-call fn args env)
 457  (cond ((and (assoc fn ac-binaries) (= (length args) 2))
 458         `(,(cadr (assoc fn ac-binaries)) ,@(ac-args '() args env)))
 459        (#t 
 460         `(,(ac-global-name fn) ,@(ac-args '() args env)))))
 461      
 462; compile a function call
 463; special cases for speed, to avoid compiled output like
 464;   (ar-apply _pr (list 1 2))
 465; which results in 1/2 the CPU time going to GC. Instead:
 466;   (ar-funcall2 _pr 1 2)
 467; and for (foo bar), if foo is a reference to a global variable,
 468;   and it's bound to a function, generate (foo bar) instead of
 469;   (ar-funcall1 foo bar)
 470
 471(define (ac-call fn args env)
 472  (let ((macfn (ac-macro? fn)))
 473    (cond (macfn
 474           (ac-mac-call macfn args env))
 475          ((and (pair? fn) (eqv? (car fn) 'fn))
 476           `(,(ac fn env) ,@(ac-args (cadr fn) args env)))
 477          ((and (ar-bflag 'direct-calls) (symbol? fn) (not (lex? fn env)) (bound? fn)
 478                (procedure? (namespace-variable-value (ac-global-name fn))))
 479           (ac-global-call fn args env))
 480          (#t
 481           `((ar-coerce ,(ac fn env) 'fn)
 482             ,@(map (lambda (x) (ac x env)) args))))))
 483
 484(define (ac-mac-call m args env)
 485  (let ((x1 (apply m (map ac-niltree args))))
 486    (let ((x2 (ac (ac-denil x1) env)))
 487      x2)))
 488
 489; returns #f or the macro function
 490
 491(define (ac-macro? fn)
 492  (if (symbol? fn)
 493      (let ((v (namespace-variable-value (ac-global-name fn) 
 494                                         #t 
 495                                         (lambda () #f))))
 496        (if (and v
 497                 (ar-tagged? v)
 498                 (eq? (ar-type v) 'mac))
 499            (ar-rep v)
 500            #f))
 501      #f))
 502
 503; macroexpand the outer call of a form as much as possible
 504
 505(define (ac-macex e . once)
 506  (if (pair? e)
 507      (let ((m (ac-macro? (car e))))
 508        (if m
 509            (let ((expansion (ac-denil (apply m (map ac-niltree (cdr e))))))
 510              (if (null? once) (ac-macex expansion) expansion))
 511            e))
 512      e))
 513
 514; macros return Arc lists, ending with NIL.
 515; but the Arc compiler expects Scheme lists, ending with '().
 516; what to do with (is x nil . nil) ?
 517;   the first nil ought to be replaced with 'NIL
 518;   the second with '()
 519; so the rule is: NIL in the car -> 'NIL, NIL in the cdr -> '().
 520;   NIL by itself -> NIL
 521
 522(define (ac-denil x)
 523  (cond ((pair? x) (cons (ac-denil-car (car x)) (ac-denil-cdr (cdr x))))
 524        ((hash-table? x) 
 525         (let ((xc (make-hash-table 'equal)))
 526           (hash-table-for-each x
 527             (lambda (k v) (hash-table-put! xc (ac-denil k) (ac-denil v))))
 528           xc))
 529        (#t x)))
 530
 531(define (ac-denil-car x)
 532  (if (eq? x 'nil)
 533      'nil
 534      (ac-denil x)))
 535
 536(define (ac-denil-cdr x)
 537  (if (eq? x 'nil)
 538      '()
 539      (ac-denil x)))
 540
 541; is v lexically bound?
 542
 543(define (lex? v env)
 544  (memq v env))
 545
 546(define (xcar x)
 547  (and (pair? x) (car x)))
 548
 549; #f and '() -> nil for a whole quoted list/tree.
 550
 551; Arc primitives written in Scheme should look like:
 552
 553; (xdef foo (lambda (lst)
 554;           (ac-niltree (scheme-foo (ar-nil-terminate lst)))))
 555
 556; That is, Arc lists are NIL-terminated. When calling a Scheme
 557; function that treats an argument as a list, call ar-nil-terminate
 558; to change NIL to '(). When returning any data created by Scheme
 559; to Arc, call ac-niltree to turn all '() into NIL.
 560; (hash-table-get doesn't use its argument as a list, so it doesn't
 561; need ar-nil-terminate).
 562
 563(define (ac-niltree x)
 564  (cond ((pair? x)   (cons (ac-niltree (car x)) (ac-niltree (cdr x))))
 565        ((or (eq? x #f) (eq? x '()) (void? x))   'nil)
 566        (#t   x)))
 567
 568; The next two are optimizations, except work for macros.
 569
 570(define (decompose fns args)
 571  (cond ((null? fns) `((fn vals (car vals)) ,@args))
 572        ((null? (cdr fns)) (cons (car fns) args))
 573        (#t (list (car fns) (decompose (cdr fns) args)))))
 574
 575(define (ac-andf s env)
 576  (ac (let ((gs (map (lambda (x) (gensym)) (cdr s))))
 577               `((fn ,gs
 578                   (and ,@(map (lambda (f) `(,f ,@gs))
 579                               (cdar s))))
 580                 ,@(cdr s)))
 581      env))
 582
 583(define err error)
 584
 585; run-time primitive procedures
 586
 587;(define (xdef a b)
 588;  (namespace-set-variable-value! (ac-global-name a) b)
 589;  b)
 590
 591(define-syntax xdef
 592  (syntax-rules ()
 593    ((xxdef a b)
 594     (let ((nm (ac-global-name 'a))
 595           (a b))
 596       (namespace-set-variable-value! nm a)
 597       a))))
 598
 599(define fn-signatures (make-hash-table 'equal))
 600
 601; This is a replacement for xdef that stores opeator signatures.
 602; Haven't started using it yet.
 603
 604(define (odef a parms b)
 605  (namespace-set-variable-value! (ac-global-name a) b)
 606  (hash-table-put! fn-signatures a (list parms))
 607  b)
 608
 609(xdef sig fn-signatures)
 610
 611; versions of car and cdr for parsing arguments for optional
 612; parameters, that yield nil for nil. maybe we should use
 613; full Arc car and cdr, so we can destructure more things
 614
 615(define (ar-xcar x)
 616  (if (or (eqv? x 'nil) (eqv? x '()))
 617      'nil
 618      (car x)))
 619      
 620(define (ar-xcdr x)
 621  (if (or (eqv? x 'nil) (eqv? x '()))
 622      'nil
 623      (cdr x)))
 624
 625; convert #f from a Scheme predicate to NIL.
 626
 627(define (ar-nill x)
 628  (if (or (eq? x '()) (eq? x #f))
 629      'nil
 630      x))
 631
 632; definition of falseness for Arc if.
 633; must include '() since sometimes Arc functions see
 634; Scheme lists (e.g. . body of a macro).
 635
 636(define (ar-false? x)
 637  (or (eq? x 'nil) (eq? x '()) (eq? x #f)))
 638
 639; call a function or perform an array ref, hash ref, &c
 640
 641; Non-fn constants in functional position are valuable real estate, so
 642; should figure out the best way to exploit it.  What could (1 foo) or 
 643; ('a foo) mean?  Maybe it should mean currying.
 644
 645; For now the way to make the default val of a hash table be other than
 646; nil is to supply the val when doing the lookup.  Later may also let
 647; defaults be supplied as an arg to table.  To implement this, need: an 
 648; eq table within scheme mapping tables to defaults, and to adapt the 
 649; code in arc.arc that reads and writes tables to read and write their 
 650; default vals with them.  To make compatible with existing written tables, 
 651; just use an atom or 3-elt list to keep the default.
 652
 653(define (ar-apply fn args)
 654  (apply (ar-coerce fn 'fn) args))
 655
 656(xdef apply (lambda (fn . args)
 657               (ar-apply fn (ar-apply-args args))))
 658
 659; replace the nil at the end of a list with a '()
 660
 661(define (ar-nil-terminate l)
 662  (if (or (eqv? l '()) (eqv? l 'nil))
 663      '()
 664      (cons (car l) (ar-nil-terminate (cdr l)))))
 665
 666; turn the arguments to Arc apply into a list.
 667; if you call (apply fn 1 2 '(3 4))
 668; then args is '(1 2 (3 4 . nil) . ())
 669; that is, the main list is a scheme list.
 670; and we should return '(1 2 3 4 . ())
 671; was once (apply apply list (ac-denil args))
 672; but that didn't work for (apply fn nil)
 673
 674(define (ar-apply-args args)
 675  (cond ((null? args) '())
 676        ((null? (cdr args)) (ar-nil-terminate (car args)))
 677        (#t (cons (car args) (ar-apply-args (cdr args))))))
 678
 679
 680
 681
 682
 683(xdef cons cons)
 684
 685(xdef car (lambda (x)
 686             (cond ((pair? x)     (car x))
 687                   ((eqv? x 'nil) 'nil)
 688                   ((eqv? x '())  'nil)
 689                   (#t            (err "Can't take car of" x)))))
 690
 691(xdef cdr (lambda (x)
 692             (cond ((pair? x)     (cdr x))
 693                   ((eqv? x 'nil) 'nil)
 694                   ((eqv? x '())  'nil)
 695                   (#t            (err "Can't take cdr of" x)))))
 696
 697(define (tnil x) (if x 't 'nil))
 698
 699; (pairwise pred '(a b c d)) =>
 700;   (and (pred a b) (pred b c) (pred c d))
 701; pred returns t/nil, as does pairwise
 702; reduce? 
 703
 704(define (pairwise pred lst)
 705  (cond ((null? lst) 't)
 706        ((null? (cdr lst)) 't)
 707        ((not (eqv? (pred (car lst) (cadr lst)) 'nil))
 708         (pairwise pred (cdr lst)))
 709        (#t 'nil)))
 710
 711; not quite right, because behavior of underlying eqv unspecified
 712; in many cases according to r5rs
 713; do we really want is to ret t for distinct strings?
 714
 715; for (is x y)
 716
 717(define (ar-is2 a b)
 718  (tnil (or (eqv? a b)
 719            (and (string? a) (string? b) (string=? a b))
 720            (and (ar-false? a) (ar-false? b)))))
 721
 722; for all other uses of is
 723
 724(xdef is (lambda args (pairwise ar-is2 args)))
 725
 726(xdef err err)
 727(xdef nil 'nil)
 728(xdef t   't)
 729
 730(define (all test seq)
 731  (or (null? seq) 
 732      (and (test (car seq)) (all test (cdr seq)))))
 733
 734(define (arc-list? x) (or (pair? x) (eqv? x 'nil) (eqv? x '())))
 735      
 736; Generic +: strings, lists, numbers.
 737; Return val has same type as first argument.
 738
 739(xdef + (lambda args
 740           (cond ((null? args) 0)
 741                 ((char-or-string? (car args))
 742                  (apply string-append 
 743                         (map (lambda (a) (ar-coerce a 'string))
 744                              args)))
 745                 ((arc-list? (car args)) 
 746                  (ac-niltree (apply append (map ar-nil-terminate args))))
 747                 (#t (apply + args)))))
 748
 749(define (char-or-string? x) (or (string? x) (char? x)))
 750
 751(define (ar-+2 x y)
 752  (cond ((char-or-string? x)
 753         (string-append (ar-coerce x 'string) (ar-coerce y 'string)))
 754        ((and (arc-list? x) (arc-list? y))
 755         (ac-niltree (append (ar-nil-terminate x) (ar-nil-terminate y))))
 756        (#t (+ x y))))
 757
 758(xdef - -)
 759(xdef * *)
 760(xdef / /)
 761(xdef mod modulo)
 762(xdef expt expt)
 763(xdef sqrt sqrt)
 764
 765; generic comparison
 766
 767(define (ar->2 x y)
 768  (tnil (cond ((and (number? x) (number? y)) (> x y))
 769              ((and (string? x) (string? y)) (string>? x y))
 770              ((and (symbol? x) (symbol? y)) (string>? (symbol->string x)
 771                                                       (symbol->string y)))
 772              ((and (char? x) (char? y)) (char>? x y))
 773              (#t (> x y)))))
 774
 775(xdef > (lambda args (pairwise ar->2 args)))
 776
 777(define (ar-<2 x y)
 778  (tnil (cond ((and (number? x) (number? y)) (< x y))
 779              ((and (string? x) (string? y)) (string<? x y))
 780              ((and (symbol? x) (symbol? y)) (string<? (symbol->string x)
 781                                                       (symbol->string y)))
 782              ((and (char? x) (char? y)) (char<? x y))
 783              (#t (< x y)))))
 784
 785(xdef < (lambda args (pairwise ar-<2 args)))
 786
 787(xdef len (lambda (x)
 788             (cond ((string? x) (string-length x))
 789                   ((hash-table? x) (hash-table-count x))
 790                   (#t (length (ar-nil-terminate x))))))
 791
 792(define (ar-tagged? x)
 793  (and (vector? x) (eq? (vector-ref x 0) 'tagged)))
 794
 795(define (ar-tag type rep)
 796  (cond ((eqv? (ar-type rep) type) rep)
 797        (#t (vector 'tagged type rep))))
 798
 799(xdef annotate ar-tag)
 800
 801; (type nil) -> sym
 802
 803(define (exint? x) (and (integer? x) (exact? x)))
 804
 805(define (ar-type x)
 806  (cond ((ar-tagged? x)     (vector-ref x 1))
 807        ((pair? x)          'cons)
 808        ((symbol? x)        'sym)
 809        ((null? x)          'sym)
 810        ((procedure? x)     'fn)
 811        ((char? x)          'char)
 812        ((string? x)        'string)
 813        ((exint? x)         'int)
 814        ((number? x)        'num)     ; unsure about this
 815        ((hash-table? x)    'table)
 816        ((output-port? x)   'output)
 817        ((input-port? x)    'input)
 818        ((tcp-listener? x)  'socket)
 819        ((exn? x)           'exception)
 820        ((thread? x)        'thread)
 821        ((thread-cell? x)   'thread-cell)
 822        (#t                 (err "Type: unknown type" x))))
 823(xdef type ar-type)
 824
 825(define (ar-rep x)
 826  (if (ar-tagged? x)
 827      (vector-ref x 2)
 828      x))
 829
 830(xdef rep ar-rep)
 831
 832(xdef uniq gensym)
 833
 834(xdef ccc call-with-current-continuation)
 835
 836(xdef infile  open-input-file)
 837
 838(xdef outfile (lambda (f . args) 
 839                 (open-output-file f 
 840                                   'text
 841                                   (if (equal? args '(append))
 842                                       'append
 843                                       'truncate))))
 844
 845(xdef instring  open-input-string)
 846(xdef outstring open-output-string)
 847
 848; use as general fn for looking inside things
 849
 850(xdef inside get-output-string)
 851
 852(xdef stdout current-output-port)  ; should be a vars
 853(xdef stdin  current-input-port) 
 854(xdef stderr current-error-port)
 855
 856(xdef call-w/stdout
 857      (lambda (port thunk)
 858        (parameterize ((current-output-port port)) (thunk))))
 859
 860(xdef call-w/stdin
 861      (lambda (port thunk)
 862        (parameterize ((current-input-port port)) (thunk))))
 863
 864(xdef readc (lambda str
 865              (let ((c (read-char (if (pair? str)
 866                                      (car str)
 867                                      (current-input-port)))))
 868                (if (eof-object? c) 'nil c))))
 869
 870(xdef readchars (lambda (n . str)
 871                  (let ((cs (read-string n (if (pair? str)
 872                                              (car str)
 873                                              (current-input-port)))))
 874                    (if (eof-object? cs) 'nil (string->list cs)))))
 875
 876(xdef readb (lambda str
 877              (let ((c (read-byte (if (pair? str)
 878                                      (car str)
 879                                      (current-input-port)))))
 880                (if (eof-object? c) 'nil c))))
 881
 882(xdef readbytes (lambda (n . str)
 883                  (let ((bs (read-bytes n (if (pair? str)
 884                                              (car str)
 885                                              (current-input-port)))))
 886                    (if (eof-object? bs) 'nil (bytes->list bs)))))
 887
 888(xdef peekc (lambda str 
 889              (let ((c (peek-char (if (pair? str)
 890                                      (car str)
 891                                      (current-input-port)))))
 892                (if (eof-object? c) 'nil c))))
 893
 894(xdef writec (lambda (c . args) 
 895                (write-char c 
 896                            (if (pair? args) 
 897                                (car args) 
 898                                (current-output-port)))
 899                c))
 900
 901(xdef writeb (lambda (b . args) 
 902                (write-byte b 
 903                            (if (pair? args) 
 904                                (car args) 
 905                                (current-output-port)))
 906                b))
 907
 908(define (printwith f args)
 909  (let ((port (if (> (length args) 1)
 910                  (cadr args)
 911                  (current-output-port))))
 912    (when (pair? args)
 913      (f (ac-denil (car args)) port))
 914    (unless (ar-bflag 'explicit-flush)
 915      (flush-output port)))
 916  'nil)
 917
 918(defarc write (arc-write . args) (printwith write args))
 919(xdef disp  (lambda args (printwith display args)))
 920
 921; sread = scheme read. eventually replace by writing read
 922
 923(xdef sread (lambda (p eof)
 924               (let ((expr (read p)))
 925                 (if (eof-object? expr) eof expr))))
 926
 927; these work in PLT but not scheme48
 928
 929(define char->ascii char->integer)
 930(define ascii->char integer->char)
 931
 932(define (iround x) (inexact->exact (round x)))
 933
 934; look up first by target type, then by source type
 935(define coercions (make-hash-table 'equal))
 936
 937(for-each (lambda (e)
 938            (let ((target-type (car e))
 939                  (conversions (make-hash-table 'equal)))
 940              (hash-table-put! coercions target-type conversions)
 941              (for-each
 942               (lambda (x) (hash-table-put! conversions (car x) (cadr x)))
 943               (cdr e))))
 944 `((fn      (cons   ,(lambda (l) (lambda (i) (list-ref l i))))
 945            (string ,(lambda (s) (lambda (i) (string-ref s i))))
 946            (table  ,(lambda (h) (case-lambda
 947                                  ((k) (hash-table-get h k 'nil))
 948                                  ((k d) (hash-table-get h k d))))))
 949
 950   (string  (int    ,number->string)
 951            (num    ,number->string)
 952            (char   ,string)
 953            (cons   ,(lambda (l) (apply string-append
 954                                        (map (lambda (y) (ar-coerce y 'string))
 955                                             (ar-nil-terminate l)))))
 956            (sym    ,(lambda (x) (if (eqv? x 'nil) "" (symbol->string x)))))
 957
 958   (sym     (string ,string->symbol)
 959            (char   ,(lambda (c) (string->symbol (string c)))))
 960
 961   (int     (char   ,(lambda (c . args) (char->ascii c)))
 962            (num    ,(lambda (x . args) (iround x)))
 963            (string ,(lambda (x . args)
 964                       (let ((n (apply string->number x args)))
 965                         (if n (iround n)
 966                             (err "Can't coerce " x 'int))))))
 967
 968   (num     (string ,(lambda (x . args)
 969                       (or (apply string->number x args)
 970                           (err "Can't coerce " x 'num))))
 971            (int    ,(lambda (x) x)))
 972
 973   (cons    (string ,(lambda (x) (ac-niltree (string->list x)))))
 974
 975   (char    (int    ,ascii->char)
 976            (num    ,(lambda (x) (ascii->char (iround x)))))))
 977
 978(define (ar-coerce x type . args)
 979  (let ((x-type (ar-type x)))
 980    (if (eqv? type x-type) x
 981        (let* ((fail        (lambda () (err "Can't coerce " x type)))
 982               (conversions (hash-table-get coercions type fail))
 983               (converter   (hash-table-get conversions x-type fail)))
 984          (ar-apply converter (cons x args))))))
 985
 986(xdef coerce ar-coerce)
 987(xdef coerce* coercions)
 988
 989(xdef parameter make-parameter)
 990(xdef parameterize-sub
 991      (lambda (var val thunk)
 992        (parameterize ((var val)) (thunk))))
 993
 994(xdef open-socket  (lambda (num) (tcp-listen num 50 #t))) 
 995
 996(define (ar-init-socket init-fn . args)
 997  (let ((oc (current-custodian))
 998        (nc (make-custodian)))
 999    (current-custodian nc)
1000    (apply
1001      (lambda (in out . tail)
1002        (current-custodian oc)
1003        (associate-custodian nc in out)
1004        (list* in out tail))
1005      (call-with-values
1006        init-fn
1007        (if (pair? args)
1008            (car args)
1009            list)))))
1010
1011; the 2050 means http requests currently capped at 2 meg
1012; http://list.cs.brown.edu/pipermail/plt-scheme/2005-August/009414.html
1013
1014(xdef socket-accept (lambda (s)
1015                      (ar-init-socket
1016                        (lambda () (tcp-accept s))
1017                        (lambda (in out)
1018                          (list (make-limited-input-port in 100000 #t)
1019                                out
1020                                (let-values (((us them) (tcp-addresses out)))
1021                                  them))))))
1022
1023(xdef socket-connect (lambda (host port)
1024                       (ar-init-socket
1025                         (lambda () (tcp-connect host port)))))
1026
1027; allow Arc to give up root privileges after it
1028; calls open-socket. thanks, Eli!
1029(define setuid (get-ffi-obj 'setuid #f (_fun _int -> _int)))
1030(xdef setuid setuid)
1031
1032(xdef new-thread thread)
1033(xdef current-thread current-thread)
1034
1035(define (wrapnil f) (lambda args (apply f args) 'nil))
1036
1037(xdef sleep (wrapnil sleep))
1038
1039; Will system "execute" a half-finished string if thread killed
1040; in the middle of generating it?  
1041
1042(xdef system (lambda (s) (tnil (system s))))
1043
1044(xdef pipe-from (lambda (cmd)
1045                   (let ((tf (ar-tmpname)))
1046                     (system (string-append cmd " > " tf))
1047                     (let ((str (open-input-file tf)))
1048                       (system (string-append "rm -f " tf))
1049                       str))))
1050                   
1051(define (ar-tmpname)
1052  (call-with-input-file "/dev/urandom"
1053    (lambda (rstr)
1054      (do ((s "/tmp/")
1055           (c (read-char rstr) (read-char rstr))
1056           (i 0 (+ i 1)))
1057          ((>= i 16) s)
1058        (set! s (string-append s
1059                               (string
1060                                 (integer->char
1061                                   (+ (char->integer #\a)
1062                                      (modulo
1063                                        (char->integer (read-char rstr))
1064                                        26))))))))))
1065
1066; PLT scheme provides only eq? and equal? hash tables,
1067; we need the latter for strings.
1068
1069(xdef table (lambda args
1070              (let ((h (make-hash-table 'equal)))
1071                (if (pair? args) ((car args) h))
1072                h)))
1073
1074;(xdef table (lambda args
1075;               (fill-table (make-hash-table 'equal) 
1076;                           (if (pair? args) (ac-denil (car args)) '()))))
1077                   
1078(define (fill-table h pairs)
1079  (if (eq? pairs '())
1080      h
1081      (let ((pair (car pairs)))
1082        (begin (hash-table-put! h (car pair) (cadr pair))
1083               (fill-table h (cdr pairs))))))
1084
1085(xdef maptable (lambda (fn table)               ; arg is (fn (key value) ...)
1086                  (hash-table-for-each table fn)
1087                  table))
1088
1089(define (protect during after)
1090  (dynamic-wind (lambda () #t) during after))
1091
1092(xdef protect protect)
1093
1094; need to use a better seed
1095
1096(xdef rand random)
1097
1098(xdef dir (lambda (name)
1099            (ac-niltree (map path->string (directory-list name)))))
1100
1101; Would def mkdir in terms of make-directory and call that instead
1102; of system in ensure-dir, but make-directory is too weak: it doesn't
1103; create intermediate directories like mkdir -p.
1104
1105(xdef file-exists (lambda (name)
1106                     (if (file-exists? name) name 'nil)))
1107
1108(xdef dir-exists (lambda (name)
1109                     (if (directory-exists? name) name 'nil)))
1110
1111(xdef rmfile (wrapnil delete-file))
1112
1113(xdef mvfile (lambda (old new)
1114                (rename-file-or-directory old new #t)
1115                'nil))
1116
1117; top level read-eval-print
1118; tle kept as a way to get a break loop when a scheme err
1119
1120(define (arc-eval expr) 
1121  (eval (ac expr '())))
1122
1123(define (tle)
1124  (display "Arc> ")
1125  (let ((expr (read)))
1126    (when (not (eqv? expr ':a))
1127      (write (arc-eval expr))
1128      (newline)
1129      (tle))))
1130
1131(define last-condition* #f)
1132
1133(define (tl)
1134  (let ((interactive? (terminal-port? (current-input-port))))
1135    (when interactive? 
1136      (display "Use (quit) or ^D to quit, (tl) to return here after an interrupt.\n"))
1137    (tl2 interactive?)))
1138
1139(define (tl2 interactive?)
1140  (when interactive? (display "arc> "))
1141  (on-err (lambda (c) 
1142            (set! last-condition* c)
1143            (parameterize ((current-output-port (current-error-port)))
1144              (display "Error: ")
1145              (write (exn-message c))
1146              (newline)
1147              (tl2 interactive?)))
1148    (lambda ()
1149      (let ((expr (read)))
1150        (if (eof-object? expr)
1151             (begin (when interactive? (newline))
1152                    (exit)))
1153        (if (eqv? expr ':a)
1154            'done
1155            (let ((val (arc-eval expr)))
1156              (when interactive?
1157                (arc-write (ac-denil val))
1158                (newline))
1159              (namespace-set-variable-value! '_that val)
1160              (namespace-set-variable-value! '_thatexpr expr)
1161              (tl2 interactive?)))))))
1162
1163(define (aload1 p)
1164  (let ((x (read p)))
1165    (if (eof-object? x)
1166        #t
1167        (begin
1168          (arc-eval x)
1169          (aload1 p)))))
1170
1171(define (atests1 p)
1172  (let ((x (read p)))
1173    (if (eof-object? x)
1174        #t
1175        (begin
1176          (write x)
1177          (newline)
1178          (let ((v (arc-eval x)))
1179            (if (ar-false? v)
1180                (begin
1181                  (display "  FAILED")
1182                  (newline))))
1183          (atests1 p)))))
1184
1185(define (aload filename)
1186  (call-with-input-file filename aload1))
1187
1188(define (test filename)
1189  (call-with-input-file filename atests1))
1190
1191(define (acompile1 ip op)
1192  (let ((x (read ip)))
1193    (if (eof-object? x)
1194        #t
1195        (let ((scm (ac x '())))
1196          (eval scm)
1197          (pretty-print scm op)
1198          (newline op)
1199          (newline op)
1200          (acompile1 ip op)))))
1201
1202; compile xx.arc to xx.arc.scm
1203; useful to examine the Arc compiler output
1204(define (acompile inname)
1205  (let ((outname (string-append inname ".scm")))
1206    (if (file-exists? outname)
1207        (delete-file outname))
1208    (call-with-input-file inname
1209      (lambda (ip)
1210        (call-with-output-file outname 
1211          (lambda (op)
1212            (acompile1 ip op)))))))
1213
1214(xdef macex (lambda (e) (ac-macex (ac-denil e))))
1215
1216(xdef macex1 (lambda (e) (ac-macex (ac-denil e) 'once)))
1217
1218(xdef eval (lambda (e)
1219              (eval (ac (ac-denil e) '()))))
1220
1221; If an err occurs in an on-err expr, no val is returned and code
1222; after it doesn't get executed.  Not quite what I had in mind.
1223
1224(define (on-err errfn f)
1225  ((call-with-current-continuation 
1226     (lambda (k) 
1227       (lambda () 
1228         (with-handlers ((exn:fail? (lambda (c) 
1229                                      (k (lambda () (errfn c)))))) 
1230                        (f)))))))
1231(xdef on-err on-err)
1232
1233(define (disp-to-string x)
1234  (let ((o (open-output-string)))
1235    (display x o)
1236    (close-output-port o)
1237    (get-output-string o)))
1238
1239(xdef details (lambda (c)
1240                 (disp-to-string (exn-message c))))
1241
1242(xdef scar (lambda (x val) 
1243              (if (string? x) 
1244                  (string-set! x 0 val)
1245                  (x-set-car! x val))
1246              val))
1247
1248(xdef scdr (lambda (x val) 
1249              (if (string? x)
1250                  (err "Can't set cdr of a string" x)
1251                  (x-set-cdr! x val))
1252              val))
1253
1254; decide at run-time whether the underlying mzscheme supports
1255; set-car! and set-cdr!, since I can't figure out how to do it
1256; at compile time.
1257
1258(define (x-set-car! p v)
1259  (let ((fn (namespace-variable-value 'set-car! #t (lambda () #f))))
1260    (if (procedure? fn)
1261        (fn p v)
1262        (n-set-car! p v))))
1263
1264(define (x-set-cdr! p v)
1265  (let ((fn (namespace-variable-value 'set-cdr! #t (lambda () #f))))
1266    (if (procedure? fn)
1267        (fn p v)
1268        (n-set-cdr! p v))))
1269
1270; Eli's code to modify mzscheme-4's immutable pairs.
1271
1272;; to avoid a malloc on every call, reuse a single pointer, but make
1273;; it thread-local to avoid races
1274(define ptr (make-thread-cell #f))
1275(define (get-ptr)
1276  (or (thread-cell-ref ptr)
1277      (let ([p (malloc _scheme 1)]) (thread-cell-set! ptr p) p)))
1278
1279;; set a pointer to the cons cell, then dereference it as a pointer,
1280;; and bang the new value in the given offset
1281(define (set-ca/dr! offset who p x)
1282  (if (pair? p)
1283    (let ([p* (get-ptr)])
1284      (ptr-set! p* _scheme p)
1285      (ptr-set! (ptr-ref p* _pointer 0) _scheme offset x))
1286    (raise-type-error who "pair" p)))
1287
1288(define (n-set-car! p x) (set-ca/dr! 1 'set-car! p x))
1289(define (n-set-cdr! p x) (set-ca/dr! 2 'set-cdr! p x))
1290
1291; When and if cdr of a string returned an actual (eq) tail, could
1292; say (if (string? x) (string-replace! x val 1) ...) in scdr, but
1293; for now would be misleading to allow this, because fails for cddr.
1294
1295(define (string-replace! str val index)
1296  (if (eqv? (string-length val) (- (string-length str) index))
1297      (do ((i index (+ i 1)))
1298          ((= i (string-length str)) str)
1299        (string-set! str i (string-ref val (- i index))))
1300      (err "Length mismatch between strings" str val index)))
1301
1302; Later may want to have multiple indices.
1303
1304(xdef sref 
1305  (lambda (com val ind)
1306    (cond ((hash-table? com)  (if (eqv? val 'nil)
1307                                  (hash-table-remove! com ind)
1308                                  (hash-table-put! com ind val)))
1309          ((string? com) (string-set! com ind val))
1310          ((pair? com)   (nth-set! com ind val))
1311          (#t (err "Can't set reference " com ind val)))
1312    val))
1313
1314(define (nth-set! lst n val)
1315  (x-set-car! (list-tail lst n) val))
1316
1317; rewrite to pass a (true) gensym instead of #f in case var bound to #f
1318
1319(define (bound? arcname)
1320  (namespace-variable-value (ac-global-name arcname)
1321                            #t
1322                            (lambda () #f)))
1323
1324(xdef bound (lambda (x) (tnil (bound? x))))
1325
1326(xdef newstring make-string)
1327
1328(xdef trunc (lambda (x) (inexact->exact (truncate x))))
1329
1330; bad name
1331
1332(xdef exact (lambda (x) (tnil (exint? x))))
1333
1334(xdef msec                         current-milliseconds)
1335(xdef current-process-milliseconds current-process-milliseconds)
1336(xdef current-gc-milliseconds      current-gc-milliseconds)
1337
1338(xdef seconds current-seconds)
1339
1340(print-hash-table #t)
1341
1342(xdef client-ip (lambda (port) 
1343                   (let-values (((x y) (tcp-addresses port)))
1344                     y)))
1345
1346; make sure only one thread at a time executes anything
1347; inside an atomic-invoke. atomic-invoke is allowed to
1348; nest within a thread; the thread-cell keeps track of
1349; whether this thread already holds the lock.
1350
1351(define ar-atomic-sema (make-semaphore 1))
1352(define ar-atomic-cell (make-thread-cell #f))
1353(xdef atomic-invoke (lambda (f)
1354                       (if (thread-cell-ref ar-atomic-cell)
1355                           (ar-apply f '())
1356                           (begin
1357                             (thread-cell-set! ar-atomic-cell #t)
1358                             (protect
1359                              (lambda ()
1360                                (call-with-semaphore
1361                                 ar-atomic-sema
1362                                 (lambda () (ar-apply f '()))))
1363                              (lambda ()
1364                                (thread-cell-set! ar-atomic-cell #f)))))))
1365
1366(xdef dead (lambda (x) (tnil (thread-dead? x))))
1367
1368; Added because Mzscheme buffers output.  Not a permanent part of Arc.
1369; Only need to use when declare explicit-flush optimization.
1370
1371(xdef flushout (lambda args (flush-output (if (pair? args)
1372                                              (car args)
1373                                              (current-output-port)))
1374                            't))
1375
1376(xdef ssyntax (lambda (x) (tnil (ssyntax? x))))
1377
1378(xdef ssexpand (lambda (x)
1379                  (if (symbol? x) (expand-ssyntax x) x)))
1380
1381(xdef quit exit)
1382
1383; there are two ways to close a TCP output port.
1384; (close o) waits for output to drain, then closes UNIX descriptor.
1385; (force-close o) discards buffered output, then closes UNIX desc.
1386; web servers need the latter to get rid of connections to
1387; clients that are not reading data.
1388; mzscheme close-output-port doesn't work (just raises an error)
1389; if there is buffered output for a non-responsive socket.
1390; must use custodian-shutdown-all instead.
1391
1392(define custodians (make-hash-table 'equal))
1393
1394(define (associate-custodian c i o)
1395  (hash-table-put! custodians i c)
1396  (hash-table-put! custodians o c))
1397
1398; if a port has a custodian, use it to close the port forcefully.
1399; also get rid of the reference to the custodian.
1400; sadly doing this to the input port also kills the output port.
1401
1402(define (try-custodian p)
1403  (let ((c (hash-table-get custodians p #f)))
1404    (if c
1405        (begin
1406          (custodian-shutdown-all c)
1407          (hash-table-remove! custodians p)
1408          #t)
1409        #f)))
1410
1411(define (ar-close . args)
1412  (map (lambda (p)
1413         (cond ((input-port? p)   (close-input-port p))
1414               ((output-port? p)  (close-output-port p))
1415               ((tcp-listener? p) (tcp-close p))
1416               (#t (err "Can't close " p))))
1417       args)
1418  (map (lambda (p) (try-custodian p)) args) ; free any custodian
1419  'nil)
1420
1421(xdef close ar-close)
1422
1423(xdef force-close (lambda args
1424                       (map (lambda (p)
1425                              (if (not (try-custodian p))
1426                                  (ar-close p)))
1427                            args)
1428                       'nil))
1429
1430(xdef memory current-memory-use)
1431
1432(define ar-declarations (make-hash-table))
1433
1434(define (ar-bflag key)
1435  (not (ar-false? (hash-table-get ar-declarations key 'nil))))
1436
1437(xdef declarations* ar-declarations)
1438
1439(putenv "TZ" ":GMT")
1440
1441(define (gmt-date sec) (seconds->date sec))
1442
1443(xdef timedate 
1444  (lambda args
1445    (let ((d (gmt-date (if (pair? args) (car args) (current-seconds)))))
1446      (ac-niltree (list (date-second d)
1447                        (date-minute d)
1448                        (date-hour d)
1449                        (date-day d)
1450                        (date-month d)
1451                        (date-year d))))))
1452
1453(xdef utf-8-bytes
1454  (lambda (str)
1455    (bytes->list (string->bytes/utf-8 str))))
1456
1457(xdef sin sin)
1458(xdef cos cos)
1459(xdef tan tan)
1460(xdef asin asin)
1461(xdef acos acos)
1462(xdef atan atan)
1463(xdef log log)
1464
1465(xdef lor bitwise-ior)
1466(xdef land bitwise-and)
1467(xdef lxor bitwise-xor)
1468(xdef lnot bitwise-not)
1469(xdef shl arithmetic-shift)
1470
1471(define (codestring s)
1472  (let ((i (atpos s 0)))
1473    (if i
1474        (cons (substring s 0 i)
1475              (let* ((rest (substring s (+ i 1)))
1476                     (in (open-input-string rest))
1477                     (expr (read in))
1478                     (i2 (let-values (((x y z) (port-next-location in))) z)))
1479                (close-input-port in)
1480                (cons expr (codestring (substring rest (- i2 1))))))
1481        (list s))))
1482
1483; First unescaped @ in s, if any.  Escape by doubling.
1484
1485(define (atpos s i)
1486  (cond ((eqv? i (string-length s)) 
1487         #f)
1488        ((eqv? (string-ref s i) #\@)
1489         (if (and (< (+ i 1) (string-length s))
1490                  (not (eqv? (string-ref s (+ i 1)) #\@)))
1491             i
1492             (atpos s (+ i 2))))
1493        (#t                         
1494         (atpos s (+ i 1)))))
1495
1496(define (unescape-ats s)
1497  (list->string (letrec ((unesc (lambda (cs)
1498                                  (cond 
1499                                    ((null? cs) 
1500                                     '())
1501                                    ((and (eqv? (car cs) #\@) 
1502                                          (not (null? (cdr cs)))
1503                                          (eqv? (cadr cs) #\@))
1504                                     (unesc (cdr cs)))
1505                                    (#t
1506                                     (cons (car cs) (unesc (cdr cs))))))))
1507                  (unesc (string->list s)))))
1508
1509)