/ac.scm
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)