summaryrefslogtreecommitdiffstats
path: root/ac.scm
diff options
context:
space:
mode:
authorbnewbold <bnewbold@robocracy.org>2011-06-24 17:21:45 -0400
committerbnewbold <bnewbold@robocracy.org>2011-06-24 17:21:45 -0400
commit421dc8c7141ecb6297996f7370d96e7e99894683 (patch)
tree50b8bcf931c4dc204f74b8721de9244ab4977056 /ac.scm
downloadslackernews-421dc8c7141ecb6297996f7370d96e7e99894683.tar.gz
slackernews-421dc8c7141ecb6297996f7370d96e7e99894683.zip
arc3.1.tar
Diffstat (limited to 'ac.scm')
-rw-r--r--ac.scm1489
1 files changed, 1489 insertions, 0 deletions
diff --git a/ac.scm b/ac.scm
new file mode 100644
index 0000000..173ff4a
--- /dev/null
+++ b/ac.scm
@@ -0,0 +1,1489 @@
+; Arc Compiler.
+
+(module ac mzscheme
+
+(provide (all-defined))
+(require (lib "port.ss"))
+(require (lib "process.ss"))
+(require (lib "pretty.ss"))
+(require (lib "foreign.ss"))
+(unsafe!)
+
+; compile an Arc expression into a Scheme expression,
+; both represented as s-expressions.
+; env is a list of lexically bound variables, which we
+; need in order to decide whether set should create a global.
+
+(define (ac s env)
+ (cond ((string? s) (ac-string s env))
+ ((literal? s) s)
+ ((eqv? s 'nil) (list 'quote 'nil))
+ ((ssyntax? s) (ac (expand-ssyntax s) env))
+ ((symbol? s) (ac-var-ref s env))
+ ((ssyntax? (xcar s)) (ac (cons (expand-ssyntax (car s)) (cdr s)) env))
+ ((eq? (xcar s) 'quote) (list 'quote (ac-niltree (cadr s))))
+ ((eq? (xcar s) 'quasiquote) (ac-qq (cadr s) env))
+ ((eq? (xcar s) 'if) (ac-if (cdr s) env))
+ ((eq? (xcar s) 'fn) (ac-fn (cadr s) (cddr s) env))
+ ((eq? (xcar s) 'assign) (ac-set (cdr s) env))
+ ; the next three clauses could be removed without changing semantics
+ ; ... except that they work for macros (so prob should do this for
+ ; every elt of s, not just the car)
+ ((eq? (xcar (xcar s)) 'compose) (ac (decompose (cdar s) (cdr s)) env))
+ ((eq? (xcar (xcar s)) 'complement)
+ (ac (list 'no (cons (cadar s) (cdr s))) env))
+ ((eq? (xcar (xcar s)) 'andf) (ac-andf s env))
+ ((pair? s) (ac-call (car s) (cdr s) env))
+ (#t (err "Bad object in expression" s))))
+
+(define atstrings #f)
+
+(define (ac-string s env)
+ (if atstrings
+ (if (atpos s 0)
+ (ac (cons 'string (map (lambda (x)
+ (if (string? x)
+ (unescape-ats x)
+ x))
+ (codestring s)))
+ env)
+ (unescape-ats s))
+ (string-copy s))) ; avoid immutable strings
+
+(define (literal? x)
+ (or (boolean? x)
+ (char? x)
+ (string? x)
+ (number? x)
+ (eq? x '())))
+
+(define (ssyntax? x)
+ (and (symbol? x)
+ (not (or (eqv? x '+) (eqv? x '++) (eqv? x '_)))
+ (let ((name (symbol->string x)))
+ (has-ssyntax-char? name (- (string-length name) 1)))))
+
+(define (has-ssyntax-char? string i)
+ (and (>= i 0)
+ (or (let ((c (string-ref string i)))
+ (or (eqv? c #\:) (eqv? c #\~)
+ (eqv? c #\&)
+ ;(eqv? c #\_)
+ (eqv? c #\.) (eqv? c #\!)))
+ (has-ssyntax-char? string (- i 1)))))
+
+(define (read-from-string str)
+ (let ((port (open-input-string str)))
+ (let ((val (read port)))
+ (close-input-port port)
+ val)))
+
+; Though graphically the right choice, can't use _ for currying
+; because then _!foo becomes a function. Maybe use <>. For now
+; leave this off and see how often it would have been useful.
+
+; Might want to make ~ have less precedence than &, because
+; ~foo&bar prob should mean (andf (complement foo) bar), not
+; (complement (andf foo bar)).
+
+(define (expand-ssyntax sym)
+ ((cond ((or (insym? #\: sym) (insym? #\~ sym)) expand-compose)
+ ((or (insym? #\. sym) (insym? #\! sym)) expand-sexpr)
+ ((insym? #\& sym) expand-and)
+ ; ((insym? #\_ sym) expand-curry)
+ (#t (error "Unknown ssyntax" sym)))
+ sym))
+
+(define (expand-compose sym)
+ (let ((elts (map (lambda (tok)
+ (if (eqv? (car tok) #\~)
+ (if (null? (cdr tok))
+ 'no
+ `(complement ,(chars->value (cdr tok))))
+ (chars->value tok)))
+ (tokens (lambda (c) (eqv? c #\:))
+ (symbol->chars sym)
+ '()
+ '()
+ #f))))
+ (if (null? (cdr elts))
+ (car elts)
+ (cons 'compose elts))))
+
+(define (expand-and sym)
+ (let ((elts (map chars->value
+ (tokens (lambda (c) (eqv? c #\&))
+ (symbol->chars sym)
+ '()
+ '()
+ #f))))
+ (if (null? (cdr elts))
+ (car elts)
+ (cons 'andf elts))))
+
+; How to include quoted arguments? Can't treat all as quoted, because
+; never want to quote fn given as first. Do we want to allow quote chars
+; within symbols? Could be ugly.
+
+; If release, fix the fact that this simply uses v0... as vars. Should
+; make these vars gensyms.
+
+(define (expand-curry sym)
+ (let ((expr (exc (map (lambda (x)
+ (if (pair? x) (chars->value x) x))
+ (tokens (lambda (c) (eqv? c #\_))
+ (symbol->chars sym)
+ '()
+ '()
+ #t))
+ 0)))
+ (list 'fn
+ (keep (lambda (s)
+ (and (symbol? s)
+ (eqv? (string-ref (symbol->string s) 0)
+ #\v)))
+ expr)
+ expr)))
+
+(define (keep f xs)
+ (cond ((null? xs) '())
+ ((f (car xs)) (cons (car xs) (keep f (cdr xs))))
+ (#t (keep f (cdr xs)))))
+
+(define (exc elts n)
+ (cond ((null? elts)
+ '())
+ ((eqv? (car elts) #\_)
+ (cons (string->symbol (string-append "v" (number->string n)))
+ (exc (cdr elts) (+ n 1))))
+ (#t
+ (cons (car elts) (exc (cdr elts) n)))))
+
+(define (expand-sexpr sym)
+ (build-sexpr (reverse (tokens (lambda (c) (or (eqv? c #\.) (eqv? c #\!)))
+ (symbol->chars sym)
+ '()
+ '()
+ #t))
+ sym))
+
+(define (build-sexpr toks orig)
+ (cond ((null? toks)
+ 'get)
+ ((null? (cdr toks))
+ (chars->value (car toks)))
+ (#t
+ (list (build-sexpr (cddr toks) orig)
+ (if (eqv? (cadr toks) #\!)
+ (list 'quote (chars->value (car toks)))
+ (if (or (eqv? (car toks) #\.) (eqv? (car toks) #\!))
+ (err "Bad ssyntax" orig)
+ (chars->value (car toks))))))))
+
+(define (insym? char sym) (member char (symbol->chars sym)))
+
+(define (symbol->chars x) (string->list (symbol->string x)))
+
+(define (chars->value chars) (read-from-string (list->string chars)))
+
+(define (tokens test source token acc keepsep?)
+ (cond ((null? source)
+ (reverse (if (pair? token)
+ (cons (reverse token) acc)
+ acc)))
+ ((test (car source))
+ (tokens test
+ (cdr source)
+ '()
+ (let ((rec (if (null? token)
+ acc
+ (cons (reverse token) acc))))
+ (if keepsep?
+ (cons (car source) rec)
+ rec))
+ keepsep?))
+ (#t
+ (tokens test
+ (cdr source)
+ (cons (car source) token)
+ acc
+ keepsep?))))
+
+(define (ac-global-name s)
+ (string->symbol (string-append "_" (symbol->string s))))
+
+(define (ac-var-ref s env)
+ (if (lex? s env)
+ s
+ (ac-global-name s)))
+
+; quasiquote
+
+(define (ac-qq args env)
+ (list 'quasiquote (ac-qq1 1 args env)))
+
+; process the argument of a quasiquote. keep track of
+; depth of nesting. handle unquote only at top level (level = 1).
+; complete form, e.g. x or (fn x) or (unquote (fn x))
+
+(define (ac-qq1 level x env)
+ (cond ((= level 0)
+ (ac x env))
+ ((and (pair? x) (eqv? (car x) 'unquote))
+ (list 'unquote (ac-qq1 (- level 1) (cadr x) env)))
+ ((and (pair? x) (eqv? (car x) 'unquote-splicing) (= level 1))
+ (list 'unquote-splicing
+ (list 'ar-nil-terminate (ac-qq1 (- level 1) (cadr x) env))))
+ ((and (pair? x) (eqv? (car x) 'quasiquote))
+ (list 'quasiquote (ac-qq1 (+ level 1) (cadr x) env)))
+ ((pair? x)
+ (imap (lambda (x) (ac-qq1 level x env)) x))
+ (#t x)))
+
+; like map, but don't demand '()-terminated list
+
+(define (imap f l)
+ (cond ((pair? l)
+ (cons (f (car l)) (imap f (cdr l))))
+ ((null? l)
+ '())
+ (#t (f l))))
+
+; (if) -> nil
+; (if x) -> x
+; (if t a ...) -> a
+; (if nil a b) -> b
+; (if nil a b c) -> (if b c)
+
+(define (ac-if args env)
+ (cond ((null? args) ''nil)
+ ((null? (cdr args)) (ac (car args) env))
+ (#t `(if (not (ar-false? ,(ac (car args) env)))
+ ,(ac (cadr args) env)
+ ,(ac-if (cddr args) env)))))
+
+(define (ac-dbname! name env)
+ (if (symbol? name)
+ (cons (list name) env)
+ env))
+
+(define (ac-dbname env)
+ (cond ((null? env) #f)
+ ((pair? (car env)) (caar env))
+ (#t (ac-dbname (cdr env)))))
+
+; translate fn directly into a lambda if it has ordinary
+; parameters, otherwise use a rest parameter and parse it.
+
+(define (ac-fn args body env)
+ (if (ac-complex-args? args)
+ (ac-complex-fn args body env)
+ (ac-nameit
+ (ac-dbname env)
+ `(lambda ,(let ((a (ac-denil args))) (if (eqv? a 'nil) '() a))
+ ,@(ac-body* body (append (ac-arglist args) env))))))
+
+; does an fn arg list use optional parameters or destructuring?
+; a rest parameter is not complex
+
+(define (ac-complex-args? args)
+ (cond ((eqv? args '()) #f)
+ ((symbol? args) #f)
+ ((and (pair? args) (symbol? (car args)))
+ (ac-complex-args? (cdr args)))
+ (#t #t)))
+
+; translate a fn with optional or destructuring args
+; (fn (x (o y x) (o z 21) (x1 x2) . rest) ...)
+; arguments in top-level list are mandatory (unless optional),
+; but it's OK for parts of a list you're destructuring to
+; be missing.
+
+(define (ac-complex-fn args body env)
+ (let* ((ra (ar-gensym))
+ (z (ac-complex-args args env ra #t)))
+ `(lambda ,ra
+ (let* ,z
+ ,@(ac-body* body (append (ac-complex-getargs z) env))))))
+
+; returns a list of two-element lists, first is variable name,
+; second is (compiled) expression. to be used in a let.
+; caller should extract variables and add to env.
+; ra is the rest argument to the fn.
+; is-params indicates that args are function arguments
+; (not destructuring), so they must be passed or be optional.
+
+(define (ac-complex-args args env ra is-params)
+ (cond ((or (eqv? args '()) (eqv? args 'nil)) '())
+ ((symbol? args) (list (list args ra)))
+ ((pair? args)
+ (let* ((x (if (and (pair? (car args)) (eqv? (caar args) 'o))
+ (ac-complex-opt (cadar args)
+ (if (pair? (cddar args))
+ (caddar args)
+ 'nil)
+ env
+ ra)
+ (ac-complex-args
+ (car args)
+ env
+ (if is-params
+ `(car ,ra)
+ `(ar-xcar ,ra))
+ #f)))
+ (xa (ac-complex-getargs x)))
+ (append x (ac-complex-args (cdr args)
+ (append xa env)
+ `(ar-xcdr ,ra)
+ is-params))))
+ (#t (err "Can't understand fn arg list" args))))
+
+; (car ra) is the argument
+; so it's not present if ra is nil or '()
+
+(define (ac-complex-opt var expr env ra)
+ (list (list var `(if (pair? ,ra) (car ,ra) ,(ac expr env)))))
+
+; extract list of variables from list of two-element lists.
+
+(define (ac-complex-getargs a)
+ (map (lambda (x) (car x)) a))
+
+; (a b . c) -> (a b c)
+; a -> (a)
+
+(define (ac-arglist a)
+ (cond ((null? a) '())
+ ((symbol? a) (list a))
+ ((symbol? (cdr a)) (list (car a) (cdr a)))
+ (#t (cons (car a) (ac-arglist (cdr a))))))
+
+(define (ac-body body env)
+ (map (lambda (x) (ac x env)) body))
+
+; like ac-body, but spits out a nil expression if empty
+
+(define (ac-body* body env)
+ (if (null? body)
+ (list (list 'quote 'nil))
+ (ac-body body env)))
+
+; (set v1 expr1 v2 expr2 ...)
+
+(define (ac-set x env)
+ `(begin ,@(ac-setn x env)))
+
+(define (ac-setn x env)
+ (if (null? x)
+ '()
+ (cons (ac-set1 (ac-macex (car x)) (cadr x) env)
+ (ac-setn (cddr x) env))))
+
+; trick to tell Scheme the name of something, so Scheme
+; debugging and profiling make more sense.
+
+(define (ac-nameit name v)
+ (if (symbol? name)
+ (let ((n (string->symbol (string-append " " (symbol->string name)))))
+ (list 'let `((,n ,v)) n))
+ v))
+
+; = replaced by set, which is only for vars
+; = now defined in arc (is it?)
+; name is to cause fns to have their arc names for debugging
+
+(define (ac-set1 a b1 env)
+ (if (symbol? a)
+ (let ((b (ac b1 (ac-dbname! a env))))
+ (list 'let `((zz ,b))
+ (cond ((eqv? a 'nil) (err "Can't rebind nil"))
+ ((eqv? a 't) (err "Can't rebind t"))
+ ((lex? a env) `(set! ,a zz))
+ (#t `(namespace-set-variable-value! ',(ac-global-name a)
+ zz)))
+ 'zz))
+ (err "First arg to set must be a symbol" a)))
+
+; given a list of Arc expressions, return a list of Scheme expressions.
+; for compiling passed arguments.
+
+(define (ac-args names exprs env)
+ (if (null? exprs)
+ '()
+ (cons (ac (car exprs)
+ (ac-dbname! (if (pair? names) (car names) #f) env))
+ (ac-args (if (pair? names) (cdr names) '())
+ (cdr exprs)
+ env))))
+
+; generate special fast code for ordinary two-operand
+; calls to the following functions. this is to avoid
+; calling e.g. ar-is with its &rest and apply.
+
+(define ac-binaries
+ '((is ar-is2)
+ (< ar-<2)
+ (> ar->2)
+ (+ ar-+2)))
+
+; (foo bar) where foo is a global variable bound to a procedure.
+
+(define (ac-global-call fn args env)
+ (cond ((and (assoc fn ac-binaries) (= (length args) 2))
+ `(,(cadr (assoc fn ac-binaries)) ,@(ac-args '() args env)))
+ (#t
+ `(,(ac-global-name fn) ,@(ac-args '() args env)))))
+
+; compile a function call
+; special cases for speed, to avoid compiled output like
+; (ar-apply _pr (list 1 2))
+; which results in 1/2 the CPU time going to GC. Instead:
+; (ar-funcall2 _pr 1 2)
+; and for (foo bar), if foo is a reference to a global variable,
+; and it's bound to a function, generate (foo bar) instead of
+; (ar-funcall1 foo bar)
+
+(define direct-calls #f)
+
+(define (ac-call fn args env)
+ (let ((macfn (ac-macro? fn)))
+ (cond (macfn
+ (ac-mac-call macfn args env))
+ ((and (pair? fn) (eqv? (car fn) 'fn))
+ `(,(ac fn env) ,@(ac-args (cadr fn) args env)))
+ ((and direct-calls (symbol? fn) (not (lex? fn env)) (bound? fn)
+ (procedure? (namespace-variable-value (ac-global-name fn))))
+ (ac-global-call fn args env))
+ ((= (length args) 0)
+ `(ar-funcall0 ,(ac fn env) ,@(map (lambda (x) (ac x env)) args)))
+ ((= (length args) 1)
+ `(ar-funcall1 ,(ac fn env) ,@(map (lambda (x) (ac x env)) args)))
+ ((= (length args) 2)
+ `(ar-funcall2 ,(ac fn env) ,@(map (lambda (x) (ac x env)) args)))
+ ((= (length args) 3)
+ `(ar-funcall3 ,(ac fn env) ,@(map (lambda (x) (ac x env)) args)))
+ ((= (length args) 4)
+ `(ar-funcall4 ,(ac fn env) ,@(map (lambda (x) (ac x env)) args)))
+ (#t
+ `(ar-apply ,(ac fn env)
+ (list ,@(map (lambda (x) (ac x env)) args)))))))
+
+(define (ac-mac-call m args env)
+ (let ((x1 (apply m (map ac-niltree args))))
+ (let ((x2 (ac (ac-denil x1) env)))
+ x2)))
+
+; returns #f or the macro function
+
+(define (ac-macro? fn)
+ (if (symbol? fn)
+ (let ((v (namespace-variable-value (ac-global-name fn)
+ #t
+ (lambda () #f))))
+ (if (and v
+ (ar-tagged? v)
+ (eq? (ar-type v) 'mac))
+ (ar-rep v)
+ #f))
+ #f))
+
+; macroexpand the outer call of a form as much as possible
+
+(define (ac-macex e . once)
+ (if (pair? e)
+ (let ((m (ac-macro? (car e))))
+ (if m
+ (let ((expansion (ac-denil (apply m (map ac-niltree (cdr e))))))
+ (if (null? once) (ac-macex expansion) expansion))
+ e))
+ e))
+
+; macros return Arc lists, ending with NIL.
+; but the Arc compiler expects Scheme lists, ending with '().
+; what to do with (is x nil . nil) ?
+; the first nil ought to be replaced with 'NIL
+; the second with '()
+; so the rule is: NIL in the car -> 'NIL, NIL in the cdr -> '().
+; NIL by itself -> NIL
+
+(define (ac-denil x)
+ (cond ((pair? x) (cons (ac-denil-car (car x)) (ac-denil-cdr (cdr x))))
+ (#t x)))
+
+(define (ac-denil-car x)
+ (if (eq? x 'nil)
+ 'nil
+ (ac-denil x)))
+
+(define (ac-denil-cdr x)
+ (if (eq? x 'nil)
+ '()
+ (ac-denil x)))
+
+; is v lexically bound?
+
+(define (lex? v env)
+ (memq v env))
+
+(define (xcar x)
+ (and (pair? x) (car x)))
+
+; #f and '() -> nil for a whole quoted list/tree.
+
+; Arc primitives written in Scheme should look like:
+
+; (xdef foo (lambda (lst)
+; (ac-niltree (scheme-foo (ar-nil-terminate lst)))))
+
+; That is, Arc lists are NIL-terminated. When calling a Scheme
+; function that treats an argument as a list, call ar-nil-terminate
+; to change NIL to '(). When returning any data created by Scheme
+; to Arc, call ac-niltree to turn all '() into NIL.
+; (hash-table-get doesn't use its argument as a list, so it doesn't
+; need ar-nil-terminate).
+
+(define (ac-niltree x)
+ (cond ((pair? x) (cons (ac-niltree (car x)) (ac-niltree (cdr x))))
+ ((or (eq? x #f) (eq? x '())) 'nil)
+ (#t x)))
+
+; The next two are optimizations, except work for macros.
+
+(define (decompose fns args)
+ (cond ((null? fns) `((fn vals (car vals)) ,@args))
+ ((null? (cdr fns)) (cons (car fns) args))
+ (#t (list (car fns) (decompose (cdr fns) args)))))
+
+(define (ac-andf s env)
+ (ac (let ((gs (map (lambda (x) (ar-gensym)) (cdr s))))
+ `((fn ,gs
+ (and ,@(map (lambda (f) `(,f ,@gs))
+ (cdar s))))
+ ,@(cdr s)))
+ env))
+
+(define err error)
+
+; run-time primitive procedures
+
+;(define (xdef a b)
+; (namespace-set-variable-value! (ac-global-name a) b)
+; b)
+
+(define-syntax xdef
+ (syntax-rules ()
+ ((xxdef a b)
+ (let ((nm (ac-global-name 'a))
+ (a b))
+ (namespace-set-variable-value! nm a)
+ a))))
+
+(define fn-signatures (make-hash-table 'equal))
+
+; This is a replacement for xdef that stores opeator signatures.
+; Haven't started using it yet.
+
+(define (odef a parms b)
+ (namespace-set-variable-value! (ac-global-name a) b)
+ (hash-table-put! fn-signatures a (list parms))
+ b)
+
+(xdef sig fn-signatures)
+
+; versions of car and cdr for parsing arguments for optional
+; parameters, that yield nil for nil. maybe we should use
+; full Arc car and cdr, so we can destructure more things
+
+(define (ar-xcar x)
+ (if (or (eqv? x 'nil) (eqv? x '()))
+ 'nil
+ (car x)))
+
+(define (ar-xcdr x)
+ (if (or (eqv? x 'nil) (eqv? x '()))
+ 'nil
+ (cdr x)))
+
+; convert #f from a Scheme predicate to NIL.
+
+(define (ar-nill x)
+ (if (or (eq? x '()) (eq? x #f))
+ 'nil
+ x))
+
+; definition of falseness for Arc if.
+; must include '() since sometimes Arc functions see
+; Scheme lists (e.g. . body of a macro).
+
+(define (ar-false? x)
+ (or (eq? x 'nil) (eq? x '()) (eq? x #f)))
+
+; call a function or perform an array ref, hash ref, &c
+
+; Non-fn constants in functional position are valuable real estate, so
+; should figure out the best way to exploit it. What could (1 foo) or
+; ('a foo) mean? Maybe it should mean currying.
+
+; For now the way to make the default val of a hash table be other than
+; nil is to supply the val when doing the lookup. Later may also let
+; defaults be supplied as an arg to table. To implement this, need: an
+; eq table within scheme mapping tables to defaults, and to adapt the
+; code in arc.arc that reads and writes tables to read and write their
+; default vals with them. To make compatible with existing written tables,
+; just use an atom or 3-elt list to keep the default.
+
+(define (ar-apply fn args)
+ (cond ((procedure? fn)
+ (apply fn args))
+ ((pair? fn)
+ (list-ref fn (car args)))
+ ((string? fn)
+ (string-ref fn (car args)))
+ ((hash-table? fn)
+ (ar-nill (hash-table-get fn
+ (car args)
+ (if (pair? (cdr args)) (cadr args) #f))))
+; experiment: means e.g. [1] is a constant fn
+; ((or (number? fn) (symbol? fn)) fn)
+; another possibility: constant in functional pos means it gets
+; passed to the first arg, i.e. ('kids item) means (item 'kids).
+ (#t (err "Function call on inappropriate object" fn args))))
+
+(xdef apply (lambda (fn . args)
+ (ar-apply fn (ar-apply-args args))))
+
+; special cases of ar-apply for speed and to avoid consing arg lists
+
+(define (ar-funcall0 fn)
+ (if (procedure? fn)
+ (fn)
+ (ar-apply fn (list))))
+
+(define (ar-funcall1 fn arg1)
+ (if (procedure? fn)
+ (fn arg1)
+ (ar-apply fn (list arg1))))
+
+(define (ar-funcall2 fn arg1 arg2)
+ (if (procedure? fn)
+ (fn arg1 arg2)
+ (ar-apply fn (list arg1 arg2))))
+
+(define (ar-funcall3 fn arg1 arg2 arg3)
+ (if (procedure? fn)
+ (fn arg1 arg2 arg3)
+ (ar-apply fn (list arg1 arg2 arg3))))
+
+(define (ar-funcall4 fn arg1 arg2 arg3 arg4)
+ (if (procedure? fn)
+ (fn arg1 arg2 arg3 arg4)
+ (ar-apply fn (list arg1 arg2 arg3 arg4))))
+
+; replace the nil at the end of a list with a '()
+
+(define (ar-nil-terminate l)
+ (if (or (eqv? l '()) (eqv? l 'nil))
+ '()
+ (cons (car l) (ar-nil-terminate (cdr l)))))
+
+; turn the arguments to Arc apply into a list.
+; if you call (apply fn 1 2 '(3 4))
+; then args is '(1 2 (3 4 . nil) . ())
+; that is, the main list is a scheme list.
+; and we should return '(1 2 3 4 . ())
+; was once (apply apply list (ac-denil args))
+; but that didn't work for (apply fn nil)
+
+(define (ar-apply-args args)
+ (cond ((null? args) '())
+ ((null? (cdr args)) (ar-nil-terminate (car args)))
+ (#t (cons (car args) (ar-apply-args (cdr args))))))
+
+
+
+
+
+(xdef cons cons)
+
+(xdef car (lambda (x)
+ (cond ((pair? x) (car x))
+ ((eqv? x 'nil) 'nil)
+ ((eqv? x '()) 'nil)
+ (#t (err "Can't take car of" x)))))
+
+(xdef cdr (lambda (x)
+ (cond ((pair? x) (cdr x))
+ ((eqv? x 'nil) 'nil)
+ ((eqv? x '()) 'nil)
+ (#t (err "Can't take cdr of" x)))))
+
+(define (tnil x) (if x 't 'nil))
+
+; (pairwise pred '(a b c d)) =>
+; (and (pred a b) (pred b c) (pred c d))
+; pred returns t/nil, as does pairwise
+; reduce?
+
+(define (pairwise pred lst)
+ (cond ((null? lst) 't)
+ ((null? (cdr lst)) 't)
+ ((not (eqv? (pred (car lst) (cadr lst)) 'nil))
+ (pairwise pred (cdr lst)))
+ (#t 'nil)))
+
+; not quite right, because behavior of underlying eqv unspecified
+; in many cases according to r5rs
+; do we really want is to ret t for distinct strings?
+
+; for (is x y)
+
+(define (ar-is2 a b)
+ (tnil (or (eqv? a b)
+ (and (string? a) (string? b) (string=? a b))
+ (and (ar-false? a) (ar-false? b)))))
+
+; for all other uses of is
+
+(xdef is (lambda args (pairwise ar-is2 args)))
+
+(xdef err err)
+(xdef nil 'nil)
+(xdef t 't)
+
+(define (all test seq)
+ (or (null? seq)
+ (and (test (car seq)) (all test (cdr seq)))))
+
+(define (arc-list? x) (or (pair? x) (eqv? x 'nil) (eqv? x '())))
+
+; Generic +: strings, lists, numbers.
+; Return val has same type as first argument.
+
+(xdef + (lambda args
+ (cond ((null? args) 0)
+ ((char-or-string? (car args))
+ (apply string-append
+ (map (lambda (a) (ar-coerce a 'string))
+ args)))
+ ((arc-list? (car args))
+ (ac-niltree (apply append (map ar-nil-terminate args))))
+ (#t (apply + args)))))
+
+(define (char-or-string? x) (or (string? x) (char? x)))
+
+(define (ar-+2 x y)
+ (cond ((char-or-string? x)
+ (string-append (ar-coerce x 'string) (ar-coerce y 'string)))
+ ((and (arc-list? x) (arc-list? y))
+ (ac-niltree (append (ar-nil-terminate x) (ar-nil-terminate y))))
+ (#t (+ x y))))
+
+(xdef - -)
+(xdef * *)
+(xdef / /)
+(xdef mod modulo)
+(xdef expt expt)
+(xdef sqrt sqrt)
+
+; generic comparison
+
+(define (ar->2 x y)
+ (tnil (cond ((and (number? x) (number? y)) (> x y))
+ ((and (string? x) (string? y)) (string>? x y))
+ ((and (symbol? x) (symbol? y)) (string>? (symbol->string x)
+ (symbol->string y)))
+ ((and (char? x) (char? y)) (char>? x y))
+ (#t (> x y)))))
+
+(xdef > (lambda args (pairwise ar->2 args)))
+
+(define (ar-<2 x y)
+ (tnil (cond ((and (number? x) (number? y)) (< x y))
+ ((and (string? x) (string? y)) (string<? x y))
+ ((and (symbol? x) (symbol? y)) (string<? (symbol->string x)
+ (symbol->string y)))
+ ((and (char? x) (char? y)) (char<? x y))
+ (#t (< x y)))))
+
+(xdef < (lambda args (pairwise ar-<2 args)))
+
+(xdef len (lambda (x)
+ (cond ((string? x) (string-length x))
+ ((hash-table? x) (hash-table-count x))
+ (#t (length (ar-nil-terminate x))))))
+
+(define (ar-tagged? x)
+ (and (vector? x) (eq? (vector-ref x 0) 'tagged)))
+
+(define (ar-tag type rep)
+ (cond ((eqv? (ar-type rep) type) rep)
+ (#t (vector 'tagged type rep))))
+
+(xdef annotate ar-tag)
+
+; (type nil) -> sym
+
+(define (exint? x) (and (integer? x) (exact? x)))
+
+(define (ar-type x)
+ (cond ((ar-tagged? x) (vector-ref x 1))
+ ((pair? x) 'cons)
+ ((symbol? x) 'sym)
+ ((null? x) 'sym)
+ ((procedure? x) 'fn)
+ ((char? x) 'char)
+ ((string? x) 'string)
+ ((exint? x) 'int)
+ ((number? x) 'num) ; unsure about this
+ ((hash-table? x) 'table)
+ ((output-port? x) 'output)
+ ((input-port? x) 'input)
+ ((tcp-listener? x) 'socket)
+ ((exn? x) 'exception)
+ ((thread? x) 'thread)
+ (#t (err "Type: unknown type" x))))
+(xdef type ar-type)
+
+(define (ar-rep x)
+ (if (ar-tagged? x)
+ (vector-ref x 2)
+ x))
+
+(xdef rep ar-rep)
+
+; currently rather a joke: returns interned symbols
+
+(define ar-gensym-count 0)
+
+(define (ar-gensym)
+ (set! ar-gensym-count (+ ar-gensym-count 1))
+ (string->symbol (string-append "gs" (number->string ar-gensym-count))))
+
+(xdef uniq ar-gensym)
+
+(xdef ccc call-with-current-continuation)
+
+(xdef infile open-input-file)
+
+(xdef outfile (lambda (f . args)
+ (open-output-file f
+ 'text
+ (if (equal? args '(append))
+ 'append
+ 'truncate))))
+
+(xdef instring open-input-string)
+(xdef outstring open-output-string)
+
+; use as general fn for looking inside things
+
+(xdef inside get-output-string)
+
+(xdef stdout current-output-port) ; should be a vars
+(xdef stdin current-input-port)
+(xdef stderr current-error-port)
+
+(xdef call-w/stdout
+ (lambda (port thunk)
+ (parameterize ((current-output-port port)) (thunk))))
+
+(xdef call-w/stdin
+ (lambda (port thunk)
+ (parameterize ((current-input-port port)) (thunk))))
+
+(xdef readc (lambda str
+ (let ((c (read-char (if (pair? str)
+ (car str)
+ (current-input-port)))))
+ (if (eof-object? c) 'nil c))))
+
+
+(xdef readb (lambda str
+ (let ((c (read-byte (if (pair? str)
+ (car str)
+ (current-input-port)))))
+ (if (eof-object? c) 'nil c))))
+
+(xdef peekc (lambda str
+ (let ((c (peek-char (if (pair? str)
+ (car str)
+ (current-input-port)))))
+ (if (eof-object? c) 'nil c))))
+
+(xdef writec (lambda (c . args)
+ (write-char c
+ (if (pair? args)
+ (car args)
+ (current-output-port)))
+ c))
+
+(xdef writeb (lambda (b . args)
+ (write-byte b
+ (if (pair? args)
+ (car args)
+ (current-output-port)))
+ b))
+
+(define explicit-flush #f)
+
+(define (printwith f args)
+ (let ((port (if (> (length args) 1)
+ (cadr args)
+ (current-output-port))))
+ (when (pair? args)
+ (f (ac-denil (car args)) port))
+ (unless explicit-flush (flush-output port)))
+ 'nil)
+
+(xdef write (lambda args (printwith write args)))
+(xdef disp (lambda args (printwith display args)))
+
+; sread = scheme read. eventually replace by writing read
+
+(xdef sread (lambda (p eof)
+ (let ((expr (read p)))
+ (if (eof-object? expr) eof expr))))
+
+; these work in PLT but not scheme48
+
+(define char->ascii char->integer)
+(define ascii->char integer->char)
+
+(define (iround x) (inexact->exact (round x)))
+
+(define (ar-coerce x type . args)
+ (cond
+ ((ar-tagged? x) (err "Can't coerce annotated object"))
+ ((eqv? type (ar-type x)) x)
+ ((char? x) (case type
+ ((int) (char->ascii x))
+ ((string) (string x))
+ ((sym) (string->symbol (string x)))
+ (else (err "Can't coerce" x type))))
+ ((exint? x) (case type
+ ((num) x)
+ ((char) (ascii->char x))
+ ((string) (apply number->string x args))
+ (else (err "Can't coerce" x type))))
+ ((number? x) (case type
+ ((int) (iround x))
+ ((char) (ascii->char (iround x)))
+ ((string) (apply number->string x args))
+ (else (err "Can't coerce" x type))))
+ ((string? x) (case type
+ ((sym) (string->symbol x))
+ ((cons) (ac-niltree (string->list x)))
+ ((num) (or (apply string->number x args)
+ (err "Can't coerce" x type)))
+ ((int) (let ((n (apply string->number x args)))
+ (if n
+ (iround n)
+ (err "Can't coerce" x type))))
+ (else (err "Can't coerce" x type))))
+ ((pair? x) (case type
+ ((string) (apply string-append
+ (map (lambda (y) (ar-coerce y 'string))
+ (ar-nil-terminate x))))
+ (else (err "Can't coerce" x type))))
+ ((eqv? x 'nil) (case type
+ ((string) "")
+ (else (err "Can't coerce" x type))))
+ ((null? x) (case type
+ ((string) "")
+ (else (err "Can't coerce" x type))))
+ ((symbol? x) (case type
+ ((string) (symbol->string x))
+ (else (err "Can't coerce" x type))))
+ (#t x)))
+
+(xdef coerce ar-coerce)
+
+(xdef open-socket (lambda (num) (tcp-listen num 50 #t)))
+
+; the 2050 means http requests currently capped at 2 meg
+; http://list.cs.brown.edu/pipermail/plt-scheme/2005-August/009414.html
+
+(xdef socket-accept (lambda (s)
+ (let ((oc (current-custodian))
+ (nc (make-custodian)))
+ (current-custodian nc)
+ (call-with-values
+ (lambda () (tcp-accept s))
+ (lambda (in out)
+ (let ((in1 (make-limited-input-port in 100000 #t)))
+ (current-custodian oc)
+ (associate-custodian nc in1 out)
+ (list in1
+ out
+ (let-values (((us them) (tcp-addresses out)))
+ them))))))))
+
+; allow Arc to give up root privileges after it
+; calls open-socket. thanks, Eli!
+(define setuid (get-ffi-obj 'setuid #f (_fun _int -> _int)))
+(xdef setuid setuid)
+
+(xdef new-thread thread)
+(xdef kill-thread kill-thread)
+(xdef break-thread break-thread)
+(xdef current-thread current-thread)
+
+(define (wrapnil f) (lambda args (apply f args) 'nil))
+
+(xdef sleep (wrapnil sleep))
+
+; Will system "execute" a half-finished string if thread killed
+; in the middle of generating it?
+
+(xdef system (wrapnil system))
+
+(xdef pipe-from (lambda (cmd)
+ (let ((tf (ar-tmpname)))
+ (system (string-append cmd " > " tf))
+ (let ((str (open-input-file tf)))
+ (system (string-append "rm -f " tf))
+ str))))
+
+(define (ar-tmpname)
+ (call-with-input-file "/dev/urandom"
+ (lambda (rstr)
+ (do ((s "/tmp/")
+ (c (read-char rstr) (read-char rstr))
+ (i 0 (+ i 1)))
+ ((>= i 16) s)
+ (set! s (string-append s
+ (string
+ (integer->char
+ (+ (char->integer #\a)
+ (modulo
+ (char->integer (read-char rstr))
+ 26))))))))))
+
+; PLT scheme provides only eq? and equal? hash tables,
+; we need the latter for strings.
+
+(xdef table (lambda args
+ (let ((h (make-hash-table 'equal)))
+ (if (pair? args) ((car args) h))
+ h)))
+
+;(xdef table (lambda args
+; (fill-table (make-hash-table 'equal)
+; (if (pair? args) (ac-denil (car args)) '()))))
+
+(define (fill-table h pairs)
+ (if (eq? pairs '())
+ h
+ (let ((pair (car pairs)))
+ (begin (hash-table-put! h (car pair) (cadr pair))
+ (fill-table h (cdr pairs))))))
+
+(xdef maptable (lambda (fn table) ; arg is (fn (key value) ...)
+ (hash-table-for-each table fn)
+ table))
+
+(define (protect during after)
+ (dynamic-wind (lambda () #t) during after))
+
+(xdef protect protect)
+
+; need to use a better seed
+
+(xdef rand random)
+
+(xdef dir (lambda (name)
+ (ac-niltree (map path->string (directory-list name)))))
+
+; Would def mkdir in terms of make-directory and call that instead
+; of system in ensure-dir, but make-directory is too weak: it doesn't
+; create intermediate directories like mkdir -p.
+
+(xdef file-exists (lambda (name)
+ (if (file-exists? name) name 'nil)))
+
+(xdef dir-exists (lambda (name)
+ (if (directory-exists? name) name 'nil)))
+
+(xdef rmfile (wrapnil delete-file))
+
+(xdef mvfile (lambda (old new)
+ (rename-file-or-directory old new #t)
+ 'nil))
+
+; top level read-eval-print
+; tle kept as a way to get a break loop when a scheme err
+
+(define (arc-eval expr)
+ (eval (ac expr '())))
+
+(define (tle)
+ (display "Arc> ")
+ (let ((expr (read)))
+ (when (not (eqv? expr ':a))
+ (write (arc-eval expr))
+ (newline)
+ (tle))))
+
+(define last-condition* #f)
+
+(define (tl)
+ (display "Use (quit) to quit, (tl) to return here after an interrupt.\n")
+ (tl2))
+
+(define (tl2)
+ (display "arc> ")
+ (on-err (lambda (c)
+ (set! last-condition* c)
+ (display "Error: ")
+ (write (exn-message c))
+ (newline)
+ (tl2))
+ (lambda ()
+ (let ((expr (read)))
+ (if (eqv? expr ':a)
+ 'done
+ (let ((val (arc-eval expr)))
+ (write (ac-denil val))
+ (namespace-set-variable-value! '_that val)
+ (namespace-set-variable-value! '_thatexpr expr)
+ (newline)
+ (tl2)))))))
+
+(define (aload1 p)
+ (let ((x (read p)))
+ (if (eof-object? x)
+ #t
+ (begin
+ (arc-eval x)
+ (aload1 p)))))
+
+(define (atests1 p)
+ (let ((x (read p)))
+ (if (eof-object? x)
+ #t
+ (begin
+ (write x)
+ (newline)
+ (let ((v (arc-eval x)))
+ (if (ar-false? v)
+ (begin
+ (display " FAILED")
+ (newline))))
+ (atests1 p)))))
+
+(define (aload filename)
+ (call-with-input-file filename aload1))
+
+(define (test filename)
+ (call-with-input-file filename atests1))
+
+(define (acompile1 ip op)
+ (let ((x (read ip)))
+ (if (eof-object? x)
+ #t
+ (let ((scm (ac x '())))
+ (eval scm)
+ (pretty-print scm op)
+ (newline op)
+ (newline op)
+ (acompile1 ip op)))))
+
+; compile xx.arc to xx.arc.scm
+; useful to examine the Arc compiler output
+(define (acompile inname)
+ (let ((outname (string-append inname ".scm")))
+ (if (file-exists? outname)
+ (delete-file outname))
+ (call-with-input-file inname
+ (lambda (ip)
+ (call-with-output-file outname
+ (lambda (op)
+ (acompile1 ip op)))))))
+
+(xdef macex (lambda (e) (ac-macex (ac-denil e))))
+
+(xdef macex1 (lambda (e) (ac-macex (ac-denil e) 'once)))
+
+(xdef eval (lambda (e)
+ (eval (ac (ac-denil e) '()))))
+
+; If an err occurs in an on-err expr, no val is returned and code
+; after it doesn't get executed. Not quite what I had in mind.
+
+(define (on-err errfn f)
+ ((call-with-current-continuation
+ (lambda (k)
+ (lambda ()
+ (with-handlers ((exn:fail? (lambda (c)
+ (k (lambda () (errfn c))))))
+ (f)))))))
+(xdef on-err on-err)
+
+(define (disp-to-string x)
+ (let ((o (open-output-string)))
+ (display x o)
+ (close-output-port o)
+ (get-output-string o)))
+
+(xdef details (lambda (c)
+ (disp-to-string (exn-message c))))
+
+(xdef scar (lambda (x val)
+ (if (string? x)
+ (string-set! x 0 val)
+ (x-set-car! x val))
+ val))
+
+(xdef scdr (lambda (x val)
+ (if (string? x)
+ (err "Can't set cdr of a string" x)
+ (x-set-cdr! x val))
+ val))
+
+; decide at run-time whether the underlying mzscheme supports
+; set-car! and set-cdr!, since I can't figure out how to do it
+; at compile time.
+
+(define (x-set-car! p v)
+ (let ((fn (namespace-variable-value 'set-car! #t (lambda () #f))))
+ (if (procedure? fn)
+ (fn p v)
+ (n-set-car! p v))))
+
+(define (x-set-cdr! p v)
+ (let ((fn (namespace-variable-value 'set-cdr! #t (lambda () #f))))
+ (if (procedure? fn)
+ (fn p v)
+ (n-set-cdr! p v))))
+
+; Eli's code to modify mzscheme-4's immutable pairs.
+
+;; to avoid a malloc on every call, reuse a single pointer, but make
+;; it thread-local to avoid races
+(define ptr (make-thread-cell #f))
+(define (get-ptr)
+ (or (thread-cell-ref ptr)
+ (let ([p (malloc _scheme 1)]) (thread-cell-set! ptr p) p)))
+
+;; set a pointer to the cons cell, then dereference it as a pointer,
+;; and bang the new value in the given offset
+(define (set-ca/dr! offset who p x)
+ (if (pair? p)
+ (let ([p* (get-ptr)])
+ (ptr-set! p* _scheme p)
+ (ptr-set! (ptr-ref p* _pointer 0) _scheme offset x))
+ (raise-type-error who "pair" p)))
+
+(define (n-set-car! p x) (set-ca/dr! 1 'set-car! p x))
+(define (n-set-cdr! p x) (set-ca/dr! 2 'set-cdr! p x))
+
+; When and if cdr of a string returned an actual (eq) tail, could
+; say (if (string? x) (string-replace! x val 1) ...) in scdr, but
+; for now would be misleading to allow this, because fails for cddr.
+
+(define (string-replace! str val index)
+ (if (eqv? (string-length val) (- (string-length str) index))
+ (do ((i index (+ i 1)))
+ ((= i (string-length str)) str)
+ (string-set! str i (string-ref val (- i index))))
+ (err "Length mismatch between strings" str val index)))
+
+; Later may want to have multiple indices.
+
+(xdef sref
+ (lambda (com val ind)
+ (cond ((hash-table? com) (if (eqv? val 'nil)
+ (hash-table-remove! com ind)
+ (hash-table-put! com ind val)))
+ ((string? com) (string-set! com ind val))
+ ((pair? com) (nth-set! com ind val))
+ (#t (err "Can't set reference " com ind val)))
+ val))
+
+(define (nth-set! lst n val)
+ (x-set-car! (list-tail lst n) val))
+
+; rewrite to pass a (true) gensym instead of #f in case var bound to #f
+
+(define (bound? arcname)
+ (namespace-variable-value (ac-global-name arcname)
+ #t
+ (lambda () #f)))
+
+(xdef bound (lambda (x) (tnil (bound? x))))
+
+(xdef newstring make-string)
+
+(xdef trunc (lambda (x) (inexact->exact (truncate x))))
+
+; bad name
+
+(xdef exact (lambda (x) (tnil (exint? x))))
+
+(xdef msec current-milliseconds)
+(xdef current-process-milliseconds current-process-milliseconds)
+(xdef current-gc-milliseconds current-gc-milliseconds)
+
+(xdef seconds current-seconds)
+
+(print-hash-table #t)
+
+(xdef client-ip (lambda (port)
+ (let-values (((x y) (tcp-addresses port)))
+ y)))
+
+; make sure only one thread at a time executes anything
+; inside an atomic-invoke. atomic-invoke is allowed to
+; nest within a thread; the thread-cell keeps track of
+; whether this thread already holds the lock.
+
+(define ar-the-sema (make-semaphore 1))
+
+(define ar-sema-cell (make-thread-cell #f))
+
+(xdef atomic-invoke (lambda (f)
+ (if (thread-cell-ref ar-sema-cell)
+ (ar-apply f '())
+ (begin
+ (thread-cell-set! ar-sema-cell #t)
+ (protect
+ (lambda ()
+ (call-with-semaphore
+ ar-the-sema
+ (lambda () (ar-apply f '()))))
+ (lambda ()
+ (thread-cell-set! ar-sema-cell #f)))))))
+
+(xdef dead (lambda (x) (tnil (thread-dead? x))))
+
+; Added because Mzscheme buffers output. Not a permanent part of Arc.
+; Only need to use when declare explicit-flush optimization.
+
+(xdef flushout (lambda () (flush-output) 't))
+
+(xdef ssyntax (lambda (x) (tnil (ssyntax? x))))
+
+(xdef ssexpand (lambda (x)
+ (if (symbol? x) (expand-ssyntax x) x)))
+
+(xdef quit exit)
+
+; there are two ways to close a TCP output port.
+; (close o) waits for output to drain, then closes UNIX descriptor.
+; (force-close o) discards buffered output, then closes UNIX desc.
+; web servers need the latter to get rid of connections to
+; clients that are not reading data.
+; mzscheme close-output-port doesn't work (just raises an error)
+; if there is buffered output for a non-responsive socket.
+; must use custodian-shutdown-all instead.
+
+(define custodians (make-hash-table 'equal))
+
+(define (associate-custodian c i o)
+ (hash-table-put! custodians i c)
+ (hash-table-put! custodians o c))
+
+; if a port has a custodian, use it to close the port forcefully.
+; also get rid of the reference to the custodian.
+; sadly doing this to the input port also kills the output port.
+
+(define (try-custodian p)
+ (let ((c (hash-table-get custodians p #f)))
+ (if c
+ (begin
+ (custodian-shutdown-all c)
+ (hash-table-remove! custodians p)
+ #t)
+ #f)))
+
+(define (ar-close . args)
+ (map (lambda (p)
+ (cond ((input-port? p) (close-input-port p))
+ ((output-port? p) (close-output-port p))
+ ((tcp-listener? p) (tcp-close p))
+ (#t (err "Can't close " p))))
+ args)
+ (map (lambda (p) (try-custodian p)) args) ; free any custodian
+ 'nil)
+
+(xdef close ar-close)
+
+(xdef force-close (lambda args
+ (map (lambda (p)
+ (if (not (try-custodian p))
+ (ar-close p)))
+ args)
+ 'nil))
+
+(xdef memory current-memory-use)
+
+(xdef declare (lambda (key val)
+ (let ((flag (not (ar-false? val))))
+ (case key
+ ((atstrings) (set! atstrings flag))
+ ((direct-calls) (set! direct-calls flag))
+ ((explicit-flush) (set! explicit-flush flag)))
+ val)))
+
+(putenv "TZ" ":GMT")
+
+(define (gmt-date sec) (seconds->date sec))
+
+(xdef timedate
+ (lambda args
+ (let ((d (gmt-date (if (pair? args) (car args) (current-seconds)))))
+ (ac-niltree (list (date-second d)
+ (date-minute d)
+ (date-hour d)
+ (date-day d)
+ (date-month d)
+ (date-year d))))))
+
+(xdef sin sin)
+(xdef cos cos)
+(xdef tan tan)
+(xdef asin asin)
+(xdef acos acos)
+(xdef atan atan)
+(xdef log log)
+
+(define (codestring s)
+ (let ((i (atpos s 0)))
+ (if i
+ (cons (substring s 0 i)
+ (let* ((rest (substring s (+ i 1)))
+ (in (open-input-string rest))
+ (expr (read in))
+ (i2 (let-values (((x y z) (port-next-location in))) z)))
+ (close-input-port in)
+ (cons expr (codestring (substring rest (- i2 1))))))
+ (list s))))
+
+; First unescaped @ in s, if any. Escape by doubling.
+
+(define (atpos s i)
+ (cond ((eqv? i (string-length s))
+ #f)
+ ((eqv? (string-ref s i) #\@)
+ (if (and (< (+ i 1) (string-length s))
+ (not (eqv? (string-ref s (+ i 1)) #\@)))
+ i
+ (atpos s (+ i 2))))
+ (#t
+ (atpos s (+ i 1)))))
+
+(define (unescape-ats s)
+ (list->string (letrec ((unesc (lambda (cs)
+ (cond
+ ((null? cs)
+ '())
+ ((and (eqv? (car cs) #\@)
+ (not (null? (cdr cs)))
+ (eqv? (cadr cs) #\@))
+ (unesc (cdr cs)))
+ (#t
+ (cons (car cs) (unesc (cdr cs))))))))
+ (unesc (string->list s)))))
+
+)
+