Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

The initial contents of arc0.tar.

  • Loading branch information...
commit a2abf3b54b5835759c45f257ae19bb2fb3184e44 0 parents
@nex3 nex3 authored
1,093 ac.scm
@@ -0,0 +1,1093 @@
+; scheme48
+; ,open tables sockets extended-ports c-system-function ascii i/o-internal
+; ,open posix-files handle random pp simple-conditions
+
+; to do:
+; select, perhaps with threads, or pltt events
+; check argument count for complex arguments
+
+; refs.arc, first 300 lines of x, total CPU time including startup. on powerbook.
+; scheme48: 31.944u 0.518s 2:13.65 24.2% 0+0k 5+7io 0pf+0w
+; mzscheme: 16.425u 0.489s 0:52.61 32.1% 0+0k 26+22io 0pf+0w
+
+; dynamic creation of local variables with =
+; can you create globals inside a procedure?
+; does action of = depend on whether, at run time,
+; the variable has a global definition?
+; what's the scope of such a variable?
+; though a.lisp seems to create a global, not a local!
+; run-time expansion of macros
+; how do I know if something is a macro at compile time?
+; macros have lexical scope. so how do i know if a lexical
+; variable is going to be bound to a procedure? or to a macro?
+; what is annotate doing to symbols?
+; tests.arc implies that '(a b) produces a mutable list
+; so (fn () '(a)) produces a list that can be modified,
+; and future calls will reflect the modifications
+; oy. clisp works this way too.
+; it's not that easy to simulate this.
+; what is this? (def foo1 (x (o y x)) (list x y))
+
+; it's not clear I translate NILs in the outputs of macros correctly.
+; I translate (NIL . NIL) to ('NIL . '())
+; I use Scheme apply to call macros.
+; Scheme apply demands a '()-terminated list.
+; most macros have a . body argument.
+; so body is '()-terminated, not NIL-terminated.
+; solution: ar-false? knows about '()
+; this doesn't work, since var isn't a variable name:
+; (mac or args
+; (and args
+; (let var (tag 'symbol (list 'or))
+; (list 'let var (car args)
+; (list 'if var var (cons 'or (cdr args)))))))
+
+(module ac mzscheme
+
+(provide (all-defined))
+(require (lib "port.ss"))
+(require (lib "process.ss"))
+(require (lib "pretty.ss"))
+
+; 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) (string-copy s)) ; to avoid immutable strings
+ ((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) 'set) (ac-set (cdr s) env))
+ ; this line could be removed without changing semantics
+ ((eq? (xcar (xcar s)) 'compose) (ac (decompose (cdar s) (cdr s)) env))
+ ((pair? s) (ac-call (car s) (cdr s) env))
+ (#t (err "Bad object in expression" s))))
+
+(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 '++)))
+ (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 #\~)))
+ (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)))
+
+(define (expand-ssyntax sym)
+ (let ((elts (map (lambda (tok)
+ (if (eqv? (car tok) #\~)
+ `(complement ,(chars->value (cdr tok)))
+ (chars->value tok)))
+ (tokens #\: (symbol->chars sym) '() '()))))
+ (if (null? (cdr elts))
+ (car elts)
+ (cons 'compose elts))))
+
+(define (symbol->chars x) (string->list (symbol->string x)))
+
+(define (chars->value chars) (read-from-string (list->string chars)))
+
+; result will contain || if separator at end of symbol; could use
+; that to mean something
+
+(define (tokens separator source token acc)
+ (cond ((null? source)
+ (reverse (cons (reverse token) acc)))
+ ((eqv? (car source) separator)
+ (tokens separator
+ (cdr source)
+ '()
+ (cons (reverse token) acc)))
+ (#t
+ (tokens separator
+ (cdr source)
+ (cons (car source) token)
+ acc))))
+
+; Purely an optimization. Could in principle do it with a preprocessor
+; instead of adding a line to ac, but only want to do it for evaluated
+; subtrees, and much easier to figure those out in ac.
+
+(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-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)
+ (map (lambda (x) (ac-qq1 level x env)) x))
+ (#t x)))
+
+; (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)))
+;(not (eq? 'nil ,(ac (car args) env)))
+ ,(ac (cadr args) env)
+ ,(ac-if (cddr args) 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)
+ `(lambda ,(let ((a (ac-denil args))) (if (eqv? a 'nil) '() a))
+ 'nil
+ ,@(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
+ 'nil
+ ,@(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)
+ (if (null? body)
+ '()
+ (cons (ac (car body) env) (ac-body (cdr 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)) (ac (cadr x) env) env)
+ (ac-setn (cddr x) env))))
+
+; = 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 b env)
+ (if (symbol? a)
+ (let ((name (string->symbol (string-append " " (symbol->string a)))))
+ (list 'let `((,name ,b))
+ (cond ((eqv? a 'nil) (err "Can't rebind nil"))
+ ((eqv? a 't) (err "Can't rebind t"))
+ ((lex? a env) `(set! ,a ,name))
+ (#t `(namespace-set-variable-value! ',(ac-global-name a)
+ ,name)))
+ name))
+ (err "First arg to set must be a symbol" a)))
+
+; 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)
+(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) ,@(map (lambda (x) (ac x env)) args)))
+ ((= (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.
+
+(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)))
+
+;(define (err msg . args)
+; (display msg)
+; (map (lambda (a) (display " ") (write a)) args)
+; (newline)
+; (xxundefined))
+
+(define err error) ; eli says need to remove xxundefined for speed
+
+; run-time primitive procedures
+
+(define (xdef a b)
+ (namespace-set-variable-value! (ac-global-name a) b)
+ b)
+
+(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)))
+
+#|
+ (if (eq? x 'nil) #t
+ (if (eq? x '()) #t
+ (not x)))
+|#
+
+; call a function or perform an array ref, hash ref, &c
+
+; Non-fn donstants in functional position are valuable real estate, so
+; should figure out the best way to exploit it.
+
+(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) #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)))))
+
+; reduce?
+
+(define (pairwise pred args base)
+ (let ((n (length args)))
+ (cond ((< n 2) base)
+ ((= n 2) (apply pred args))
+ (#t (and (pred (car args) (cadr args))
+ (pairwise pred (cdr args) base))))))
+
+; 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?
+
+(xdef 'is (lambda args
+ (if (or (all (lambda (a) (eqv? (car args) a)) (cdr args))
+ (and (all string? args)
+ (apply string=? args))
+ (all ar-false? args))
+ 't 'nil)))
+
+(xdef 'err err)
+(xdef 'nil 'nil)
+(xdef 't 't)
+
+(define (all test seq)
+ (or (null? seq)
+ (and (test (car seq)) (all test (cdr seq)))))
+
+; rather strictly excludes ()
+
+(define (arc-list? x) (or (pair? x) (eqv? x 'nil)))
+
+; generic +: strings, lists, numbers.
+; problem with generic +: what to return when no args?
+; could even coerce based on type of first arg...
+
+(xdef '+ (lambda args
+ (cond ((null? args) 0)
+ ((all string? args)
+ (apply string-append args))
+ ((all arc-list? args)
+ (ac-niltree (apply append (map ar-nil-terminate args))))
+ (#t (apply + args)))))
+
+(xdef '- -)
+(xdef '* *)
+(xdef '/ /)
+(xdef 'mod modulo)
+(xdef 'expt expt)
+(xdef 'sqrt sqrt)
+
+; generic comparison
+
+(define (arc> . args)
+ (cond ((all number? args) (apply > args))
+ ((all string? args) (pairwise string>? args #f))
+ ((all symbol? args) (pairwise (lambda (x y)
+ (string>? (symbol->string x)
+ (symbol->string y)))
+ args
+ #f))
+ ((all char? args) (pairwise char>? args #f))
+ (#t (apply > args))))
+(xdef '> (lambda args (if (apply arc> args) 't 'nil)))
+
+(define (arc< . args)
+ (cond ((all number? args) (apply < args))
+ ((all string? args) (pairwise string<? args #f))
+ ((all symbol? args) (pairwise (lambda (x y)
+ (string<? (symbol->string x)
+ (symbol->string y)))
+ args
+ #f))
+ ((all char? args) (pairwise char<? args #f))
+ (#t (apply < args))))
+(xdef '< (lambda args (if (apply arc< args) 't 'nil)))
+
+(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 (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)
+ ((integer? 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)
+ (#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 'close (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)))
+ 'nil))
+
+(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))))
+
+; (readc stream)
+; nil stream means stdout
+; returns nil on eof
+
+(xdef 'readc (lambda (str)
+ (let ((p (if (ar-false? str)
+ (current-input-port)
+ str)))
+ (let ((c (read-char p)))
+ (if (eof-object? c) 'nil c)))))
+
+(xdef 'readb (lambda (str)
+ (let ((p (if (ar-false? str)
+ (current-input-port)
+ str)))
+ (let ((c (read-byte p)))
+ (if (eof-object? c) 'nil c)))))
+
+(xdef 'peekc (lambda (str)
+ (let ((p (if (ar-false? str)
+ (current-input-port)
+ str)))
+ (let ((c (peek-char p)))
+ (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))
+
+(xdef 'write (lambda args
+ (if (pair? args)
+ (write (ac-denil (car args))
+ (if (pair? (cdr args))
+ (cadr args)
+ (current-output-port))))
+ (flush-output)
+ 'nil))
+
+(xdef 'disp (lambda args
+ (if (pair? args)
+ (display (ac-denil (car args))
+ (if (pair? (cdr args))
+ (cadr args)
+ (current-output-port))))
+ (flush-output)
+ 'nil))
+
+; 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)
+
+(xdef 'coerce (lambda (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))))
+ ((integer? x) (case type
+ ((char) (ascii->char x))
+ ((string) (apply number->string x args))
+ (else (err "Can't coerce" x type))))
+ ((number? x) (case type
+ ((int) (round x))
+ ((char) (ascii->char (round 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)))
+ ((int) (or (apply string->number x args)
+ (err "Can't coerce" x type)))
+ (else (err "Can't coerce" x type))))
+ ((pair? x) (case type
+ ((string) (list->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))))
+ ((symbol? x) (case type
+ ((string) (symbol->string x))
+ (else (err "Can't coerce" x type))))
+ (#t x))))
+
+(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)
+ (call-with-values
+ (lambda () (tcp-accept s))
+ (lambda (in out)
+ (list (make-limited-input-port in 100000 #t)
+ out
+ (let-values (((us them) (tcp-addresses out)))
+ them))))))
+
+(xdef 'thread thread)
+(xdef 'kill-thread kill-thread)
+(xdef 'break-thread break-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 () (make-hash-table 'equal)))
+
+;(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))
+
+(xdef 'protect (lambda (during after)
+ (dynamic-wind (lambda () #t) during after)))
+
+; need to use a better seed
+
+(xdef 'rand random)
+
+(xdef 'dir (lambda (name) (map path->string (directory-list name))))
+
+(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))
+
+; 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 '()) (interaction-environment)))
+
+(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 (interaction-environment))
+ (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) '()) (interaction-environment))))
+
+; 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 (write-to-string x)
+ (let ((o (open-output-string)))
+ (write x o)
+ (close-output-port o)
+ (get-output-string o)))
+
+(xdef 'details (lambda (c)
+ (write-to-string (exn-message c))))
+
+(xdef 'scar (lambda (x val)
+ (if (string? x)
+ (string-set! x 0 val)
+ (set-car! x val))
+ val))
+
+(xdef 'scdr (lambda (x val)
+ (if (string? x)
+ (err "Can't set cdr of a string" x)
+ (set-cdr! x val))
+ val))
+
+; 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)))
+
+(xdef 'sref (lambda (com val ind) ; later make ind rest arg
+ (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)
+ (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) (if (bound? x) 't 'nil)))
+
+(xdef 'newstring make-string)
+
+(xdef 'truncate (lambda (x) (inexact->exact (truncate x))))
+
+(xdef 'exact (lambda (x) (and (integer? x) (exact? 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.
+; XXX make sure cell is set #f after an exception?
+; maybe it doesn't matter since thread will die?
+(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)
+ (let ((ret
+ (call-with-semaphore
+ ar-the-sema
+ (lambda () (ar-apply f '())))))
+ (thread-cell-set! ar-sema-cell #f)
+ ret)))))
+
+(xdef 'dead thread-dead?)
+
+; Added because Mzscheme buffers output. Not sure if want as official
+; part of Arc.
+
+;(xdef 'flushout (lambda () (flush-output) 't))
+
+(xdef 'ssyntax (lambda (x) (if (ssyntax? x) 't 'nil)))
+
+(xdef 'ssexpand (lambda (x)
+ (if (symbol? x) (expand-ssyntax x) x)))
+
+(xdef 'quit exit)
+
+
+)
+
+(require ac)
535 app.arc
@@ -0,0 +1,535 @@
+; Application Server. Layer inserted 2 Sep 06.
+
+; todo: def a general notion of apps of which the programming app is
+; one and the news site another.
+; give each user a place to store data? A home dir?
+
+; A user is simply a string: "pg". Use /whoami to test user cookie.
+
+(= hpwfile* "arc/hpw"
+ adminfile* "arc/admins"
+ cookfile* "arc/cooks")
+
+(def asv ((o port 8080))
+ (load-userinfo)
+ (serve port))
+
+(def load-userinfo ()
+ (= hpasswords* (safe-load-table hpwfile*)
+ admins* (map string (errsafe (readfile adminfile*)))
+ cookie->user* (safe-load-table cookfile*))
+ (maptable (fn (k v) (= (user->cookie* v) k))
+ cookie->user*))
+
+; idea: a bidirectional table, so don't need two vars (and sets)
+
+(= cookie->user* (table) user->cookie* (table) logins* (table))
+
+(def get-user (req)
+ (let u (aand (alref (req 'cooks) "user") (cookie->user* (sym it)))
+ (when u (= (logins* u) (req 'ip)))
+ u))
+
+(mac when-usermatch (user req . body)
+ `(if (is ,user (get-user ,req))
+ (do ,@body)
+ (mismatch-message)))
+
+(def mismatch-message () (prn "Dead link: users don't match."))
+
+(mac when-usermatchr (user req . body)
+ `(if (is ,user (get-user ,req))
+ (do ,@body)
+ "mismatch"))
+
+(defop mismatch req (mismatch-message))
+
+(mac matchform (user req after . body)
+ `(aform (fn (,req)
+ (when-usermatch ,user ,req
+ ,after))
+ ,@body))
+
+(mac matchrform (user req after . body)
+ `(arform (fn (,req)
+ (when-usermatchr ,user ,req
+ ,after))
+ ,@body))
+
+; Like onlink, but checks that user submitting the request is the
+; same it was generated for. Really should log the username and
+; ip addr of every genlink, and check if they match.
+
+(mac userlink (user text . body)
+ (w/uniq req
+ `(linkf ,text (,req)
+ (when-usermatch ,user ,req ,@body))))
+
+
+(defop admin req (admin-gate (get-user req)))
+
+(def admin-gate (u)
+ (if (admin u)
+ (admin-page u)
+ (login-page 'login nil
+ (fn (u ip) (admin-gate u)))))
+
+(def admin (u) (and u (mem u admins*)))
+
+(def user-exists (u) (and u (hpasswords* u) u))
+
+(def admin-page (user . msg)
+ (whitepage
+ (prbold "Admin: ")
+ (hspace 20)
+ (pr user " | ")
+ (w/link (do (logout-user user)
+ (whitepage (pr "Bye " user ".")))
+ (pr "logout"))
+ (when msg (hspace 10) (map pr msg))
+ (br2)
+ (aform (fn (req)
+ (when-usermatch user req
+ (with (u (arg req "u") p (arg req "p"))
+ (if (or (no u) (no p) (is u "") (is p ""))
+ (pr "Bad data.")
+ (user-exists u)
+ (admin-page user "User already exists: " u)
+ (do (create-acct u p)
+ (admin-page user))))))
+ (pwfields "create (server) account"))))
+
+; need to define a notion of a hashtable that's always written
+; to a file when modified
+
+(def cook-user (user)
+ (let id (new-user-cookie)
+ (= (cookie->user* id) user
+ (user->cookie* user) id)
+ (save-table cookie->user* cookfile*)
+ id))
+
+; Unique-ids are only unique per server invocation.
+
+(def new-user-cookie ()
+ (let id (unique-id)
+ (if (cookie->user* id) (new-user-cookie) id)))
+
+(def logout-user (user)
+ (nil! (logins* user))
+ (nil! (cookie->user* (user->cookie* user)) (user->cookie* user))
+ (save-table cookie->user* cookfile*))
+
+(def create-acct (user pw)
+ (set-pw user pw))
+
+(def disable-acct (user)
+ (set-pw user (rand-string 20))
+ (logout-user user))
+
+(def set-pw (user pw)
+ (= (hpasswords* user) (and pw (shash pw)))
+ (save-table hpasswords* hpwfile*))
+
+(def hello-page (user ip)
+ (whitepage (prs "hello" user "at" ip)))
+
+(defop login req (login-page 'login))
+
+; switch is one of: register, login, both
+; afterward is a function on the newly created user, ip addr
+; or can be a list of such a fn and a string, in which case call fn
+; then redirect to string
+
+; classic example of something that should just "return" a val
+; via a continuation rather than going to a new page.
+
+; ugly code-- too much duplication
+
+(def login-page (switch (o msg nil) (o afterward hello-page))
+ (whitepage
+ (pagemessage msg)
+ (when (in switch 'login 'both)
+ (prbold "Login")
+ (br2)
+ (if (acons afterward)
+ (let (f url) afterward
+ (arformh (fn (req)
+ (logout-user (get-user req))
+ (aif (good-login (arg req "u") (arg req "p") (req 'ip))
+ (do (= (logins* it) (req 'ip))
+ (prcookie (user->cookie* it))
+ (f it (req 'ip))
+ url)
+ (flink (fn ignore (login-page switch
+ "Bad login."
+ afterward)))))
+ (pwfields)))
+ (aformh (fn (req)
+ (logout-user (get-user req))
+ (aif (good-login (arg req "u") (arg req "p") (req 'ip))
+ (do (= (logins* it) (req 'ip))
+ (prcookie (user->cookie* it))
+ (prn)
+ (afterward it (req 'ip)))
+ (do (prn)
+ (login-page switch "Bad login." afterward))))
+ (pwfields)))
+ (br2))
+ (when (in switch 'register 'both)
+ (prbold "Create Account")
+ (br2)
+ (if (acons afterward)
+ (let (f url) afterward
+ (arformh (fn (req)
+ (logout-user (get-user req))
+ (with (user (arg req "u") pw (arg req "p"))
+ (aif (bad-newacct user pw)
+ (flink (fn ignore
+ (login-page switch it afterward)))
+ (do (create-acct user pw)
+ (= (logins* user) (req 'ip))
+ (prcookie (cook-user user))
+ (f user (req 'ip))
+ url))))
+ (pwfields "create account")))
+ (aformh (fn (req)
+ (logout-user (get-user req))
+ (with (user (arg req "u") pw (arg req "p"))
+ (aif (bad-newacct user pw)
+ (do (prn)
+ (login-page switch it afterward))
+ (do (create-acct user pw)
+ (= (logins* user) (req 'ip))
+ (prcookie (cook-user user))
+ (prn)
+ (afterward user (req 'ip))))))
+ (pwfields "create account"))))))
+
+(def prcookie (cook)
+ (prn "Set-Cookie: user=" cook "; expires=Sun, 17-Jan-2038 19:14:07 GMT"))
+
+(def pwfields ((o label "login"))
+ (inputs u username 20 nil
+ p password 20 nil)
+ (br)
+ (submit label))
+
+(= good-logins* (queue) bad-logins* (queue))
+
+(def good-login (user pw ip)
+ (let record (list (seconds) ip user pw)
+ (if (and user pw (aand (shash pw) (is it (hpasswords* user))))
+ (do (unless (user->cookie* user) (cook-user user))
+ (enq-limit record good-logins*)
+ user)
+ (do (enq-limit record bad-logins*)
+ nil))))
+
+; can remove this once sha1 installed on pi
+
+; Create a file in case people have quote chars in their pws. I can't
+; believe there's no way to just send the chars.
+
+(def shash (str)
+ (let fname (+ "/tmp/shash" (rand-string 10))
+ (w/outfile f fname (disp str f))
+ (let res (tostring (system (+ "openssl dgst -sha1 <" fname)))
+ (do1 (subseq res 0 (- (len res) 1))
+ (rmfile fname)))))
+
+(def bad-newacct (user pw)
+ (if (no (goodname user 2 15))
+ "Usernames can only contain letters, digits, dashes and
+ underscores, and should be between 2 and 15 characters long.
+ Please choose another."
+ (let dcuser (downcase user)
+ (some [is dcuser (downcase _)] (keys hpasswords*)))
+ "That username is taken. Please choose another."
+ (or (no pw) (< (len pw) 4))
+ "Passwords should be a least 4 characters long. Please
+ choose another."
+ nil))
+
+(def goodname (str (o min 1) (o max nil))
+ (and (isa str 'string)
+ (>= (len str) min)
+ (~find (fn (c) (no (or (alphadig c) (in c #\- #\_))))
+ str)
+ (isnt (str 0) #\-)
+ (or (no max) (<= (len str) max))
+ str))
+
+
+(defop logout req
+ (aif (get-user req)
+ (do (logout-user it)
+ (pr "Logged out."))
+ (pr "You were not logged in.")))
+
+(defop whoami req
+ (aif (get-user req)
+ (prs it 'at (req 'ip))
+ (do (pr "You are not logged in. ")
+ (w/link (login-page 'both) (pr "Log in"))
+ (pr "."))))
+
+
+
+(= formwid* 60 bigformwid* 80 numwid* 8 formatdoc-url* nil)
+
+; Eventually figure out a way to separate type name from format of
+; input field, instead of having e.g. toks and bigtoks
+
+(def varfield (typ id val)
+ (if (in typ 'string 'string1 'url)
+ (gentag input type 'text name id value val size formwid*)
+ (in typ 'num 'int 'posint)
+ (gentag input type 'text name id value val size numwid*)
+ (in typ 'users 'toks)
+ (gentag input type 'text name id value (tostring (apply prs val))
+ size formwid*)
+ (is typ 'sexpr)
+ (gentag input type 'text name id
+ value (tostring (map [do (write _) (sp)] val))
+ size formwid*)
+ (in typ 'syms 'text 'doc 'mdtext 'mdtext2 'lines 'bigtoks)
+ (let text (if (in typ 'syms 'bigtoks)
+ (tostring (apply prs val))
+ (in typ 'mdtext 'mdtext2)
+ (unmarkdown val)
+ (no val)
+ ""
+ val)
+ (tag (textarea cols (if (is typ 'doc) bigformwid* formwid*)
+ rows (needrows text formwid* 4)
+ wrap 'virtual
+ style (if (is typ 'doc) "font-size:8.5pt")
+ name id)
+ (prn) ; needed or 1 initial newline gets chopped off
+ (pr text))
+ (when (and formatdoc-url* (in typ 'mdtext 'mdtext2))
+ (pr " ")
+ (tag (font size -2)
+ (link "help" formatdoc-url* (gray 175)))))
+ (and (acons typ) (is (car typ) 'choice))
+ (menu id (cddr typ) val)
+ (is typ 'yesno)
+ (menu id '("yes" "no") (if val "yes" "no"))
+ (is typ 'hexcol)
+ (gentag input type 'text name id value val); was (hexrep val)
+ (err "unknown varfield type" typ)))
+
+(def text-rows (text wid (o pad 3))
+ (+ (truncate (/ (len text) (* wid .8))) pad))
+
+(def needrows (text cols (o pad 0))
+ (+ pad (max (+ 1 (count #\newline text))
+ (roundup (/ (len text) (- cols 5))))))
+
+(def varline (typ id val)
+ (if (in typ 'users 'syms 'toks 'bigtoks) (apply prs val)
+ (is typ 'lines) (map prn val)
+ (is typ 'yesno) (pr (if val 'yes 'no))
+ (is typ 'choice) (varline (cadr typ) nil val)
+ (text-type typ) (pr (or val ""))
+ (pr val)))
+
+(def text-type (typ) (in typ 'string 'string1 'url 'text 'mdtext 'mdtext2))
+
+; Newlines in forms come back as /r/n. Only want the /ns. Currently
+; remove the /rs in individual cases below. Could do it in aform or
+; even in the parsing of http requests, in the server.
+
+; Need the calls to striptags so that news users can't get html
+; into a title or comment by editing it. If want a form that
+; can take html, just create another typ for it.
+
+(def readvar (typ str (o fail nil))
+ (case (carif typ)
+ string (striptags str)
+ string1 (if (is str "") fail (striptags str))
+ url (if (is str "") str (valid-url str) (striptags str) fail)
+ num (let n (saferead str) (if (number n) n fail))
+ int (let n (saferead str)
+ (if (number n) (round n) fail))
+ posint (let n (saferead str)
+ (if (and (number n) (> n 0)) (round n) fail))
+ text (striptags str)
+ doc (striptags str)
+ mdtext (md-from-form str)
+ mdtext2 (md-from-form str t) ; for md with no links
+ ; sym (aif (tokens str) (sym (car it)) fail)
+ ; syms (map sym (tokens str))
+ sexpr (errsafe (readall str))
+ users (rem [no (goodname _)] (tokens str))
+ toks (tokens str)
+ bigtoks (tokens str)
+ ; lines (or (splitlines (= sss str)) fail)
+ choice (readvar (cadr typ) str)
+ yesno (is str "yes")
+ hexcol (if (hex>color str) str fail) ; was (or (hex>color str) fail)
+ (err "unknown readvar type" typ)))
+
+(def splitlines (str)
+ (map [rem #\return _] (split (cons #\newline "") str)))
+
+(= fail* (uniq))
+
+; Takes a list of fields of the form (type label value view modify) and
+; a fn f and generates a form such that when submitted (f label newval)
+; will be called for each valid value. Finally done is called.
+
+(def vars-form (user fields f done (o button "update") (o lasts))
+ (timed-aform lasts
+ (fn (req)
+ (when-usermatch user req
+ (each (k v) (req 'args)
+ (let name (sym k)
+ (awhen (find [is (cadr _) name] fields)
+ (let (typ id val mod) it
+ (when (and mod v)
+ (let newval (readvar typ v fail*)
+ (unless (is newval fail*)
+ (f name newval))))))))
+ (done)))
+ (tab
+ (showvars fields))
+ (unless (all [no (_ 4)] fields) ; no modifiable fields
+ (br)
+ (submit button))))
+
+(def showvars (fields)
+ (each (typ id val view mod question) fields
+ (when view
+ (when question
+ (tr (td (prn question))))
+ (tr (unless question (tag (td valign 'top) (pr id ":")))
+ (td ((if mod varfield varline) typ id val)))
+ (prn))))
+
+; http://daringfireball.net/projects/markdown/syntax
+
+(def md-from-form (str (o nolinks))
+ (markdown (trim (rem #\return (esc<>& str)) 'end) 60 nolinks))
+
+(def markdown (s (o maxurl) (o nolinks))
+ (let ital nil
+ (tostring
+ (forlen i s
+ (iflet (newi spaces) (indented-code s i (if (is i 0) 2 0))
+ (do (pr "<p><pre><code>")
+ (let cb (code-block s (- newi spaces 1))
+ (pr cb)
+ (= i (+ (- newi spaces 1) (len cb))))
+ (pr "</code></pre>"))
+ (iflet newi (parabreak s i (if (is i 0) 1 0))
+ (do (unless (is i 0) (pr "<p>"))
+ (= i (- newi 1)))
+ (and (is (s i) #\*)
+ (or ital
+ (atend i s)
+ (and (~whitec (s (+ i 1)))
+ (pos #\* s (+ i 1)))))
+ (do (pr (if ital "</i>" "<i>"))
+ (= ital (no ital)))
+ (and (no nolinks)
+ (t! gotthere)
+ (or (litmatch "http://" s i)
+ (litmatch "https://" s i)))
+ (withs (n (urlend s i)
+ url (subseq s i n))
+ (tag (a href url rel 'nofollow)
+ (pr (if (no maxurl) url (ellipsize url maxurl))))
+ (= i (- n 1)))
+ (writec (s i))))))))
+
+(def indented-code (s i (o newlines 0) (o spaces 0))
+ (let c (s i)
+ (if (nonwhite c)
+ (if (and (> newlines 1) (> spaces 1))
+ (list i spaces)
+ nil)
+ (atend i s)
+ nil
+ (is c #\newline)
+ (indented-code s (+ i 1) (+ newlines 1) 0)
+ (indented-code s (+ i 1) newlines (+ spaces 1)))))
+
+(def parabreak (s i (o newlines 0))
+ (let c (s i)
+ (if (or (nonwhite c) (atend i s))
+ (if (> newlines 1) i nil)
+ (parabreak s (+ i 1) (+ newlines (if (is c #\newline) 1 0))))))
+
+
+; Returns the index of the first char not part of the url beginning
+; at i, or len of string if url goes all the way to the end.
+
+; Note that > immediately after a url (http://foo.com>) will cause
+; an odd result, because the > gets escaped to something beginning
+; with &, which is treated as part of the url. Perhaps the answer
+; is just to esc<>& after markdown instead of before.
+
+(def urlend (s i)
+ (let c (s i)
+ (if (atend i s)
+ (if ((orf punc delimc whitec) c) i (+ i 1))
+ (if (or (whitec c)
+ (delimc c)
+ (and (punc c)
+ ((orf whitec delimc) (s (+ i 1)))))
+ i
+ (urlend s (+ i 1))))))
+
+(def delimc (c)
+ (in c #\( #\) #\[ #\] #\{ #\} #\"))
+
+
+(def code-block (s i)
+ (tostring
+ (until (let left (- (len s) i 1)
+ (or (is left 0)
+ (and (> left 2)
+ (is (s (+ i 1)) #\newline)
+ (nonwhite (s (+ i 2))))))
+ (writec (s (++ i))))))
+
+(def unmarkdown (s)
+ (tostring
+ (forlen i s
+ (if (litmatch "<p>" s i)
+ (do (++ i 2)
+ (unless (is i 2) (pr "\n\n")))
+ (litmatch "<i>" s i)
+ (do (++ i 2) (pr #\*))
+ (litmatch "</i>" s i)
+ (do (++ i 3) (pr #\*))
+ (litmatch "<a href=" s i)
+ (let endurl (posmatch [in _ #\> #\space] s (+ i 9))
+ (if endurl
+ (do (pr (subseq s (+ i 9) (- endurl 1)))
+ (= i (aif (posmatch "</a>" s endurl)
+ (+ it 3)
+ endurl)))
+ (writec (s i))))
+ (litmatch "<pre><code>" s i)
+ (awhen (findsubseq "</code></pre>" s (+ i 12))
+ (pr (subseq s (+ i 11) it))
+ (= i (+ it 12)))
+ (litmatch "<pre><code>" s i)
+ (awhen (findsubseq "</code></pre>" s (+ i 12))
+ (pr (subseq s (+ i 11) it))
+ (= i (+ it 12)))
+ (writec (s i))))))
+
+
+(mac defopl (name parm . body)
+ `(defop ,name ,parm
+ (if (get-user ,parm)
+ (do ,@body)
+ (login-page 'both
+ "You need to be logged in to do that."
+ (list (fn (u ip))
+ (string ',name (reassemble-args ,parm)))))))
+
1,496 arc.arc
@@ -0,0 +1,1496 @@
+; Main Arc lib. Ported to Scheme version Jul 06.
+
+; optimize ~foo in functional position in ac, like compose
+; rename: string, into-string (shorter). could call intos string,
+; but then what to call string?
+; get hold of error types within arc
+; why is macex defined in scheme instead of using def below?
+; write disp, read, write in arc
+; could prob write rmfile and dir in terms of system
+; could I get all of macros up into lib.arc?
+
+; any logical reason I can't say (push x (if foo y z)) ?
+; eval would have to always ret 2 things, the val and where it came from
+; idea: implicit tables of tables; setf empty field, becomes table
+; or should setf on a table just take n args?
+; idea: permanent objs that live on disk and are updated when modified
+
+; compromises in this implementation:
+; no objs in code
+; (mac testlit args (listtab args)) breaks when called
+; separate string type
+; (= (cdr (cdr str)) "foo") couldn't work because no way to get str tail
+
+
+(set do (annotate 'mac
+ (fn args `((fn () ,@args)))))
+
+(set safeset (annotate 'mac
+ (fn (var val)
+ `(do (if (bound ',var)
+ (do (disp "*** redefining ")
+ (disp ',var)
+ (writec #\newline)))
+ (set ,var ,val)))))
+
+(set def (annotate 'mac
+ (fn (name parms . body)
+ `(do (sref sig ',parms ',name)
+ (safeset ,name (fn ,parms ,@body))))))
+
+(def caar (xs) (car (car xs)))
+(def cadr (xs) (car (cdr xs)))
+(def cddr (xs) (cdr (cdr xs)))
+
+(def no (x) (is x nil))
+
+(def acons (x) (is (type x) 'cons))
+
+(def atom (x) (no (acons x)))
+
+(def list args args)
+
+(def idfn (x) x)
+
+; Maybe later make this internal.
+
+(def map1 (f xs)
+ (if (no xs)
+ nil
+ (cons (f (car xs)) (map1 f (cdr xs)))))
+
+(def pair (xs (o f list))
+ (if (no xs)
+ nil
+ (no (cdr xs))
+ (list (list (car xs)))
+ (cons (f (car xs) (cadr xs))
+ (pair (cddr xs) f))))
+
+(set mac (annotate 'mac
+ (fn (name parms . body)
+ `(do (sref sig ',parms ',name)
+ (safeset ,name (annotate 'mac (fn ,parms ,@body)))))))
+
+(mac and args
+ (if args
+ (if (cdr args)
+ `(if ,(car args) (and ,@(cdr args)))
+ (car args))
+ 't))
+
+(def assoc (key al)
+ (if (atom al)
+ nil
+ (and (acons (car al)) (is (caar al) key))
+ (car al)
+ (assoc key (cdr al))))
+
+(def alref (al key) (cadr (assoc key al)))
+
+(mac with (parms . body)
+ `((fn ,(map1 car (pair parms))
+ ,@body)
+ ,@(map1 cadr (pair parms))))
+
+(mac let (var val . body)
+ `(with (,var ,val) ,@body))
+
+(mac withs (parms . body)
+ (if (no parms)
+ `(do ,@body)
+ `(let ,(car parms) ,(cadr parms)
+ (withs ,(cddr parms) ,@body))))
+
+; Rtm prefers to overload + to do this
+
+(def join args
+ (if (no args)
+ nil
+ (let a (car args)
+ (if (no a)
+ (apply join (cdr args))
+ (cons (car a) (apply join (cdr a) (cdr args)))))))
+
+; Need rfn for use in macro expansions.
+
+(mac rfn (name parms . body)
+ `(let ,name nil
+ (set ,name (fn ,parms ,@body))))
+
+(mac afn (parms . body)
+ `(let self nil
+ (set self (fn ,parms ,@body))))
+
+; Ac expands x:y:z into (compose x y z), ~x into (complement x)
+
+; Only used when the call to compose doesn't occur in functional position.
+; Composes in functional position are transformed away by ac.
+
+(mac compose args
+ (let g (uniq)
+ `(fn ,g
+ ,((afn (fs)
+ (if (cdr fs)
+ (list (car fs) (self (cdr fs)))
+ `(apply ,(if (car fs) (car fs) 'idfn) ,g)))
+ args))))
+
+(mac complement (f)
+ (let g (uniq)
+ `(fn ,g (no (apply ,f ,g)))))
+
+(def rev (xs)
+ ((afn (xs acc)
+ (if (no xs)
+ acc
+ (self (cdr xs) (cons (car xs) acc))))
+ xs nil))
+
+(def isnt (x y) (no (is x y)))
+
+(mac w/uniq (names . body)
+ (if (acons names)
+ `(with ,(apply + nil (map1 (fn (n) (list n '(uniq)))
+ names))
+ ,@body)
+ `(let ,names (uniq) ,@body)))
+
+(mac or args
+ (and args
+ (w/uniq g
+ `(let ,g ,(car args)
+ (if ,g ,g (or ,@(cdr args)))))))
+
+(def alist (x) (or (no x) (is (type x) 'cons)))
+
+(mac in (x . choices)
+ (w/uniq g
+ `(let ,g ,x
+ (or ,@(map1 (fn (c) `(is ,g ,c)) choices)))))
+
+; should take n args
+
+(def iso (x y)
+ (or (is x y)
+ (and (acons x)
+ (acons y)
+ (iso (car x) (car y))
+ (iso (cdr x) (cdr y)))))
+
+(mac when (test . body)
+ `(if ,test (do ,@body)))
+
+(mac unless (test . body)
+ `(if (no ,test) (do ,@body)))
+
+(mac while (test . body)
+ (w/uniq (gf gp)
+ `((rfn ,gf (,gp)
+ (when ,gp ,@body (,gf ,test)))
+ ,test)))
+
+(def empty (seq)
+ (or (no seq)
+ (and (no (acons seq)) (is (len seq) 0))))
+
+(def reclist (f xs)
+ (and xs (or (f xs) (reclist f (cdr xs)))))
+
+(def recstring (test s (o start 0))
+ (let n (len s)
+ ((afn (i)
+ (and (< i (len s))
+ (or (test i)
+ (self (+ i 1)))))
+ start)))
+
+(def testify (x)
+ (if (isa x 'fn) x [is _ x]))
+
+(def some (test seq)
+ (let f (testify test)
+ (if (alist seq)
+ (reclist f:car seq)
+ (recstring f:seq seq))))
+
+(def all (test seq)
+ (~some (complement (testify test)) seq))
+
+(def mem (test seq)
+ (let f (testify test)
+ (reclist [if (f:car _) _] seq)))
+
+(def find (test seq)
+ (let f (testify test)
+ (if (alist seq)
+ (reclist [if (f:car _) (car _)] seq)
+ (recstring [if (f:seq _) (seq _)] seq))))
+
+(def isa (x y) (is (type x) y))
+
+; Possible to write map without map1, but makes News 3x slower.
+
+;(def map (f . seqs)
+; (if (some1 no seqs)
+; nil
+; (no (cdr seqs))
+; (let s1 (car seqs)
+; (cons (f (car s1))
+; (map f (cdr s1))))
+; (cons (apply f (map car seqs))
+; (apply map f (map cdr seqs)))))
+
+
+(def map (f . seqs)
+ (if (some [isa _ 'string] seqs)
+ (withs (n (apply min (map len seqs))
+ new (newstring n))
+ ((afn (i)
+ (if (is i n)
+ new
+ (do (sref new (apply f (map [_ i] seqs)) i)
+ (self (+ i 1)))))
+ 0))
+ (no (cdr seqs))
+ (map1 f (car seqs))
+ ((afn (seqs)
+ (if (some no seqs)
+ nil
+ (cons (apply f (map1 car seqs))
+ (self (map1 cdr seqs)))))
+ seqs)))
+
+(def mappend (f . args)
+ (apply + nil (apply map f args)))
+
+(def firstn (n xs)
+ (if (and (> n 0) xs)
+ (cons (car xs) (firstn (- n 1) (cdr xs)))
+ nil))
+
+(def nthcdr (n xs)
+ (if (> n 0)
+ (nthcdr (- n 1) (cdr xs))
+ xs))
+
+; Generalization of pair: (tuples x) = (pair x)
+
+(def tuples (xs (o n 2))
+ (if (no xs)
+ nil
+ (cons (firstn n xs)
+ (tuples (nthcdr n xs) n))))
+
+(def caris (x val) (and (acons x) (is (car x) val)))
+
+(def warn (msg . args)
+ (disp (+ "Warning: " msg ". "))
+ (map [do (write _) (disp " ")] args)
+ (disp #\newline))
+
+(mac atomic body
+ `(atomic-invoke (fn () ,@body)))
+
+(mac atlet args
+ `(atomic (let ,@args)))
+
+(mac atwith args
+ `(atomic (with ,@args)))
+
+(mac atwiths args
+ `(atomic (withs ,@args)))
+
+; setforms returns (vars get set) for a place based on car of an expr
+; vars is a list of gensyms alternating with expressions whose vals they
+; should be bound to, suitable for use as first arg to withs
+; get is an expression returning the current value in the place
+; set is an expression representing a function of one argument
+; that stores a new value in the place
+
+; A bit gross that it works based on the *name* in the car, but maybe
+; wrong to worry. Macros live in expression land.
+
+; seems meaningful to e.g. (push 1 (pop x)) if (car x) is a cons.
+; can't in cl though. could I define a setter for push or pop?
+
+(set setter (table))
+
+(mac defset (name parms . body)
+ (w/uniq gexpr
+ `(sref setter
+ (fn (,gexpr)
+ (let ,parms (cdr ,gexpr)
+ ,@body))
+ ',name)))
+
+(defset car (x)
+ (w/uniq g
+ (list (list g x)
+ `(car ,g)
+ `(fn (val) (scar ,g val)))))
+
+(defset cdr (x)
+ (w/uniq g
+ (list (list g x)
+ `(cdr ,g)
+ `(fn (val) (scdr ,g val)))))
+
+(defset caar (x)
+ (w/uniq g
+ (list (list g x)
+ `(caar ,g)
+ `(fn (val) (scar (car ,g) val)))))
+
+(defset cadr (x)
+ (w/uniq g
+ (list (list g x)
+ `(cadr ,g)
+ `(fn (val) (scar (cdr ,g) val)))))
+
+(defset cddr (x)
+ (w/uniq g
+ (list (list g x)
+ `(cddr ,g)
+ `(fn (val) (scdr (cdr ,g) val)))))
+
+; Note: if expr0 macroexpands into any expression whose car doesn't
+; have a setter, setforms assumes it's a data structure in functional
+; position. Such bugs will be seen only when the code is executed, when
+; sref complains it can't set a reference to a function.
+
+(def setforms (expr0)
+ (let expr (macex expr0)
+ (if (isa expr 'sym)
+ (w/uniq (g h)
+ (list (list g expr)
+ g
+ `(fn (,h) (set ,expr ,h))))
+ ; make it also work for uncompressed calls to compose
+ (and (acons expr) (metafn (car expr)))
+ (setforms (expand-metafn-call (ssexpand (car expr)) (cdr expr)))
+ (let f (setter (car expr))
+ (if f
+ (f expr)
+ ; assumed to be data structure in fn position
+ (do (when (caris (car expr) 'fn)
+ (warn "Inverting what looks like a function call"
+ expr0 expr))
+ (w/uniq (g h)
+ (let argsyms (map [uniq] (cdr expr))
+ (list (+ (list g (car expr))
+ (mappend list argsyms (cdr expr)))
+ `(,g ,@argsyms)
+ `(fn (,h) (sref ,g ,h ,@argsyms)))))))))))
+
+(def metafn (x)
+ (or (ssyntax x)
+ (and (acons x) (in (car x) 'compose 'complement))))
+
+(def expand-metafn-call (f args)
+ (if (is (car f) 'compose)
+ ((afn (fs)
+ (if (caris (car fs) 'compose) ; nested compose
+ (self (join (cdr (car fs)) (cdr fs)))
+ (cdr fs)
+ (list (car fs) (self (cdr fs)))
+ (cons (car fs) args)))
+ (cdr f))
+ (err "Can't invert " (cons f args))))
+
+(def expand= (place val)
+ (if (isa place 'sym)
+ `(set ,place ,val)
+ (let (vars prev setter) (setforms place)
+ (w/uniq g
+ `(atwith ,(+ vars (list g val))
+ (,setter ,g))))))
+
+(def expand=list (terms)
+ `(do ,@(map (fn ((p v)) (expand= p v)) ; [apply expand= _]
+ (pair terms))))
+
+(mac = args
+ (expand=list args))
+
+(mac loop (start test update . body)
+ (w/uniq (gfn gparm)
+ `(do ,start
+ ((rfn ,gfn (,gparm)
+ (if ,gparm
+ (do ,@body ,update (,gfn ,test))))
+ ,test))))
+
+(mac for (v init max . body)
+ (w/uniq (gi gm)
+ `(with (,v nil ,gi ,init ,gm (+ ,max 1))
+ (loop (set ,v ,gi) (< ,v ,gm) (set ,v (+ ,v 1))
+ ,@body))))
+
+(mac repeat (n . body)
+ `(for ,(uniq) 1 ,n ,@body))
+
+; could bind index instead of gensym
+
+(mac each (var expr . body)
+ (w/uniq (gseq g)
+ `(let ,gseq ,expr
+ (if (alist ,gseq)
+ ((afn (,g)
+ (when (acons ,g)
+ (let ,var (car ,g) ,@body)
+ (self (cdr ,g))))
+ ,gseq)
+ (isa ,gseq 'table)
+ (maptable (fn (,g ,var) ,@body)
+ ,gseq)
+ (for ,g 0 (- (len ,gseq) 1)
+ (let ,var (,gseq ,g) ,@body))))))
+
+; (nthcdr x y) = (subseq y x).
+
+(def subseq (seq start (o end (len seq)))
+ (if (isa seq 'string)
+ (let s2 (newstring (- end start))
+ (for i 0 (- end start 1)
+ (= (s2 i) (seq (+ start i))))
+ s2)
+ (firstn (- end start) (nthcdr start seq))))
+
+(mac ontable (k v h . body)
+ `(maptable (fn (,k ,v) ,@body) ,h))
+
+(mac whilet (var test . body)
+ (w/uniq (gf gp)
+ `((rfn ,gf (,gp)
+ (let ,var ,gp
+ (when ,var ,@body (,gf ,test))))
+ ,test)))
+
+(def last (seq)
+ (if (no (cdr seq))
+ (car seq)
+ (last (cdr seq))))
+
+(def rem (test seq)
+ (let f (testify test)
+ (if (alist seq)
+ ((afn (s)
+ (if (no s) nil
+ (f (car s)) (self (cdr s))
+ (cons (car s) (self (cdr s)))))
+ seq)
+ (coerce (rem test (coerce seq 'cons)) 'string))))
+
+(def keep (test seq)
+ (rem (complement (testify test)) seq))
+
+(def trues (f seq) (rem nil (map f seq)))
+
+(mac do1 args
+ (w/uniq g
+ `(let ,g ,(car args)
+ ,@(cdr args)
+ ,g)))
+
+; Would like to write a faster case based on table generated by a macro,
+; but can't insert objects into expansions in Mzscheme.
+
+(mac caselet (var expr . args)
+ (let ex (afn (args)
+ (if (no (cdr args))
+ (car args)
+ `(if (is ,var ',(car args))
+ ,(cadr args)
+ ,(self (cddr args)))))
+ `(let ,var ,expr ,(ex args))))
+
+(mac case (expr . args)
+ `(caselet ,(uniq) ,expr ,@args))
+
+(mac push (x place)
+ (w/uniq gx
+ (let (binds val setter) (setforms place)
+ `(let ,gx ,x
+ (atwiths ,binds
+ (,setter (cons ,gx ,val)))))))
+
+(mac swap (place1 place2)
+ (w/uniq (g1 g2)
+ (with ((binds1 val1 setter1) (setforms place1)
+ (binds2 val2 setter2) (setforms place2))
+ `(atwiths ,(+ binds1 (list g1 val1) binds2 (list g2 val2))
+ (,setter1 ,g2)
+ (,setter2 ,g1)))))
+
+(mac rotate places
+ (with (vars (map [uniq] places)
+ forms (map setforms places))
+ `(atwiths ,(mappend (fn (g (binds val setter))
+ (+ binds (list g val)))
+ vars
+ forms)
+ ,@(map (fn (g (binds val setter))
+ (list setter g))
+ (+ (cdr vars) (list (car vars)))
+ forms))))
+
+(mac pop (place)
+ (w/uniq g
+ (let (binds val setter) (setforms place)
+ `(atwiths ,(+ binds (list g val))
+ (do1 (car ,g)
+ (,setter (cdr ,g)))))))
+
+(def adjoin (x xs (o test iso))
+ (if (some [test x _] xs)
+ xs
+ (cons x xs)))
+
+(mac pushnew (x place . args)
+ (w/uniq gx
+ (let (binds val setter) (setforms place)
+ `(atwiths ,(+ (list gx x) binds)
+ (,setter (adjoin ,gx ,val ,@args))))))
+
+(mac pull (test place)
+ (w/uniq g
+ (let (binds val setter) (setforms place)
+ `(atwiths ,(+ (list g test) binds)
+ (,setter (rem ,g ,val))))))
+
+(mac ++ (place (o i 1))
+ (if (isa place 'sym)
+ `(= ,place (+ ,place ,i))
+ (w/uniq gi
+ (let (binds val setter) (setforms place)
+ `(atwiths ,(+ binds (list gi i))
+ (,setter (+ ,val ,gi)))))))
+
+(mac -- (place (o i 1))
+ (if (isa place 'sym)
+ `(= ,place (- ,place ,i))
+ (w/uniq gi
+ (let (binds val setter) (setforms place)
+ `(atwiths ,(+ binds (list gi i))
+ (,setter (- ,val ,gi)))))))
+
+; E.g. (inc x) equiv to (zap + x 1)
+
+(mac zap (op place . args)
+ (with (gop (uniq)
+ gargs (map [uniq] args)
+ mix (afn seqs
+ (if (some no seqs)
+ nil
+ (+ (map car seqs)
+ (apply self (map cdr seqs))))))
+ (let (binds val setter) (setforms place)
+ `(atwiths ,(+ binds (list gop op) (mix gargs args))
+ (,setter (,gop ,val ,@gargs))))))
+
+; Can't simply mod pr to print strings represented as lists of chars,
+; because empty string will get printed as nil. Would need to rep strings
+; as lists of chars annotated with 'string, and modify car and cdr to get
+; the rep of these. That would also require hacking the reader.
+
+;(def pr args
+; (if (isa (car args) 'output)
+; (do (error "stream arg!" args)
+; (map1 [disp _ (car args)] (cdr args))
+; (cadr args))
+; (do (map1 disp args)
+; (car args))))
+
+(def pr args
+ (map1 disp args)
+ (car args))
+
+; Rtm says this version should make the server 20% faster because map1
+; generates so much garbage; in fact makes slower; maybe rewrite map1?
+
+;(def newpr args
+; (if (isa (car args) 'output)
+; (do (each a (cdr args) (disp a (car args)))
+; (cadr args))
+; (do (each a args (disp a))
+; (car args))))
+
+(def prn args
+ (do1 (apply pr args)
+ (writec #\newline
+ (if (isa (car args) 'output) (car args) (stdout)))))
+
+(mac nil! args
+ `(do ,@(map (fn (a) `(= ,a nil)) args)))
+
+(mac t! args
+ `(do ,@(map (fn (a) `(= ,a t)) args)))
+
+; Destructing means ambiguity: are pat vars bound in else? (no)
+
+(mac iflet (var expr then . rest)
+ (w/uniq gv
+ `(let ,gv ,expr
+ (if ,gv (let ,var ,gv ,then) ,@rest))))
+
+(mac whenlet (var expr . body)
+ `(iflet ,var ,expr (do ,@body)))
+
+(mac aif (expr . body)
+ `(let it ,expr (if it ,@body)))
+
+(mac awhen (expr . body)
+ `(let it ,expr (if it (do ,@body))))
+
+(mac aand args
+ (if (no args)
+ 't
+ (no (cdr args))
+ (car args)
+ `(let it ,(car args) (and it (aand ,@(cdr args))))))
+
+(mac accum (accfn . body)
+ (w/uniq gacc
+ `(withs (,gacc nil ,accfn [push _ ,gacc])
+ ,@body
+ ,gacc)))
+
+; Repeatedly evaluates its body till it returns nil, then returns vals.
+
+(mac drain (expr (o eof nil))
+ (w/uniq (gacc gdone gres)
+ `(with (,gacc nil ,gdone nil)
+ (while (no ,gdone)
+ (let ,gres ,expr
+ (if (is ,gres ,eof)
+ (= ,gdone t)
+ (push ,gres ,gacc))))
+ (rev ,gacc))))
+
+; For the common C idiom while x = snarfdata != stopval.
+; Rename this if use it often.
+
+(mac whiler (var expr endval . body)
+ (w/uniq gf
+ `((rfn ,gf (,var)
+ (when (and ,var (no (is ,var ,endval)))
+ ,@body
+ (,gf ,expr)))
+ ,expr)))
+
+;(def macex (e)
+; (if (atom e)
+; e
+; (let op (and (atom (car e)) (eval (car e)))
+; (if (isa op 'mac)
+; (apply (rep op) (cdr e))
+; e))))
+
+(def consif (x y) (if x (cons x y) y))
+
+(def string args
+ (apply + "" (map [coerce _ 'string] args)))
+
+(def flat (x (o stringstoo))
+ ((rfn f (x acc)
+ (if (or (no x) (and stringstoo (is x "")))
+ acc
+ (and (atom x) (no (and stringstoo (isa x 'string))))
+ (cons x acc)
+ (f (car x) (f (cdr x) acc))))
+ x nil))
+
+; Perhaps not the final idea, or at least final name
+
+(mac default (x test alt)
+ (w/uniq gx
+ `(let ,gx ,x
+ (if (,test ,gx) ,gx ,alt))))
+
+(def pos (test seq (o start 0))
+ (let f (testify test)
+ (if (alist seq)
+ ((afn (seq n)
+ (if (no seq)
+ nil
+ (f (car seq))
+ n
+ (self (cdr seq) (+ n 1))))
+ (nthcdr start seq)
+ start)
+ (recstring [if (f (seq _)) _] seq start))))
+
+(def even (n) (is (mod n 2) 0))
+
+(def odd (n) (no (even n)))
+
+(mac after (x . ys)
+ `(protect (fn () ,x) (fn () ,@ys)))
+
+(let expander
+ (fn (f var name body)
+ `(let ,var (,f ,name)
+ (after (do ,@body) (close ,var))))
+
+ (mac w/infile (var name . body)
+ (expander 'infile var name body))
+
+ (mac w/outfile (var name . body)
+ (expander 'outfile var name body))
+
+ (mac w/instring (var str . body)
+ (expander 'instring var str body))
+ )
+
+(mac w/outstring (var . body)
+ `(let ,var (outstring) ,@body))
+
+(mac w/appendfile (var name . body)
+ `(let ,var (outfile ,name 'append)
+ (after (do ,@body) (close ,var))))
+
+; rename this simply "to"? - prob not; rarely use
+
+(mac w/stdout (str . body)
+ `(call-w/stdout ,str (fn () ,@body)))
+
+(mac w/stdin (str . body)
+ `(call-w/stdin ,str (fn () ,@body)))
+
+(mac tostring body
+ (w/uniq gv
+ `(w/outstring ,gv
+ (w/stdout ,gv ,@body)
+ (inside ,gv))))
+
+(mac fromstring (str . body)
+ (w/uniq gv
+ `(w/instring ,gv ,str
+ (w/stdin ,gv ,@body))))
+
+(def readstring1 (s (o eof nil)) (w/instring i s (read i eof)))
+
+(def read ((o x (stdin)) (o eof nil))
+ (if (isa x 'string) (readstring1 x eof) (sread x eof)))
+
+(def readfile (name) (w/infile s name (drain (read s))))
+
+(def readfile1 (name) (w/infile s name (read s)))
+
+(def writefile1 (val name) (w/outfile s name (write val s)) val)
+
+(def readall (src (o eof nil))
+ ((afn (i)
+ (let x (read i eof)
+ (if (is x eof)
+ nil
+ (cons x (self i)))))
+ (if (isa src 'string) (instring src) src)))
+
+(def sym (x) (coerce x 'sym))
+
+(mac rand-choice exprs
+ `(case (rand ,(len exprs))
+ ,@(let key -1
+ (mappend [list (++ key) _]
+ exprs))))
+
+(mac n-of (n expr)
+ (w/uniq ga
+ `(let ,ga nil
+ (repeat ,n (push ,expr ,ga))
+ (rev ,ga))))
+
+(def rand-string (n)
+ (with (cap (fn () (+ 65 (rand 26)))
+ sm (fn () (+ 97 (rand 26)))
+ dig (fn () (+ 48 (rand 10))))
+ (coerce (map [coerce _ 'char]
+ (cons (rand-choice (cap) (sm))
+ (n-of (- n 1) (rand-choice (cap) (sm) (dig)))))
+ 'string)))
+
+(mac forlen (var s . body)
+ `(for ,var 0 (- (len ,s) 1) ,@body))
+
+(mac on (var s . body)
+ (if (is var 'index)
+ (err "Can't use index as first arg to on.")
+ (w/uniq gs
+ `(let ,gs ,s
+ (forlen index ,gs
+ (let ,var (,gs index)
+ ,@body))))))
+
+(def best (f seq)
+ (if (no seq)
+ nil
+ (let wins (car seq)
+ (each elt (cdr seq)
+ (if (f elt wins) (= wins elt)))
+ wins)))
+
+(def max args (best > args))
+(def min args (best < args))
+
+; (mac max2 (x y)
+; (w/uniq (a b)
+; `(with (,a ,x ,b ,y) (if (> ,a ,b) ,a ,b))))
+
+(def most (f seq)
+ (unless (no seq)
+ (withs (wins (car seq) topscore (f wins))
+ (each elt (cdr seq)
+ (let score (f elt)
+ (if (> score topscore) (= wins elt topscore score))))
+ wins)))
+
+; Insert so that list remains sorted. Don't really want to expose
+; these but seem to have to because can't include a fn obj in a
+; macroexpansion.
+
+(def insert-sorted (test elt seq)
+ (if (no seq)
+ (list elt)
+ (test elt (car seq))
+ (cons elt seq)
+ (cons (car seq) (insert-sorted test elt (cdr seq)))))
+
+(mac insort (test elt seq)
+ `(zap [insert-sorted ,test ,elt _] ,seq))
+
+(def reinsert-sorted (test elt seq)
+ (if (no seq)
+ (list elt)
+ (is elt (car seq))
+ (reinsert-sorted test elt (cdr seq))
+ (test elt (car seq))
+ (cons elt (rem elt seq))
+ (cons (car seq) (reinsert-sorted test elt (cdr seq)))))
+
+(mac insortnew (test elt seq)
+ `(zap [reinsert-sorted ,test ,elt _] ,seq))
+
+; Could make this look at the sig of f and return a fn that took the
+; right no of args and didn't have to call apply (or list if 1 arg).
+
+(def memo (f)
+ (let cache (table)
+ (fn args
+ (or (cache args)
+ (= (cache args) (apply f args))))))
+
+(mac defmemo (name parms . body)
+ `(safeset ,name (memo (fn ,parms ,@body))))
+
+(def <= args
+ (or (no args)
+ (no (cdr args))
+ (and (no (> (car args) (cadr args)))
+ (apply <= (cdr args)))))
+
+(def >= args
+ (or (no args)
+ (no (cdr args))
+ (and (no (< (car args) (cadr args)))
+ (apply >= (cdr args)))))
+
+(def whitec (c)
+ (in c #\space #\newline #\tab #\return))
+
+(def nonwhite (c) (no (whitec c)))
+
+(def alphadig (c)
+ (or (<= #\a c #\z) (<= #\A c #\Z) (<= #\0 c #\9)))
+
+(def punc (c)
+ (in c #\. #\, #\; #\: #\! #\?))
+
+(def readline ((o str (stdin)))
+ (awhen (readc str)
+ (tostring
+ (writec it)
+ (whiler c (readc str) #\newline
+ (writec c)))))
+
+; Don't currently use this but suspect some code could.
+
+(mac summing (sumfn . body)
+ (w/uniq (gc gt)
+ `(let ,gc 0
+ (let ,sumfn (fn (,gt) (if ,gt (++ ,gc)))
+ ,@body)
+ ,gc)))
+
+(def trav (f base tree)
+ (if (atom tree)
+ (base tree)
+ (f (trav f base (car tree)) (trav f base (cdr tree)))))
+
+(def carif (x) (if (atom x) x (car x)))
+
+; Could prob be generalized beyond printing.
+
+(def prall (elts (o init "") (o sep ", "))
+ (when elts
+ (pr init (car elts))
+ (map [pr sep _] (cdr elts))
+ elts))
+
+(def prs args
+ (prall args "" #\space))
+
+(def tree-subst (old new tree)
+ (if (is tree old)
+ new
+ (atom tree)
+ tree
+ (cons (tree-subst old new (car tree))
+ (tree-subst old new (cdr tree)))))
+
+(def ontree (f tree)
+ (f tree)
+ (unless (atom tree)
+ (ontree f (car tree))
+ (ontree f (cdr tree))))
+
+(def dotted (x)
+ (if (atom x)
+ nil
+ (and (cdr x) (or (atom (cdr x))
+ (dotted (cdr x))))))
+
+(def fill-table (table data)
+ (each (k v) (pair data) (= (table k) v))
+ table)
+
+(mac obj args
+ (w/uniq g
+ `(let ,g (table)
+ ,@(map (fn ((k v)) `(= (,g ',k) ,v))
+ (pair args))
+ ,g)))
+
+(def keys (h)
+ (accum a (ontable k v h (a k))))
+
+(def vals (h)
+ (accum a (ontable k v h (a v))))
+
+; These two should really be done by coerce. Wrap coerce?
+
+(def tablist (h)
+ (accum a (maptable (fn args (a args)) h)))
+
+(def listtab (al)
+ (let h (table)
+ (map (fn ((k v)) (= (h k) v))
+ al)
+ h))
+
+(def load-table (file (o eof))
+ (w/infile i file (read-table i eof)))
+
+(def read-table ((o i (stdin)) (o eof))
+ (let e (read i eof)
+ (if (alist e) (listtab e) e)))
+
+(def load-tables (file)
+ (w/infile i file
+ (w/uniq eof
+ (drain (read-table i eof) eof))))
+
+(def save-table (h file)
+ (w/outfile o file (write-table h o)))
+
+(def write-table (h (o o (stdout)))
+ (write (tablist h) o))
+
+(def copy (x)
+ (case (type x)
+ sym x
+ cons (apply (fn args args) x)
+ string (let new (newstring (len x))
+ (forlen i x
+ (= (new i) (x i)))
+ new)
+ table (let new (table)
+ (ontable k v x
+ (= (new k) v))
+ new)
+ (err "Can't copy " x)))
+
+(def abs (n)
+ (if (< n 0) (- n) n))
+
+; The problem with returning a list instead of multiple values is that
+; you can't act as if the fn didn't return multiple vals in cases where
+; you only want the first. Not a big problem.
+
+(def round (n)
+ (withs (base (truncate n) rem (abs (- n base)))
+ (if (> rem 1/2) ((if (> n 0) + -) base 1)
+ (< rem 1/2) base
+ (odd base) ((if (> n 0) + -) base 1)
+ base)))
+
+(def roundup (n)
+ (withs (base (truncate n) rem (abs (- n base)))
+ (if (>= rem 1/2)
+ ((if (> n 0) + -) base 1)
+ base)))
+
+(def to-nearest (n quantum)
+ (* (roundup (/ n quantum)) quantum))
+
+(def avg (ns) (/ (apply + ns) (len ns)))
+
+; Use mergesort on assumption that mostly sorting mostly sorted lists
+; benchmark: (let td (n-of 10000 (rand 100)) (time (sort < td)) 1)
+
+(def sort (test seq)
+ (if (alist seq)
+ (mergesort test (copy seq))
+ (coerce (mergesort test (coerce seq 'cons)) (type seq))))
+
+; Destructive stable merge-sort, adapted from slib and improved
+; by Eli Barzilay for MzLib; re-written in Arc.
+
+(def mergesort (less? lst)
+ (with (n (len lst))
+ (if (<= n 1) lst
+ ; ; check if the list is already sorted
+ ; ; (which can be a common case, eg, directory lists).
+ ; (let loop ([last (car lst)] [next (cdr lst)])
+ ; (or (null? next)