diff --git a/arc-f/.gitignore b/arc-f/.gitignore new file mode 100644 index 000000000..fd9172f7b --- /dev/null +++ b/arc-f/.gitignore @@ -0,0 +1 @@ +arc.arc.scm diff --git a/arc-f/ac.scm b/arc-f/ac.scm new file mode 100644 index 000000000..69eebac3e --- /dev/null +++ b/arc-f/ac.scm @@ -0,0 +1,2286 @@ +; 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")) +(require (lib "file.ss")) + +; 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))) + +;----packages +(define axioms-package + ; t and nil are no longer symbols, primarily + ; because t and nil don't look + ; nice. The (coerce "t" 'sym) becomes <>t + '(o ; needed for (fn (some (o foo bar)) ...) + fn + compose ; because of (foo:bar) -> (foo (bar)) conversion + set + quote + quasiquote + unquote + unquote-splicing + if + symeval)) + +(define (make-package name) + (let ((symbol-map (make-hash-table 'equal))) + ; axioms-package is a scheme list + (for-each + (lambda (s) + (hash-table-put! symbol-map (unpackaged-symbol s) s)) + axioms-package) + (vector 'package + ; mapping: unpackaged symbol -> symbol + symbol-map + ; mapping: packaged interface symbol -> list of interface members + (make-hash-table 'equal) + ; package-name + name))) + +(define (package? x) + (and (vector? x) (eq? 'package (vector-ref x 0)))) + +(define (package-name pkg) + (vector-ref pkg 3)) + +; mapping: package name symbol -> package object +(define packages + (make-hash-table 'equal)) + +(define rex-is-package (regexp "^<([^>]*)>(.*)$")) + +(define (packaged-string? str) + (let ((rv (regexp-match rex-is-package str))) + (if rv + (if (equal? (cadr rv) "") + #f + #t) + #f))) + +(define (packaged-symbol? sym) + (packaged-string? (symbol->string sym))) + +(define (unpackaged-symbol sym) + (let* ((ss (symbol->string sym)) + (pm (regexp-match rex-is-package ss))) + (if pm + (let ((rv (string->symbol (caddr pm)))) + (cond + ((eq? rv 't) '<>t) + ((eq? rv 'nil) '<>nil) + (#t rv))) + sym))) + +(define (ar-symbol->string s) + (cond + ((eq? s '<>t) "t") + ((eq? s '<>nil) "nil") + (#t (symbol->string s)))) + +(define (package-of sym) + (let ((rv (regexp-match rex-is-package (symbol->string sym)))) + (if (and rv (not (eqv? "" (cadr rv)))) + (cadr rv) + 'nil))) + +(define (read-from-string str) + (let ((port '()) + (rd '())) + ; protect with dynamic-wind + ; in case of reader error + (dynamic-wind + (lambda () + (set! port (open-input-string str))) + (lambda () + (set! rd (read port))) + (lambda () + (close-input-port port))) + rd)) + +(define (canonicalize-symbol sym) + (let* ((ss (symbol->string sym)) + (pm (regexp-match rex-is-package ss))) + (if pm + ;check package + (let ((pak (cadr pm)) + (unpak (caddr pm))) + (cond + ; <>t and <>nil are allowed to have + ; an explicitly empty package + ; <>t != t, <>nil != nil + ((or (equal? unpak "t") (equal? unpak "nil")) + sym) + ; unpackaged symbols belong to + ; the empty package: <>x == x + ((equal? pak "") + (string->symbol unpak)) + (#t + sym))) + ; no special markings + sym))) + +(define (canonicalize-all ex) + (cond + ;((ssyntax? ex) + ; (canonicalize-all (expand-ssyntax ex))) + ((symbol? ex) + (canonicalize-symbol ex)) + ((pair? ex) + (set-car! ex (canonicalize-all (car ex))) + (set-cdr! ex (canonicalize-all (cdr ex))) + ex) + ((or (eq? ex '()) (eq? ex #f)) + 'nil) + ((eq? ex #t) + 't) + ((hash-table? ex) + (hash-table-for-each ex + (lambda (k v) + (hash-table-put! ex k + (canonicalize-all v)))) + ex) + ; included just for completeness, this + ; is otherwise quite stupid of us + ((vector? ex) + (canonicalize-vector ex 0 (vector-length ex)) + ex) + (#t + ex))) + +; can't remember do notation off-hand +(define (canonicalize-vector vec i l) + (if (< i l) + (begin + (vector-set! vec i (canonicalize-all (vector-ref vec i))) + (canonicalize-vector vec (+ i 1) l)))) + +(define (ar-read . opt) + (let* ((port + (if (eq? opt '()) + (current-input-port) + (car opt))) + (rd (read port))) + (canonicalize-all rd))) + +(define invalid-package-name (regexp ">")) + +(define (the-package str) + (if (string? str) + (if (or (packaged-string? str) + (regexp-match invalid-package-name str)) + #f + (hash-table-get packages (string->symbol str) + (lambda () + (let ((pak (make-package str))) + (hash-table-put! packages (string->symbol str) + pak) + pak)))) + #f)) + +(define (package-ref pkg sym) + (if (ar-symbol? sym) + (if (packaged-symbol? sym) + sym + (let ((tb (vector-ref pkg 1))) + (hash-table-get tb sym + (lambda () + (let ((generated-sym + (string->symbol + (string-append + "<" + (package-name pkg) + ">" + (ar-symbol->string sym))))) + (hash-table-put! tb sym + generated-sym) + generated-sym))))) + sym)) + +(define (package-sref pkg packaged unpackaged) + (let ((symbol-map (vector-ref pkg 1))) + (hash-table-put! + symbol-map unpackaged packaged) + packaged)) + +(define (interface-of-package pkg sym) + (hash-table-get (interface-table-of-package pkg) sym + (lambda () + #f))) + +(define (interface-table-of-package pkg) + (vector-ref pkg 2)) + +(define (interface-lookup sym) + (let* ((pm (regexp-match rex-is-package (ar-symbol->string sym))) + (pak (if pm (cadr pm) + (error "interface lookup expected packaged symbol"))) + (pkg (the-package pak))) + (interface-of-package pkg sym))) + +(define (make-context) + (vector 'context (the-package "User"))) + +(define (context? x) + (and (vector? x) (eq? 'context (vector-ref x 0)))) + +(define (context-ref-reuse! cxt ex) + (cond + ((pair? ex) + (let ((head (car ex))) + (if (context-metacommand? head) + (context-ref cxt ex) + (begin + (set-car! ex (context-ref-reuse-inner! cxt (car ex))) + (set-cdr! ex (context-ref-reuse-inner! cxt (cdr ex))) + ex)))) + (#t + (context-ref-reuse-inner! cxt ex)))) +(define (context-ref-reuse-inner! cxt ex) + (cond + ((ar-symbol? ex) + (if (ssyntax? ex) + (context-ref-reuse-inner! cxt (expand-ssyntax ex)) + (package-ref (package-of-context cxt) ex))) + ((pair? ex) + (set-car! ex (context-ref-reuse-inner! cxt (car ex))) + (set-cdr! ex (context-ref-reuse-inner! cxt (cdr ex))) + ex) + (#t + ex))) + +(define (context-metacommand? head) + (or (eq? head 'in-package) + (eq? head 'using) + (eq? head 'import) + (eq? head 'interface) + ; TODO + (eq? head 'interface-ssyntax) + (eq? head 'import-ssyntax))) + +; TODO: make ssyntax functions based on the package +; in the context. + +(define (context-metacommand-compile cxt expr) + (let ((head (car expr))) + (cond + ((eq? head 'in-package) + '__t) + ((eq? head 'using) + `(let ((cxt (make-context))) + (context-ref cxt '(in-package ,(string->symbol + (package-name + (package-of-context cxt))))) + (context-ref cxt '(using ,(cadr expr))) + __t)) + ((eq? head 'interface) + (let* ((pkg (package-of-context cxt)) + (parms + (arc-map + (lambda (a) + (if (pair? a) + (arc-map (lambda (a) + (package-ref pkg a))) + (package-ref pkg a))) + (cdr expr)))) + `(let ((cxt (make-context))) + (context-ref cxt '(interface ,@parms))))) + ((eq? head 'import) + `(package-sref (the-package ,(package-name (package-of-context cxt))) + ,@(cdr expr)))))) + ; TODO: interface-ssyntax, import-ssyntax + +(define (context-ref cxt ex) + (cond + ((pair? ex) + (let ((head (car ex))) + (cond + ; (in-package package) + ((eq? head 'in-package) + ; syntax check + (if (not (pair? (cdr ex))) + (error "'in-package expects one parameter")) + (if (not (ar-false? (cddr ex))) + (error "'in-package expects at most one parameter")) + (if (or (not (ar-symbol? (cadr ex))) + (packaged-symbol? (cadr ex))) + (error "'in-package expects an unpackaged symbol")) + (let ((pkg-str (ar-symbol->string (cadr ex)))) + (package-of-context-set! cxt (the-package pkg-str)) + 't)) + ; (using interface) + ((eq? head 'using) + ; syntax check + (if (not (pair? (cdr ex))) + (error "'using expects one parameter")) + (if (not (ar-false? (cddr ex))) + (error "'using expects at most one parameter")) + (if (or (not (ar-symbol? (cadr ex))) + (not (packaged-symbol? (cadr ex)))) + (error "'using expects a packaged symbol")) + (let* ((sym (cadr ex)) + (ss (symbol->string sym)) + (pm (regexp-match rex-is-package ss)) + (pak (cadr pm)) + (pkg (the-package pak)) + (int-list (interface-of-package pkg sym))) + ; if package interface doesn't exist, try + ; 'require-ing it. + (if (not int-list) + (if (namespace-variable-value '__require + #t + (lambda () #f)) + (let ((f-path + (load-resolve (string-append pak ".arc")))) + (if f-path + (begin + (ar-funcall1 (eval '__require) + f-path) + (set! int-list (interface-of-package pkg sym))))))) + ; check if package interface *still* doesn't exist + (if (not int-list) + (error "Package interface does not exist: " ss)) + (let ((dest-pkg (package-of-context cxt))) + ; int-list is from arc + (arc-for-each + (lambda (s) + (package-sref dest-pkg s (unpackaged-symbol s))) + int-list)) + 't)) + ((eq? head 'import) + ; syntax check + (if (or (not (pair? (cdr ex))) + (not (pair? (cddr ex))) + (not (ar-false? (cdddr ex)))) + (error "'import expects two parameters")) + (if (not (packaged-symbol? (cadr ex))) + (error "first parameter to 'import should be packaged symbol")) + (if (packaged-symbol? (caddr ex)) + (error "second parameter to 'import should be unpackaged symbol")) + (package-sref (package-of-context cxt) (cadr ex) (caddr ex)) + 't) + ; (interface symbol + ; symbol (symbol-to-remove) included-interface) + ((eq? head 'interface) + (let* ((dest-pkg (package-of-context cxt)) + (interface '()) + (int-tl '()) + (add-int + (lambda (np) + (if (eq? interface '()) + (begin + (set! interface (list np)) + (set! int-tl interface)) + (begin + (set-cdr! int-tl (list np)) + (set! int-tl (cdr int-tl)))))) + (find + ; I'd implement this as 'afn instead of using 'ccc, + ; but then scheme doesn't have 'afn T.T + (lambda (i l) + (call/cc + (lambda (return) + ; np is from arc + (arc-for-each + (lambda (ii) + (if (eq? i ii) (return #t))) + l) + (return #f))))) + (remove + (lambda (np) + (let ((tmp interface)) + (set! interface '()) + (set! int-tl '()) + ; tmp is the interface, which is + ; a scheme list + (for-each + (lambda (e) + ; lookup in current package + (let ((sym (package-ref dest-pkg e))) + (if (not (find sym np)) + (add-int sym)))) + tmp)))) + (int-name + (if (and (pair? (cdr ex)) (ar-symbol? (cadr ex))) + (package-ref dest-pkg (cadr ex)) + (error "'interface expects a symbol for interface name"))) + (params + (arc-map + (lambda (p) + (if (and (not (ar-symbol? p)) (pair? p)) + (error "'interface expects a list of symbols or removed symbols")) + (cond + ((pair? p) + (arc-map + (lambda (p) + (if (not (ar-symbol? p)) + (error "'interface expects symbols in removed list")) + (package-ref dest-pkg p)) + p)) + (#t + (package-ref dest-pkg p)))) + (cddr ex))) + (int-table (interface-table-of-package + (the-package (package-of int-name))))) + ; params are from arc + (arc-for-each + (lambda (p) + (if (pair? p) + (remove p) + ; look them up in the current package first + (let* ((sym (package-ref dest-pkg p)) + ; check if there is an interface + ; with that name, and include if so + (int (interface-lookup sym))) + (if int + ; interfaces are scheme lists + (for-each + (lambda (e) + (add-int e)) + int) + (add-int sym))))) + params) + (hash-table-put! int-table int-name + interface) + 't)) + ;reserved + ((or (eq? head 'interface-ssyntax) (eq? head 'import-ssyntax)) + (err "The 'interface-ssyntax and 'import-ssyntax contexter metacommands are reserved for future Arc3F revisions")) + (#t + (arc-map (lambda (x) (context-ref-inner cxt x)) + ex))))) + (#t (context-ref-inner cxt ex)))) + +(define (context-ref-inner cxt x) + (cond + ((ar-symbol? x) + (if (ssyntax? x) + (context-ref-reuse-inner! cxt (expand-ssyntax x)) + (package-ref (package-of-context cxt) x))) + ((pair? x) + (cons (context-ref-inner cxt (car x)) + (context-ref-inner cxt (cdr x)))) + (#t + x))) + +(define (arc-map fn l) + (if (ar-false? l) + 'nil + (let ((rv (list (fn (car l))))) + (arc-map-inner fn (cdr l) rv rv)))) +(define (arc-map-inner fn l hd tl) + (if (ar-false? l) + hd + (begin + (set-cdr! tl (list (fn (car l)))) + (arc-map-inner fn (cdr l) hd (cdr tl))))) + +(define (arc-for-each fn l) + (if (ar-false? l) 'nil + (begin + (fn (car l)) + (arc-for-each fn (cdr l))))) + +(define (package-of-context cxt) + (vector-ref cxt 1)) +(define (package-of-context-set! cxt pkg) + (vector-set! cxt 1 pkg)) + +(define (ar-symbol? p) + (and (symbol? p) (not (eq? p 'nil)) (not (eq? p 't)))) + +;----packages end +;above used to be separate file, but then we started +;needing quite a bit from ac.scm T.T + + +; 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) + (set! s (ac-denil s)) + (let ((head (xcar s))) + (cond ((string? s) (string-copy s)) ; to avoid immutable strings + ((literal? s) s) + ((eqv? s 'nil) (list 'quote 'nil)) + ((symbol? s) (ac-var-ref s env)) + ((eq? head 'quote) (list 'quote (ac-niltree (cadr s)))) + ((eq? head 'quasiquote) (ac-qq (cadr s) env)) + ((eq? head 'if) (ac-if (cdr s) env)) + ((eq? head 'fn) (ac-fn (cadr s) (cddr s) env)) + ((eq? head 'set) (ac-set (cdr s) env)) + ((eq? head 'symeval) (ac-symeval (cdr s) env)) + ; this line could be removed without changing semantics + ((eq? (xcar head) 'compose) (ac (decompose (cdar s) (cdr s)) env)) + ((pair? s) (ac-call (car s) (cdr s) env)) + ((eof-object? s) (exit)) + (#t (err "Bad object in expression" s))))) + +(define *defs* (make-hash-table)) + +(define (literal? x) + (or (boolean? x) + (char? x) + (string? x) + (number? x) + (ar-procedure? x) ; to allow (eval `(,+ 3 4)) + (eq? x '()))) + +(define (ssyntax? x) + (default-ssyntax? x)) +(define (expand-ssyntax sym) + (ac-denil (default-expand-ssyntax sym))) + +(define (default-ssyntax? x) + (and (ar-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 #\~) (eqv? c #\.) (eqv? c #\!))) + (has-ssyntax-char? string (- i 1))))) + +(define (default-expand-ssyntax sym) + ((cond ((or (insym? #\: sym) (insym? #\~ sym)) expand-compose) + ((or (insym? #\. sym) (insym? #\! sym)) expand-sexpr) + (#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-sexpr sym) + (build-sexpr (tokens (lambda (c) (or (eqv? c #\.) (eqv? c #\!))) + (symbol->chars sym) + '() + '() + #t))) + +; no error-checking! + +(define (build-sexpr toks) + (cond ((null? toks) + '()) + ((eqv? (car toks) #\.) + (cons (chars->value (cadr toks)) + (build-sexpr (cddr toks)))) + ((eqv? (car toks) #\!) + (cons (list 'quote (chars->value (cadr toks))) + (build-sexpr (cddr toks)))) + (#t + (cons (chars->value (car toks)) + (build-sexpr (cdr 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))) + +; result will contain || if separator at end of symbol; could use +; that to mean something + +(define (tokens test source token acc keepsep?) + (cond ((null? source) + (reverse (cons (reverse token) acc))) + ((test (car source)) + (tokens test + (cdr source) + '() + (let ((rec (cons (reverse token) acc))) + (if keepsep? + (cons (car source) rec) + rec)) + keepsep?)) + (#t + (tokens test + (cdr source) + (cons (car source) token) + acc + keepsep?)))) + +; 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) + (if (equal? s (string->symbol (symbol->string s))) + (string->symbol (string-append "__" (symbol->string s))) + 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)) + ((eqv? (xcar x) 'unquote) + (list 'unquote (ac-qq1 (- level 1) (cadr x) env))) + ((and (eqv? (xcar x) 'unquote-splicing) (= level 1)) + (list 'unquote-splicing + (list 'ar-nil-terminate (ac-qq1 (- level 1) (cadr x) env)))) + ((eqv? (xcar x) 'quasiquote) + (list 'quasiquote (ac-qq1 (+ level 1) (cadr x) env))) + ((pair? x) + (let ((t (lambda (f) (ac-qq1 level (f x) env)))) + (cons (t car) (t cdr)))) + (#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)) + ,@(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) + ((symbol? (xcar 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 (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)) (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 + `(begin + (namespace-set-variable-value! ',(ac-global-name a) ,name) + (hash-table-put! *defs* ',(ac-global-name a) ',b)))) + name)) + (err "First arg to set must be a symbol" a))) + +(define (ac-symeval xs env) + (cond + ((ar-false? xs) + (err "'symeval accepts exactly one parameter, given " xs)) + ((ar-false? (cdr xs)) + (let ((x (car xs))) + ; compile away symeval if (symeval 'global) form + (if (and (pair? x) (eq? (car x) 'quote) + (pair? (cdr x)) (ar-false? (cddr x)) + (ar-symbol? (cadr x)) ) + (ac-global-name (cadr x)) + `(symeval ,(ac x env))))) + (#t + (err "'symeval accepts exactly one parameter, none given")))) + +; 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 (ar-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) + (let ((m (ac-macro? (xcar e)))) + (if m + (let ((expansion (ac-denil (ar-apply m (map ac-niltree (cdr e)))))) + (if (null? once) (ac-macex expansion) expansion)) + 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 arc-package-cxt + (let ((rv (make-context))) + (context-ref rv '(in-package arc)) + rv)) + +(define (xdef a b) + (namespace-set-variable-value! + (ac-global-name + (context-ref-reuse! arc-package-cxt 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)) + +#| + (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. + +; There are 6 types of Arc functions: +; 1. compiled directly to scheme (generic/non-method functions) +; 2. monomethods (dispatch on first parameter only) +; - implement as flat tables on the type +; 3. multimethods (more complex dispatch) +; - implement as nested tables on the type +; 4. reductors (left, right, or truth reduction) +; - implement as vectors containing the functions +; to execute +; 5. composers (two functions tied input-to-output) +; - implement as a vector containing the functions +; to compose +; 6. clojure-style multimethods (very generalized +; dispatch) +; - implement as pair of dispatcher function +; and dispatch table + +(define (ar-procedure? fn) + (or (procedure? fn) (monomethod? fn) (multimethod? fn) + (reductor? fn) (composer? fn) (clojure-method? fn))) + +(define (ar-get-call) + (let ((rv (eval '__call*))) + (if (ar-procedure? rv) + rv + (err "call* must be a true function")))) + +(define (ar-apply fn args) + (cond + ((procedure? fn) + (apply fn args)) + ((monomethod? fn) + (ar-apply (monomethod-lookup fn (car args)) args)) + ((multimethod? fn) + (ar-apply (multimethod-lookup fn args) args)) + ((reductor? fn) + (reductor-apply fn args)) + ((composer? fn) + (ar-funcall1 (composer-fl fn) (ar-apply (composer-fr fn) args))) + ((clojure-method? fn) + (clojure-method-apply fn args)) + (#t + (ar-apply (ar-get-call) (cons fn args))))) + +(xdef 'apply (lambda (fn . args) + (ar-apply fn (ar-apply-args args)))) + +(define (ar-f2-to-lambda f2) + (if (procedure? f2) + f2 + (lambda (a b) (ar-funcall2 f2 a b)))) + +; special cases of ar-apply for speed and to avoid consing arg lists +(define (ar-funcall0 fn) + (cond + ((procedure? fn) + (fn)) + ; monomethods and multimethods dispatch on at least one argument... + ((or (monomethod? fn) (multimethod? fn)) + ; get the generic + (ar-funcall0 (vector-ref fn 2))) + ((reductor? fn) + (ar-funcall0 (reductor-f0 fn))) + ((composer? fn) + (ar-funcall1 (composer-fl fn) (ar-funcall0 (composer-fr fn)))) + ((clojure-method? fn) + (ar-funcall0 + (clojure-method-lookup fn + (ar-funcall0 + (clojure-method-dispatch-fn fn))))) + (#t + ; note that we have inserted an argument... + (ar-funcall1 (ar-get-call) fn)))) + +(define (ar-funcall1 fn arg1) + (cond + ((procedure? fn) + (fn arg1)) + ((monomethod? fn) + (ar-funcall1 (monomethod-lookup fn arg1) arg1)) + ((multimethod? fn) + (ar-funcall1 (multimethod-lookup fn (list arg1)) arg1)) + ((reductor? fn) + (ar-funcall1 (reductor-f1 fn) arg1)) + ((composer? fn) + (ar-funcall1 (composer-fl fn) (ar-funcall1 (composer-fr fn) arg1))) + ((clojure-method? fn) + (ar-funcall1 + (clojure-method-lookup fn + (ar-funcall1 + (clojure-method-dispatch-fn fn) + arg1)) + arg1)) + (#t + (ar-funcall2 (ar-get-call) fn arg1)))) + +(define (ar-funcall2 fn arg1 arg2) + (cond + ((procedure? fn) + (fn arg1 arg2)) + ((monomethod? fn) + (ar-funcall2 (monomethod-lookup fn arg1) arg1 arg2)) + ((multimethod? fn) + (ar-funcall2 (multimethod-lookup fn (list arg1 arg2)) arg1 arg2)) + ((reductor? fn) + (ar-funcall2 (reductor-f2 fn) arg1 arg2)) + ((composer? fn) + (ar-funcall1 (composer-fl fn) (ar-funcall2 (composer-fr fn) arg1 arg2))) + ((clojure-method? fn) + (ar-funcall2 + (clojure-method-lookup fn + (ar-funcall2 + (clojure-method-dispatch-fn fn) + arg1 + arg2)) + arg1 + arg2)) + (#t + (ar-funcall3 (ar-get-call) fn arg1 arg2)))) + +(define (ar-funcall3 fn arg1 arg2 arg3) + (cond + ((procedure? fn) + (fn arg1 arg2 arg3)) + ((monomethod? fn) + (ar-funcall3 (monomethod-lookup fn arg1) arg1 arg2 arg3)) + ((multimethod? fn) + (ar-funcall3 (multimethod-lookup fn (list arg1 arg2 arg3)) arg1 arg2 arg3)) + ((l-reductor? fn) + (let ((f2 (ar-f2-to-lambda (reductor-f2 fn)))) + (f2 (f2 arg1 arg2) arg3))) + ((r-reductor? fn) + (let ((f2 (ar-f2-to-lambda (reductor-f2 fn)))) + (f2 arg1 (f2 arg2 arg3)))) + ((t-reductor? fn) + (let ((f2 (ar-f2-to-lambda (reductor-f2 fn)))) + (if (ar-false? (f2 arg1 arg2)) + 'nil + (f2 arg2 arg3)))) + ((composer? fn) + (ar-funcall1 (composer-fl fn) + (ar-funcall3 (composer-fr fn) arg1 arg2 arg3))) + ((clojure-method? fn) + (ar-funcall3 + (clojure-method-lookup fn + (ar-funcall3 + (clojure-method-dispatch-fn fn) + arg1 + arg2 + arg3)) + arg1 + arg2 + arg3)) + (#t + (ar-funcall4 (ar-get-call) fn arg1 arg2)))) + +(define (ar-funcall4 fn arg1 arg2 arg3 arg4) + (cond + ((procedure? fn) + (fn arg1 arg2 arg3 arg4)) + ((monomethod? fn) + (ar-funcall4 (monomethod-lookup fn arg1) arg1 arg2 arg3 arg4)) + ((multimethod? fn) + (ar-funcall4 (multimethod-lookup fn (list arg1 arg2 arg3 arg4)) arg1 arg2 arg3 arg4)) + ; mzscheme 372 mysteriously segfaults on compiling + ; this module if we don't compute return values + ; individually + ((l-reductor? fn) + (let* ((f2 (ar-f2-to-lambda (reductor-f2 fn))) + (r1 (f2 arg1 arg2)) + (r2 (f2 r1 arg3))) + (f2 r2 arg4))) + ((r-reductor? fn) + (let* ((f2 (ar-f2-to-lambda (reductor-f2 fn))) + (r1 (f2 arg3 arg4)) + (r2 (f2 arg2 r1 ))) + (f2 arg1 r2))) + ((t-reductor? fn) + (let ((f2 (ar-f2-to-lambda (reductor-f2 fn)))) + (if (ar-false? (f2 arg1 arg2)) + 'nil + (if (ar-false? (f2 arg2 arg3)) + 'nil + (f2 arg3 arg4))))) + ((composer? fn) + (ar-funcall1 (composer-fl fn) + (ar-funcall4 (composer-fr fn) arg1 arg2 arg3 arg4))) + ((clojure-method? fn) + (ar-funcall4 + (clojure-method-lookup fn + (ar-funcall4 + (clojure-method-dispatch-fn fn) + arg1 + arg2 + arg3 + arg4)) + arg1 + arg2 + arg3 + arg4)) + (#t + (ar-apply (ar-get-call) (list fn arg1 arg2 arg3 arg4))))) + +; monomethod definition +(define (monomethod? f) + (and (vector? f) (eq? (vector-ref f 0) 'monomethod))) + +(define (ar-monomethod hash generic) + (vector 'monomethod hash generic)) + +(define (monomethod-lookup f arg) + (hash-table-get (vector-ref f 1) (ar-type arg) (lambda () (vector-ref f 2)))) + +; multimethod definition +; TODO: true CLOS-style generic multimethods + +(define (multimethod? f) + (and (vector? f) (eq? (vector-ref f 0) 'multimethod))) + +(define (multimethod tb gen) + (vector 'multimethod tb gen)) + +(define (multimethod-subtable? tb) + (and (vector? tb) (eq? (vector-ref tb 0) 'multimethod-subtable))) + +(define (multimethod-subtable tb) + (vector 'multimethod-subtable tb)) + +(define (multimethod-from-generic lt spec gen) + (err "multimethods not yet implemented!") + (let ((tb (multimethod-subtable-nested lt spec))) + (multimethod + (multimethod-subtable tb) gen))) + +(define (multimethod-subtable-nested lt spec) + (if (eq? lt '()) + (spec) + (let ((rv (make-hash-table 'equal))) + (hash-table-put! + rv (car lt) (multimethod-subtable-nested (cdr lt) spec)) + rv))) + +(define (multimethod-lookup method args) + ; destructure + (let ((gen (vector-ref method 2)) + (subtb (vector-ref method 1))) + (multimethod-subtable-lookup subtb () args))) + +(define (multimethod-subtable-lookup subtb default-fn args) + (let ((on-fail + (lambda () + (hash-table-get subtb 'nil + default-fn)))) + (if (multimethod-subtable? subtb) + (multimethod-subtable-lookup + (hash-table-get subtb (car (ar-type args)) + on-fail) + on-fail + (cdr args)) + subtb))) + +(define (multimethod-add method lt spec) + (err "multimethods not yet implemented!")) + +(define (multimethod-from-monomethod mono) + (err "multimethods not yet implemented!")) + +;reductor + +(define (reductor? f) + (or (l-reductor? f) (r-reductor? f) (t-reductor? f))) + +(define (reductor-f0 f) + (vector-ref f 1)) + +(define (reductor-f1 f) + (vector-ref f 2)) + +(define (reductor-f2 f) + (vector-ref f 3)) + +(define (reductor-apply f args) + (let ((la (length args))) + (cond + ((< la 3) + (let ((f (vector-ref f (+ la 1)))) + (if (procedure? f) + (apply f args) + (ar-apply f args)))) + ; longer dispatching + (#t + (let ((f2 (ar-f2-to-lambda (reductor-f2 f)))) + (reductor-reduce f f2 args)))))) + +(define (reductor-reduce f f2 args) + (cond + ((l-reductor? f) + (l-reduce f2 (f2 (car args) (cadr args)) (cddr args))) + ; right reduction, sadly, just isn't tail recursive + ((r-reductor? f) + (f2 (car args) (r-reduce f2 (cdr args)))) + ((t-reductor? f) + ; notice: only cdr + (t-reduce f2 (f2 (car args) (cadr args)) (cdr args))) + (#t + (err "reductor type not implemented: " (vector-ref f 0))))) + +(define (l-reduce f2 acc args) + (if (eq? '() args) + acc + (l-reduce f2 (f2 acc (car args)) (cdr args)))) + +(define (l-reductor? f) + (and (vector? f) (eq? (vector-ref f 0) 'l-reductor))) + +(define (l-reductor f0 f1 f2) + (vector 'l-reductor f0 f1 f2)) + +(define (r-reduce f2 args) + (if (eq? '() (cdr args)) + (car args) + (f2 (car args) (r-reduce f2 (cdr args))))) + +(define (r-reductor? f) + (and (vector? f) (eq? (vector-ref f 0) 'r-reductor))) + +(define (r-reductor f0 f1 f2) + (vector 'r-reductor f0 f1 f2)) + +(define (t-reduce f2 result args) + (cond + ((ar-false? result) + 'nil) + ((eq? (cddr args) '()) + (f2 (car args) (cadr args))) + (#t + (t-reduce f2 (f2 (car args) (cadr args)) (cdr args))))) + +(define (t-reductor? f) + (and (vector? f) (eq? (vector-ref f 0) 't-reductor))) + +(define (t-reductor f0 f1 f2) + (vector 't-reductor f0 f1 f2)) + +(xdef 'l-reductor l-reductor) +(xdef 'r-reductor r-reductor) +(xdef 't-reductor t-reductor) + +;compose on functions + +(define (composer fl fr) + (vector 'composer fl fr)) + +(define (composer? fn) + (and (vector? fn) (eq? (vector-ref fn 0) 'composer))) + +(define (composer-fl fn) + (vector-ref fn 1)) + +(define (composer-fr fn) + (vector-ref fn 2)) + +(xdef 'compose composer) + +;clojure-style multimethods + +(define (clojure-method dispatch-fn . optional) + (let ((generic + (cond + ((eq? optional '()) + (lambda rest + (err "No generic function for dispatcher method"))) + ((eq? (cdr optional) '()) + (car optional)) + (#t + (err "'dispatcher-method accepts at most 2 parameters"))))) + (vector 'clojure-method + dispatch-fn + (make-hash-table 'equal) + generic))) + +(define (clojure-method-add key new-fn orig-fn) + (if (not (clojure-method? orig-fn)) + (err "'add-dispatcher-method expects a function generated by 'dispatcher-method")) + (let ((new-table (make-hash-table 'equal))) + (hash-table-for-each (vector-ref orig-fn 2) + (lambda (k v) + (hash-table-put! new-table k v))) + (hash-table-put! new-table key new-fn) + (vector 'clojure-method + (vector-ref orig-fn 1) + new-table + (vector-ref orig-fn 3)))) + +(define (clojure-method? fn) + (and (vector? fn) (eq? (vector-ref fn 0) 'clojure-method))) + +(define (clojure-method-dispatch-fn fn) + (vector-ref fn 1)) + +(define (clojure-method-lookup fn key) + (hash-table-get (vector-ref fn 2) key + (lambda () + (vector-ref fn 3)))) + +(define (clojure-method-apply fn args) + (ar-apply (clojure-method-lookup fn (ar-apply (clojure-method-dispatch-fn fn) args)) args)) + +(xdef 'dispatcher-method clojure-method) +(xdef 'add-dispatcher-method clojure-method-add) + +; polymorphism + +(define (simplify-type-list lt) + (cond + ((ar-false? lt) + '()) + ((all-falses? lt) + '()) + (#t + (cons (car lt) (simplify-type-list (cdr lt)))))) + +(define (all-falses? lt) + (cond + ((ar-false? lt) #t) + ((and (ar-false? (car lt)) (all-falses? (cdr lt))) #t) + (#t #f))) + +; given: +; lt = list of types (t1 t2 ...) +; spec = specific function for that list of types +; gen = function to extend +; returns a polymorphic function which +; invokes spec if the list of types +; matches the types of the parameters +; +; (defm + ((t a int) (t b int)) +; ($.add-ints a b)) +; ==> +; (set + +; (polymorph +; '(int int) +; (fn (a b) +; ($.add-ints a b)) +; +)) + +; in future rename to true-polymorph +; and create ar-polymorph which puts +; the types into package first +(define (ar-polymorph lt spec gen) + (true-polymorph + (cadr (context-ref-reuse! arc-package-cxt `(idfn ,lt))) + spec gen)) + +(define (true-polymorph lt spec gen) + ; clean up the list + (set! lt (simplify-type-list lt)) + (let ((llt (length lt))) + (cond + ((procedure? gen) + (cond + ((= llt 0) + ; wants the generic method replaced, so... + spec) + ((= llt 1) + (let ((hash (make-hash-table 'equal))) + (hash-table-put! hash (car lt) spec) + (ar-monomethod hash gen))) + (#t + (multimethod-from-generic lt spec gen)))) + ((monomethod? gen) + (cond + ((= llt 0) + ; replace generic with this specific + (ar-monomethod (vector-ref gen 1) spec)) + ((= llt 1) + (let ((hash (make-hash-table 'equal))) + ; copy old table + ; inefficient? yes. so what? who's + ; going to use 'polymorph in a tight + ; loop? + (hash-table-for-each (vector-ref gen 1) + (lambda (k v) + (hash-table-put! hash k v))) + ; insert new entry + (hash-table-put! hash (car lt) spec) + (ar-monomethod hash (vector-ref gen 2)))) + (#t + (multimethod-add (multimethod-from-monomethod gen) lt spec)))) + ((multimethod? gen) + (if (= llt 0) + (multimethod (vector-ref gen 1) spec) + (multimethod-add gen lt spec))) + (#t + (true-polymorph lt spec (lambda rest (ar-apply gen rest))))))) + +(xdef 'polymorph true-polymorph) + +; 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 + (ar-polymorph + '(bool) (lambda (x) 'nil) + (ar-polymorph + '(cons) (lambda (x) (car x)) + (lambda (x) + (err "'car expected a scanner" x))))) + +(xdef 'cdr + (ar-polymorph + '(bool) (lambda (x) 'nil) + (ar-polymorph + '(cons) (lambda (x) (cdr x)) + (lambda (x) + (err "'cdr expected a scanner" 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)))))) + +(define (tnil x) (if x '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))))) + +(define (arc-list? x) (or (pair? x) (eqv? x 'nil) (eqv? x '()))) + +; generic +: strings, lists, numbers. +; problem with generic +: what to return when no args? +; could even coerce based on type of first arg... + +(xdef '+ + ; when we have multimethods, + ; use those instead of + ; monomethods + (ar-polymorph + ; potentially also: + ; (int int) fx+ ;although fx+ is r6rs (mzscheme 372 is r5rs) + '(int) + + (ar-polymorph + '(num) + + (ar-polymorph + '(string) string-append + (ar-polymorph + '(cons) (lambda (a b) + ; ar-nil-terminate creates + ; a copy anyway + (append! (ar-nil-terminate a) + (ar-nil-terminate b))) + (ar-polymorph + '(bool) (lambda (a b) + (if (ar-false? a) + b + (err "Attempted to add t to " b))) + (lambda (a b) + (err "Unable to add " a " to " b)))))))) + +(xdef '- -) +(xdef 'negate -) +(xdef '* *) +(xdef '/ /) +(xdef 'reciprocal /) +(xdef 'mod modulo) +(xdef 'quotient quotient) + +(xdef 'expt expt) +(xdef 'sqrt sqrt) + +; generic comparison + +(xdef 'is + (ar-polymorph + '(string) (lambda (a b) + (tnil (if (string? b) (string=? a b) #f))) + (ar-polymorph + '(bool) (lambda (a b) + (tnil (if (ar-false? a) (ar-false? b) + (eq? b 't)))) + (lambda (a b) (tnil (eqv? a b)))))) + +(xdef '< + (ar-polymorph + '(int) (lambda (a b) (tnil (< a b))) + (ar-polymorph + '(num) (lambda (a b) (tnil (< a b))) + (ar-polymorph + '(string) (lambda (a b) (tnil (stringstring a) + (symbol->string b)))) + (lambda (a b) + (err "< unable to compare " a " to " b)))))))) + +(xdef 'len + (ar-polymorph + '(bool) (lambda (x) 0) + (ar-polymorph + '(string) string-length + (ar-polymorph + '(table) hash-table-count + (ar-polymorph + '(cons) (lambda (x) (length (ar-nil-terminate x))) + (lambda (x) + (err "len unable to compute length of " 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) -> bool + +(define (ar-type x) + (cond ((eq? x 't) 'bool) + ((ar-false? x) 'bool) + ((ar-tagged? x) (vector-ref x 1)) + ((pair? x) 'cons) + ((symbol? x) 'sym) + ((ar-procedure? x) 'fn) ; notice how this is an axiom ^^ + ((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) + ((regexp? x) 're) + ((thread? x) 'thread) + ((thread-cell? x) 'thread-local) + ((semaphore? x) 'sema) + ((context? x) 'cxt) + ((package? x) 'pkg) + (#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) + +(xdef 'uniq gensym) + +(xdef 'ccc call-with-current-continuation) + +(xdef 'dynamic-wind dynamic-wind) + +(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 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) + '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)) + +(define (printwith f args) + (let ((port (if (> (length args) 1) + (cadr args) + (current-output-port)))) + (when (pair? args) + (cond + ; could print # instead, but! + ; 1 people will then assume that monomethods + ; etc. are part of "the way arc-f is" + ; 2 we don't want that: this is just a + ; function, nothing more, nothing less, + ; and monomethods etc. are implementation + ; details for arc-f-on-mzscheme. they + ; are NOT arc! 'polymorph returns a + ; function, no there is no difference + ; between methods and functions + ((monomethod? (car args)) + (display "#" port)) + ((multimethod? (car args)) + (display "#" port)) + ((reductor? (car args)) + (display "#" port)) + ((composer? (car args)) + (display "#" port)) + ((clojure-method? (car args)) + (display "#" port)) + (#t (f (ac-denil (car args)) port)))) + (flush-output port)) + 'nil) + +(define ar-write (lambda args (printwith write args))) + +(xdef 'write ar-write) +(xdef 'disp (lambda args (printwith display args))) + +; sread = scheme read. eventually replace by writing read + +(xdef 'sread (lambda (p eof) + (let ((expr (ar-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 'new-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))) + +(xdef 'dynamic-wind dynamic-wind) + +; 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)) + +; assumes that the launching script was used +(define arc-path (getenv "arc_dir")) ; getenv is mzscheme-specific +(xdef 'arc-installation-path (lambda () (if arc-path arc-path 'nil))) + +(xdef 'load-resolve + (lambda (file) + (or (load-resolve file) + (err "'load-resolve can't resolve file path for load spec: " file)))) + +(define (load-resolve file) + (path->string + (path->complete-path + (cond + ((not (string? file)) + (err "load-resolve expects a string")) + ((file-exists? file) + file) + ; absolute?, or can't find arc_dir? + ((or (absolute-path? file) + (complete-path? file) + (not arc-path)) + #f) + ((file-exists? (build-path arc-path file)) + (build-path arc-path file)) + ((file-exists? (build-path arc-path "lib" file)) + (build-path arc-path "lib" file)) + (#t + #f))))) + +; 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 (ar-read))) + (when (not (eqv? expr ':a)) + (ar-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 (make-context))) + +(define (tl2 cxt) + (display "<") + (display (package-name (package-of-context cxt))) + (display ">tl: ") + (on-err (lambda (c) + (set! last-condition* c) + (display "Error: ") + (write (exn-message c)) + (newline) + (tl2 cxt)) + (lambda () + (let ((expr (ar-read))) + (if (and (ar-symbol? expr) (eq? (unpackaged-symbol expr) ':a)) + 'done + (let ((val (arc-eval (context-ref cxt expr)))) + ;(arc-eval `(input-history-update ',expr)) + ;(arc-eval `(output-history-update ',val)) + (ar-write (ac-denil val)) + (namespace-set-variable-value! '__that val) + (namespace-set-variable-value! '__thatexpr expr) + (newline) + (tl2 cxt))))))) + +(define (probe x) (display "probe:") (write x) (display #\newline) x) + +(define (aload1 p cxt) + (let ((x (ar-read p))) + (if (eof-object? x) + #t + (begin + (arc-eval (context-ref-reuse! cxt x)) + (aload1 p cxt))))) + +(define (atests1 p cxt) + (let ((x (ar-read p))) + (if (eof-object? x) + #t + (begin + (write x) + (newline) + (let ((v (arc-eval (context-ref-reuse! cxt x)))) + (if (ar-false? v) + (begin + (display " FAILED") + (newline)))) + (atests1 p cxt))))) + +(define (aload filename) + (call-with-input-file filename + (lambda (p) + (aload1 p (make-context))))) + +(define (test filename) + (call-with-input-file filename + (lambda (p) + (atests1 p (make-context))))) + +(define (acompile1 ip op cxt) + (let ((x (ar-read ip))) + (if (eof-object? x) + #t + (let ((scm (ac (context-ref-reuse! cxt x) '()))) + (pretty-print + (if (and (pair? x) (context-metacommand? (car x))) + (context-metacommand-compile cxt x) + scm) + op) + (eval scm (interaction-environment)) + (newline op) + (newline op) + (acompile1 ip op cxt))))) + +; compile xx.arc to xx.arc.scm +; useful to examine the Arc compiler output +(define (acompile inname) + (let ((outname (string-append inname ".scm")) + (cxt (make-context))) + (if (file-exists? outname) + (delete-file outname)) + (call-with-input-file inname + (lambda (ip) + (call-with-output-file outname + (lambda (op) + (acompile1 ip op (make-context)))))))) + +(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 (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 + (ar-polymorph '(cons) (lambda (x val) (set-car! x val) val) + (ar-polymorph '(string) (lambda (x val) (string-set! x 0 val) val) + (lambda (x val) + (err "Can't set car of" x))))) + +(xdef 'scdr + (ar-polymorph '(cons) (lambda (x val) (set-cdr! x val) val) + (lambda (x val) + (err "Can't set cdr of" 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))) + +(xdef 'sref + (ar-polymorph '(table) (lambda (com val ind) + (if (ar-false? val) + (hash-table-remove! com ind) + (hash-table-put! com ind val)) + val) + (ar-polymorph '(string) (lambda (com val ind) + (string-set! com ind val) + val) + (ar-polymorph '(cons) (lambda (com val ind) + (nth-set! com ind val) + val) + (ar-polymorph '(thread-local) (lambda (com val) + (thread-cell-set! com val) + val) + (ar-polymorph '(pkg) package-sref + (lambda (com val . ind) + (err "Can't set reference" com)))))))) + +(xdef 'call* + (ar-polymorph '(table) (lambda (com ind) + (hash-table-get com ind 'nil)) + (ar-polymorph '(string) (lambda (com ind) + (string-ref com ind)) + (ar-polymorph '(cons) (lambda (com ind) + (list-ref com ind)) + (ar-polymorph '(thread-local) thread-cell-ref + (ar-polymorph '(cxt) context-ref + (ar-polymorph '(pkg) package-ref + (lambda (com . rest) + (err "Can't get reference" com))))))))) + +(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) (tnil (bound? x)))) + +(xdef 'newstring make-string) + +(xdef 'trunc (lambda (x) (inexact->exact (truncate x)))) + +(xdef 'exact (lambda (x) + (tnil (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. + +(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 '()) + (dynamic-wind + (lambda () (thread-cell-set! ar-sema-cell #t)) + (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 sure if want as official +; part of Arc. + +;(xdef 'flushout (lambda () (flush-output) 't)) + +(xdef 'ssyntax (lambda (x) (tnil (default-ssyntax? x)))) + +(xdef 'ssexpand (lambda (x) + (if (symbol? x) (default-expand-ssyntax x) x))) + +(xdef 'which-os system-type) + +(xdef 'make-directory make-directory) +(xdef 'make-directory* make-directory*) +(xdef 'datetbl + (lambda (t) + (let ((dat (seconds->date t)) + (tbl (make-hash-table 'equal))) + (hash-table-put! tbl 'year (date-year dat)) + (hash-table-put! tbl 'month (date-month dat)) + (hash-table-put! tbl 'day (date-day dat)) + tbl))) + +(xdef 'seval (lambda (x) (eval (ac-denil x)))) + +(xdef 'quit exit) + +; Added outgoing tcp/ip ports +; (= socket (connect-socket host port)) +; (= outport (car (cdr socket)) +; (= inport (car socket)) +; (write "hello" outport) +; (read inport) +(xdef 'connect-socket (lambda (host port) + (let-values ([(in out) (tcp-connect host port)]) (list in out)))) +(xdef 'flush-socket (lambda (s) (flush-output s))) + +(xdef 'pipe (lambda () + (call-with-values make-pipe + (lambda (x y) + (cons x (cons y 'nil)))))) +(xdef 'pipe-len pipe-content-length) + +(xdef 'thread-local (lambda () + (make-thread-cell 'nil #t))) + +(xdef 'sema (lambda () (make-semaphore))) +(xdef 'sema-wait (wrapnil semaphore-wait)) +(xdef 'sema-post (wrapnil semaphore-post)) +(xdef 'sync sync) +(xdef 'synct (lambda (timeout . events) + (if (ar-false? timeout) + (apply sync events) + (let ((rv (apply sync/timeout timeout events))) + (if rv rv 'nil))))) + +(xdef 'cxt make-context) +(xdef 'pkg the-package) +(xdef 'pkg-of + (ar-polymorph '(cxt) package-of-context + (ar-polymorph '(sym) (lambda (a) + (the-package (package-of a))) + (lambda rest + (err "'pkg-of expects a context or symbol"))))) +(xdef 'pkg-name package-name) +(xdef 'unpkg unpackaged-symbol) +(xdef 'cxt-ref-d context-ref-reuse!) + +) diff --git a/arc-f/arc.arc b/arc-f/arc.arc new file mode 100644 index 000000000..a4dde8469 --- /dev/null +++ b/arc-f/arc.arc @@ -0,0 +1,3643 @@ +; Main Arc lib. Ported to Scheme version Jul 06. +; Rewritten Oct 08 for Arc-F + +; optimize ~foo in functional position in ac, like compose +; make foo~bar equiv of foo:~bar (in expand-ssyntax) +; rename assert +; (10 x) for (= x 10)? +; should (= x) mean (= x t)? +; add sigs of ops defined in ac.scm +; 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 arc.arc? +; warn when shadow a global name +; permanent objs that live on disk and are updated when modified +; problem: serialization of shared structure, especially cycles +; (need eq?-tables!!) +; way to spec default 0 rather than nil for hts +; do in access call or when ht created? simply have ++ nil -> 1? +; some simple regexp/parsing plan + +; 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 + +(in-package arc) + +; NOTE! Do not modify. We can't modify this +; without potentially breaking existing code. +; Instead use v3-exp for new stuff. +; If it's good, it'll be added into v4 + +;-----DO NOT MODIFY BEGINS + +; separated, because not all Arc implementations +; might support threads (or, like SNAP, may +; support an incompatible sort of concurrency) +(interface v3-thread + thread new-thread kill-thread break-thread + dead) +; similar: might not be supported by all Arc +; implementations +(interface v3-sync + pipe pipe-len thread-local + sema sema-wait sema-post + sync synct + lock w/lock) +; almkglor: controversial? LOL +(interface v3-reductor + l-reductor t-reductor r-reductor) +(interface v3-polymorph + polymorph) +; potentially rarely useful +(interface v3-testify + testify) +; almkglor: controversial? LOL +(interface v3-scanner + scanner unscan + each each-skip each-early-out each-skip-early-out + w/collect) +; all sorts of stuff +(interface v3-sort-internals + insert-sorted insort reinsert-sorted insortnew + mergesort) +; alternative multimethods +(interface v3-dispatcher-method + dispatcher-method add-dispatcher-method) +; almkglor: in my opinion, $ should be +; reserved for implementation-specific +; "hooks" +(interface v3-on-mzscheme + $) +; because you sometimes need to +; differentiate between what would +; have been there, versus what is +; really there +(interface v3-IDEAL + IDEAL REAL) +; to gain access to hidden help stuff +(interface v3-help + help helpsearch helpstr fns) +; packages +(interface v3-packages + cxt pkg pkg-of pkg-name unpkg + cxt-ref-d) +(interface v3 + ; types + bool cons sym fn char string + int num table output input + socket exception re thread + thread-local sema + ; maths + + - * / mod quotient expt sqrt + trunc exact + abs signop positive + round roundup to-nearest + avg + multiple + ; range + range + ; comparison + is isnt < > <= >= + iso + in empty + caris prefix mismatch + compare + single + len< len> + ; character classification punc + whitec nonwhite alphadig + ; running code + apply eval + ; higher-order functions + compose complement >> andf orf + memo + par + only + ; definitional structures + def mac defm defcall + defmemo + redef + ; code grouping + do do1 let with withs given givens + ; cons creation and manipulation + cons list + makeproper + ; string creation and manipulation + newstring tostring fromstring + ; string playing + ellipsize + ; table creation and manipulation + table maptable fill-table + w/table memtable + keys vals + ; table read and write + load-table read-table + load-tables save-table + write-table + safe-load-table + ; expression reading + readstring1 read readfile readfile1 + readall + saferead + ; scanner traversal + car cdr caar cadr cdar cadr + carif + nthcdr last + each + reclist + noisy-each + some all ;note the equivalency of these + ormap andmap + mem find + ; mutation + scar scdr sref + ; assignment + = defset + push swap rotate pop + pushnew pull + ++ -- + zap + wipe assert + ; control structures + and or nor + when unless + while until + loop for repeat n-of + forlen on + case + whilet caselet iflet whenlet + drain whiler + check + ; simple functions + no idfn nilfn + even odd + ; user types + annotate rep type + ; type checks + ; - should be less useful given generics + ; - also least-consistently-named part of ArcN + isa acons atom alist number dotted + ; other traversal structures + recstring trav trav+ + ontable + ; collecting structures + w/collect w/scanner-collect-each + w/collect-on + accum accums + summing + intersperse + counts + ; filtering and choosing + keep rem trues + best max min + most least + bestn firstn-that + union + count + before + dedup + commonest + ; scanner/sequence manipulation + map1 map mappend pair tuples mapeach + butlast cut firstn + split ; list only + ssplit ; string only + join + rev len + at ; list and string only + adjoin consif conswhen ; list only + flat + copy-seq seq-to-list + sort + merge ; list only + atend ; len-able sequence only + ; scanner/sequence copying + copy-seq seq-to-list + ; scanner reduction + reduce rreduce + ; cons cells as trees + tree-subst treewise ontree + ; tables as objects + obj inst deftem addtem + templatize + temread temload temloadall + tems + ; queues + queue enq deq qlen qlist enq-limit + ; hooks + hook defhook + ; association lists + assoc alref + tablist listtab + ; bracket functions + ; - needed if say some macro syntax would appreciate [] + make-br-fn _ + ; anaphoric functions + rfn afn + ; anaphoric structures + awhile aif aand awhen + ; anaphora + self it break collect throw + ; continuations and weirder control structures + ccc breakable point + protect dynamic-wind + after + ; gensyms + uniq w/uniq + ; printing + disp write pr prn + prall prs + prf + warn ero + writefile1 + writefileraw + bar* ; global variable, not very good T.T + w/bars + ; error + err on-err details + errsafe + ; i/o + infile outfile instring outstring + w/infile w/outfile w/instring w/outstring w/appendfile append + inside + close + stdout stdin sterr + call-w/stdout call-w/stdin + w/stdout w/stdin + readc writec peekc + readb writeb + readline + ; sockets + open-socket socket-accept + client-ip + connect-socket flush-socket + w/socket + ; conversion + string sym coerce + downcase upcase + ; GIL operations + atomic-invoke atomic atlet atwith atwiths + ; random + rand-string rand rand-choice random-elt + ; filesystem and system + dir file-exists dir-exists + rmfile + mkdir ensure-dir + system pipe-from + which-os + ; time + sleep msec seconds + datetbl + current-process-milliseconds + current-gc-milliseconds + since minutes-since hours-since + days-since + date + ; timed cache + cache + ; profiling + time jtime time10 + ; global variable queries + bound varif + ; PG wierdness + copy + ; loading sources + load require arc-installation-path + ; getting out of a lousy fork of Arc + quit + ; macro playing + expand macex macex1 + ; help facilities + help fns + docstring) + +;-----DO NOT MODIFY ENDS + +; NOTE! add new structures and functions here, *not* +; in any of the above interfaces. Users of this +; interface are warned that it could break their +; code at any random time. +(interface v3-exp) +; if you want to propose a new interface for v4, +; provide it first in the form v3-your-interface-exp +; :s/your-interface/whatever you want/ +; i.e. with the -exp tag to denote its experimental +; status for 3F +(interface v3-your-interface-exp) + +; NOTE! THIS INTERFACE EXISTS ONLY FOR DOCUMENTATION PURPOSES +; IT IS NOT INTENDED FOR ACTUAL USAGE +(interface v3 + ; maths + + - negate * + / reciprocal mod + quotient + ; comparison + is < + ; higher-order functions + andf orf + ; scanner efficiency overrides + each collect-on) + +(set help* (table)) + +(set current-load-file* "arc.arc") +(set source-file* (table)) + +(set safeset (annotate 'mac + (fn (var val) + `((fn () + (if (bound ',var) + ((fn () + (disp "*** redefining ") + (disp ',var) + (writec #\newline)))) + (set ,var ,val)))))) + +(set mac (annotate 'mac + (fn (name parms . body) + `((fn () + (sref sig ',parms ',name) + ; Document the macro, including the docstring if present + (if (is (type ',(car body)) 'string) + (sref help* '(mac ,(car body)) ',name) + (sref help* '(mac nil) ',name)) + (sref source-file* current-load-file* ',name) + (safeset ,name (annotate 'mac (fn ,parms ,@body)))))))) +;documentation for mac itself +(sref help* + '(mac + " Defines a macro, a special function which transforms code. + You may specify a docstring to be displayed by `help' by + placing it as the first string in `body' + See also [[def]] [[docstring]] ") + 'mac) +(sref sig + '(name parms . body) + 'mac) +(sref source-file* + current-load-file* + 'mac) + +(mac do args + " Evaluates each expression in sequence and returns the result of the + last expression. + See also [[do1]] [[after]] " + `((fn () ,@args))) + +(mac IDEAL (ideal real-tag real) + " Used to differentiate between a form that + we would prefer to use ideally, versus a + form that exists solely for real-world + efficiency. " + (if (is real-tag 'REAL) + () + (err "syntax error in IDEAL form")) + real) + +; It would be nice if multiple strings counted as multiple docstring lines. +(mac def (name parms . body) + " Defines a function with the given `name', `parms', and `body'. + You may specify a docstring to be displayed by `help' by + placing it as the first string in `body' + See also [[fn]] [[mac]] [[defm]] [[docstring]] " + `(do (sref sig ',parms ',name) + ; Document the function, including the docstring if present + ,(if (is (type (car body)) 'string) + `(sref help* '(fn ,(car body)) ',name) + `(sref help* '(fn nil) ',name)) + (sref source-file* current-load-file* ',name) + (safeset ,name (fn ,parms ,@body)))) + +(def docstring (name type parms docstring) + " A function which creates a docstring for + a given `name' symbol. `type' and `parms' + are the type of the `name' and the + parameters to that name. `docstring' is + the actual docstring for use with `help'. + See also [[help]] [[def]] [[mac]] " + (sref help* `(,type ,docstring) name) + (sref sig parms name) + (sref source-file* current-load-file* name) + t) + +(mac let (var val . body) + " Assigns a local variable for the given `body'. + See also [[with]] [[withs]] [[fn]] [[do]] " + `((fn (,var) + ,@body) + ,val)) + +(def caar (xs) " Equivalent to (car (car xs)) " (car (car xs))) +(def cadr (xs) " Equivalent to (car (cdr xs)) " (car (cdr xs))) +(def cdar (xs) " Equivalent to (cdr (car xs)) " (cdr (car xs))) +(def cddr (xs) " Equivalent to (cdr (cdr xs)) " (cdr (cdr xs))) + +(def no (x) " Determines if `x' is `nil'. " (is x nil)) + +(def acons (x) + " Determines if `x' is a `cons' cell or list. + Unlike 'alist, this function will return nil if given an empty list + See also [[atom]] [[alist]] [[dotted]] [[isa]] [[cons]] [[list]] " + (is (type x) 'cons)) + +(def atom (x) + " Determines if `x' is an atom + See also [[acons]] [[isa]] " + (no (acons x))) + +(def list args + " Creates a list from the given parameters. + See also [[cons]] [[acons]] " + args) + +(def idfn (x) + " Identity function - just returns its argument. + See also [[nilfn]] " + x) + +(def nilfn args + " Takes any number of arguments and returns nil. + See also [[idfn]] " + nil) + +; define reductors +(IDEAL + (do ; ideally, this is the definition for l-reductor + ; however, due to speed issues, l-reductors have + ; been made into special types internally on + ; the mzscheme side + ; other implementations are free to use this + ; definition, or to imitate this implementation + ; and create special objects for l-reductors + ; (provided that they are indistinguishable + ; by Arc from true functions) + (def l-reductor (f0 f1 f2) + " Creates a function which accepts any number of + parameters. If the function is given no + parameters, f0 is executed, if given 1 parameter + f1 is executed, if given 2 parameters f2 is + executed. For more than 2 parameters, parameters + are paired left-to-right: + (= f (l-reductor f0 f1 f2)) + (f) == (f0) + (f a) == (f1 a) + (f a b) == (f2 a b) + (f a b c) == (f2 (f2 a b) c) + See also [[r-reductor]] [[t-reductor]] " + (fn rest + (if (no rest) (f0) + (no:cdr rest) (f1:car rest) + (no:cdr:cdr rest) (f2 (car rest) (cadr rest)) + (l-reduction f2 (f2 (car rest) (cadr rest)) (cdr:cdr rest))))) + ; this function is *not* part of the v3 + ; interface, or any interface; portable arc + ; programs should not rely on its presence + ; *or* absence. + ; This also means that other implementations + ; are free to include various internal + ; functions in arc.arc, provided they are not + ; included in a standard interface + (def l-reduction (f acc args) + (if args + (l-reduction f (f acc (car args)) (cdr args)) + acc))) + REAL + ; l-reductor is defined scheme-side + (docstring 'l-reductor 'fn '(f0 f1 f2) + " Creates a function which accepts any number of + parameters. If the function is given no + parameters, f0 is executed, if given 1 parameter + f1 is executed, if given 2 parameters f2 is + executed. For more than 2 parameters, parameters + are paired left-to-right. + (= f (l-reductor f0 f1 f2)) + (f) == (f0) + (f a) == (f1 a) + (f a b) == (f2 a b) + (f a b c) == (f2 (f2 a b) c) + See also [[r-reductor]] [[t-reductor]] ")) + +; use wrapper functions to allow overriding of +; basic math functions +(set + (l-reductor + (fn () (err "'+ requires at least one parameter")) + (fn (x) x) + (fn (a b) (+ a b)))) +(docstring '+ 'fn 'args + " Adds numbers together, or concatenates + strings and lists. + See also [[-]] [[*]] [[/]] [[join]] ") + +(set - (l-reductor + (fn () (err "'- requires at least one parameter")) + (fn (x) (negate x)) + (fn (a b) (- a b)))) +(docstring '- 'fn 'args + " Subtracts other numbers from the first given + number, or negates a single number. + (- 10 5 4) => (10 - 5) - 4 == 1 + (- 10) => -10 + See also [[-]] [[*]] [[/]] ") + +(set * (l-reductor + (fn () (err "'* requires at least one parameter")) + (fn (x) x) + (fn (a b) (* a b)))) +(docstring '* 'fn 'args + " Multiplies numbers together. + See also [[+]] [[-]] [[/]] ") + +(set / (l-reductor + (fn () (err "'/ requires at least one parameter")) + (fn (x) (reciprocal x)) + (fn (a b) (/ a b)))) +(docstring '/ 'fn 'args + " Divides a number by succeeding numbers, + or takes the reciprocal of a number. + (/ 60 3 2) => (60 / 3) / 2 == 10 + (/ 0.25) => 4.0 + See also [[+]] [[-]] [[*]] [[mod]] [[quotient]] ") + +(set mod + (l-reductor + (fn () (err "'mod requires at least two parameters")) + (fn (x) (err "'mod requires at least two parameters")) + (fn (a b) (mod a b)))) +(docstring 'mod 'fn 'args + " Divides a number by another number, + returning the remainder (or + 'modulo'); the result is further + divided and the remainder computed + if more than two parameters are + given. All numbers must be integers. + (mod 59 10) => 9 + (mod 59 10 4) => (59 mod 10) mod 4 + => 9 mod 4 + => 1 + See also [[quotient]] [[/]] ") + +(set quotient + (l-reductor + (fn () (err "'quotient requires at least two parameters")) + (fn (x) (err "'quotient requires at least two parameters")) + (fn (a b) (quotient a b)))) +(docstring 'quotient 'fn 'args + " Divides a number by another number, + returning the quotient, rounded + towards zero to the nearest integer; + the result is further divided and + the quotient rounded if more than + two parameters are given. All + numbers must be integers. + (quotient 42 8) => 5 + (quotient 42 8 2) => round(round(42 / 8) / 2) + => round(5 / 2) + => 2 + See also [[mod]] [[/]] ") + +(set compose + (l-reductor + (fn () (err "'compose requires at least one parameter")) + (fn (x) x) + (fn (a b) (compose a b)))) +(docstring 'compose 'fn 'args + " Connects several functions so that the + result of the rightmost function is + given to the function to the right, + and so on. + ((compose a b) x) => (a (b x)) + See also [[>>]] [[complement]] ") + +(IDEAL + (def compose (a b) + (fn rest + (a (apply b rest)))) + REAL + ()) + +(def complement (f) + " Arc expands ~x into (complement x) + whenever the function returns true this returns false. + See also [[no]] [[isnt]] [[compose]]" + (compose no f)) + +(IDEAL + (do ; like l-reductor, this is handled + ; by the base ac.scm for speed + (def r-reductor (f0 f1 f2) + " Creates a function which accepts any number of + parameters. If the function is given no + parameters, f0 is executed, if given 1 parameter + f1 is executed, if given 2 parameters f2 is + executed. For more than 2 parameters, parameters + are paired right-to-left: + (= f (r-reductor f0 f1 f2)) + (f) == (f0) + (f a) == (f1 a) + (f a b) == (f2 a b) + (f a b c) == (f2 a (f2 b c)) + See also [[l-reductor]] [[t-reductor]] " + (fn rest + (if (no rest) (f0) + (no:cdr rest) (f1:car args) + (no:cdr:cdr rest) (f2 (car args) (cadr args)) + (f2 (car rest) (r-reduction f2 (cdr rest)))))) + (def r-reduction (f2 rest) + (if (no:cdr rest) + (car rest) + (f2 (car rest) (r-reduction f2 (cdr rest)))))) + REAL + (docstring 'r-reductor 'fn '(f0 f1 f2) + " Creates a function which accepts any number of + parameters. If the function is given no + parameters, f0 is executed, if given 1 parameter + f1 is executed, if given 2 parameters f2 is + executed. For more than 2 parameters, parameters + are paired right-to-left: + (= f (r-reductor f0 f1 f2)) + (f) == (f0) + (f a) == (f1 a) + (f a b) == (f2 a b) + (f a b c) == (f2 a (f2 b c)) + See also [[l-reductor]] [[t-reductor]] ")) + +; reduce right so that pairing is thus: +; (andf a (andf b c)) +; this is slightly more efficient in the +; case of a function returning nil early +(set andf + (r-reductor + (fn () (fn (x) t)) + (fn (a) (fn (x) (a x))) + (fn (a b) (andf a b)))) +(docstring 'andf 'fn 'fns + " Creates a function which returns true on its argument if all of the + given `fns' return true on that argument. + The created function accepts a single argument. + See also [[and]] [[orf]] ") + +(def andf (a b) + (fn (x) + (if (a x) (b x)))) + +(set orf + (r-reductor + (fn () (fn (x) t)) + (fn (a) (fn (x) (a x))) + (fn (a b) (orf a b)))) +(docstring 'orf 'fn 'fns + " Creates a function which returns true on its argument if any of the + given `fns' return true on that argument. + The created function accepts a single argument. + See also [[or]] [[andf]] ") + +(def orf (a b) + (fn (x) + ((fn (rv) + (if rv rv + (b x))) + (a x)))) + +(IDEAL + (do ; efficiency concern, efficiency concern + (def t-reductor (f0 f1 f2) + " Creates a function which accepts any number of + parameters. If the function is given no + parameters, f0 is executed, if given 1 parameter + f1 is executed, if given 2 parameters f2 is + executed. For more than 2 parameters, parameters + are paired left-to-right, and execution continues + only if f2 on the previous pair returns true: + (= f (t-reductor f0 f1 f2)) + (f) == (f0) + (f a) == (f1 a) + (f a b) == (f2 a b) + (f a b c) == (if (f2 a b) (f2 b c)) + See also [[l-reductor]] [[r-reductor]] " + (fn rest + (if (no rest) (f0) + (no:cdr rest) (f1:car rest) + (no:cdr:cdr rest) (f2 (car rest) (cadr rest)) + ; notice only cdr + (t-reduction f2 (f2 (car rest) (cadr rest)) (cdr rest))))) + (def t-reduction (f2 result rest) + (if result + (if (cdr:cdr rest) + (t-reduction f2 (f2 (car rest) (cadr rest)) (cdr rest)) + (f2 (car rest) (cadr rest)))))) + REAL + (docstring 't-reductor 'fn '(f0 f1 f2) + " Creates a function which accepts any number of + parameters. If the function is given no + parameters, f0 is executed, if given 1 parameter + f1 is executed, if given 2 parameters f2 is + executed. For more than 2 parameters, parameters + are paired left-to-right, and execution continues + only if f2 on the previous pair returns true: + (= f (t-reductor f0 f1 f2)) + (f) == (f0) + (f a) == (f1 a) + (f a b) == (f2 a b) + (f a b c) == (if (f2 a b) (f2 b c)) + See also [[l-reductor]] [[r-reductor]] ")) + +(set is + (t-reductor + (fn () (err "'is expects at least one argument")) + (fn (a) (fn (b) (is a b))) + (fn (a b) (is a b)))) +(docstring 'is 'fn 'args + " Determines if all arguments are + equal. + If given only one argument, returns + a function that compares its + argument to that value. + (is 1 2) => nil + (is 1 1) => t + (= f (is 0)) + (f 2) => nil + (f 0) => t + See also [[isnt]] [[iso]] [[<]] [[>]] [[<=]] [[>=]] ") + +(set isnt + (t-reductor + (fn () (err "'isnt expects at least one argument")) + (fn (a) (fn (b) (isnt a b))) + (fn (a b) (no (is a b))))) +(docstring 'isnt 'fn 'args + " Determines if all arguments are not + equal. + If given only one argument, returns + a function that compares its + argument to that value. + (isnt 1 2) => t + (isnt 1 1) => nil + (= f (isnt 0)) + (f 2) => t + (f 0) => nil + See also [[no]] [[is]] [[<]] [[>]] [[<=]] [[>=]] ") + +(set < + (t-reductor + (fn () (err "'< expects at least one argument")) + (fn (a) (fn (b) (< a b))) + (fn (a b) (< a b)))) +(docstring '< 'fn 'args + " Determines if arguments are in order + from least to highest. + If given only one argument, returns + a function that compares its + argument to that value. + (< 1 2) => t + (< 1 1) => nil + (< 1 2 3) => t + (< 1 3 2) => nil + (= f (< 0)) + (f 1) => t + (f -1) => nil + See also [[<=]] [[>]] [[>=]] [[is]] [[isnt]] ") + +(set > + (t-reductor + (fn () (err "'> expects at least one argument")) + (fn (a) (fn (b) (> a b))) + (fn (a b) (if (< a b) + nil + (no:is a b))))) +(docstring '> 'fn 'args + " Determines if arguments are in order + from highest to lowest. + If given only one argument, returns + a function that compares its + argument to that value. + (> 1 2) => nil + (> 1 1) => nil + (> 1 2 3) => nil + (> 3 2 1) => t + (= f (> 0)) + (f 1) => nil + (f -1) => t + See also [[>=]] [[<=]] [[<]] [[is]] [[isnt]] ") + + +(set <= + (t-reductor + (fn () (err "'<= expects at least one argument")) + (fn (a) (fn (b) (<= a b))) + (fn (a b) ((fn (rv) + (if rv + rv + (is a b))) + (< a b))))) +(docstring '<= 'fn 'args + " Determines if arguments are not + decreasing. + If given only one argument, returns + a function that compares its + argument to that value. + (<= 1 2) => t + (<= 3 2) => nil + (<= 1 1 2) => t + (<= 3 3 2) => nil + (= f (<= 0)) + (f 1) => t + (f -1) => nil + See also [[<]] [[>=]] [[>]] [[is]] [[isnt]] ") + +(set >= + (t-reductor + (fn () (err "'>= expect at least one argument")) + (fn (a) (fn (b) (>= a b))) + (fn (a b) (if (< a b) + (is a b) + t)))) +(docstring '>= 'fn 'args + " Determines if arguments are not + increasing. + If given only one argument, returns + a function that compares its + argument to that value. + (>= 1 2) => nil + (>= 3 2) => t + (>= 1 1 2) => nil + (>= 3 3 2) => t + (= f (>= 0)) + (f 1) => nil + (f -1) => t + See also [[>]] [[<=]] [[<]] [[is]] [[isnt]] ") + +(mac and args + " Evaluates arguments till false is found else returns the last one. + See also [[or]] [[aand]] [[andf]] [[andmap]] " + (if args + (if (cdr args) + `(if ,(car args) (and ,@(cdr args))) + (car args)) + 't)) + +(mac defm (name parms . body) + " Defines or redefines a method, with type + annotations. A generic function must be + defined with 'def before using this form. + Example: + (defm sref ((t c container) value) + (scar (rep c) value)) + See also [[def]] [[defcall]]" + (let (real-parms parmstl + types typestl + self) nil + ; withs not defined yet ^^ + (let add-parm + (fn (p) + (if real-parms + (set parmstl (scdr parmstl (list p))) + (set real-parms (set parmstl (list p))))) + (let add-type + (fn (tt) + (if types + (set typestl (scdr typestl (list tt))) + (set types (set typestl (list tt))))) + (let rest-parm + (fn (p) + (if real-parms + (scdr parmstl p) + (set real-parms p))) + (set self + (fn (l) + (if (is (type l) 'cons) + (let parm (car l) + (if (and (is (type parm) 'cons) + (is (car parm) t)) + (let (spec real-parm typ) parm + (add-parm real-parm) + (add-type typ)) + (do (add-parm parm) + (add-type nil))) + (self:cdr l)) + (rest-parm l)))) + (self parms) + `(set ,name + (symeval!polymorph + ',types (fn ,real-parms ,@body) + ,name))))))) + +; bootstrap ends + +(mac w/collect body + " Creates a new list, providing a `collect' function + within `body' which collects its argument into the + list. + Collection is in the correct order. + See also [[accum]] [[w/collect-on]] [[summing]] " + `(symeval!w/collect-f (fn (collect) ,@body))) +(def w/collect-f (bf) + (let (hd tl collect) nil + (set collect + (fn (e) + (if hd (set tl (scdr tl (cons e nil))) + (set tl (set hd (cons e nil)))))) + (bf collect) + hd)) + +; defined here, but each is defined later +(mac each (var expr . body) + " Performs `body' for each element of the sequence returned by `expr', + with each element assigned to `var'. + See also [[forlen]] [[on]] [[map]] [[mapeach]] [[ontable]] + [[each-skip-early-out]] " + `(symeval!each ,expr 0 (fn (,var) ,@body t))) + +(mac each-skip-early-out (start var expr . body) + " Performs `body' for each element of the sequence returned by `expr', + starting at start. If the last expression in `body' returns nil, + ends iteration. + See also [[each]] [[each-skip]] [[each-early-out]] " + `(symeval!each ,expr ,start (fn (,var) ,@body))) + +(mac each-skip (start var expr . body) + " Performs `body' for each element of the sequence returned by `expr', + starting at start. + See also [[each]] [[each-skip-early-out]] [[each-early-out]] " + `(symeval!each ,expr ,start (fn (,var) ,@body t))) + +(mac each-early-out (var expr . body) + " Performs `body' for each element of the sequence returend by `expr'. + If the last epression in `body' returns nil, ends iteration, + See also [[each]] [[each-skip]] [[each-skip-early-out]] " + `(symeval!each ,expr 0 (fn (,var) ,@body))) + +(mac w/collect-on (seq . body) + " Constructs a new sequence with the same type as `seq', + and provides a `collect' function which collects its + argument into the sequence. The original `seq' is not + modified, and is used only as a template. + See also [[w/collect]] " + `(symeval!collect-on ,seq (fn (collect) ,@body))) + +(def nthcdr (n xs) + " Returns the result of applying `cdr' repeatedly + by `n' times on `xs'. + See also [[cut]] [[firstn]] " + (nthcdr-internal n (scanner xs))) +(def nthcdr-internal (n xs) + (if (no n) xs + (> n 0) (nthcdr-internal (- n 1) (cdr xs)) + xs)) + +; scanners +(def scanner (a) + " Converts `a' to a scanner. + Sequence-like types should overload this + function to return a value with a type + that can be validly used with 'car and 'cdr + See also [[unscan]] [[car]] [[cdr]] " + (err "Can't be converted to scanner sequence " a)) +(def unscan (origob scan) + " Converts the scanner `scan' to an object + of the same type as `origob'. + Sequence-like types should overload this + function on `origob'. The overloaded + method should ignore the value of `origob' + and treat `scan' as a read-only scanner. + Scanner types can validly return `scan'. + See also [[scanner]] " + (err "Can't reconstitute " (type origob) " from scanner")) + +(defm scanner ((t a cons)) + a) +(defm unscan ((t a cons) scan) + (w/collect:each i scan + (collect i))) + +(defm scanner ((t a string)) + (coerce a 'cons)) +(defm unscan ((t a string) scan) + ((fn (port) + (each ch scan + (disp ch port)) + (inside port)) + (outstring))) + +(defm scanner ((t a table)) + (w/collect:maptable + (fn (k v) + (collect (cons k v))) + a)) +(defm unscan ((t a table) scan) + ((fn (rv) + (each (k . v) scan + (sref rv v k)) + rv) + (table))) + +(defm scanner ((t a bool)) + (if a (err "Attempt to scan t")) + nil) +(defm unscan ((t a bool) scan) + scan) + +(let self nil + (set self + (fn (f s) + (if s + (if (f:car s) + (self f (cdr s)))))) + (def each (seq skip bf) + " Traverses a traversable object `seq' (any object + which validly returns when applied to 'scanner) + starting at `skip'. + The function `bf' is called with a single + parameter, the value at each position in the + sequence. + Traversal continues if the function returns a + true value, and stops if the function returns + 'nil. + See also [[each]] " + (self bf (nthcdr skip seq)))) + +(let self nil + (set self + (fn (f s i l) + (if (< i l) + (if (f s.i) + (self f s (+ i 1) l))))) + (defm each ((t seq string) skip bf) + (self bf seq skip (len seq)))) + +(defm each ((t seq table) skip bf) + (ccc + (fn (break) + (maptable + (fn (k v) + (if + (> skip 0) + (set skip (- skip 1)) + (no (bf:cons k v)) + (break nil))) + seq)))) + +(def collect-on (seq bf) + (unscan seq + (w/collect-f bf))) +(defm collect-on ((t seq cons) bf) + (w/collect-f bf)) +(defm collect-on ((t seq string) bf) + (let port (outstring) + (bf (fn (e) (disp e port) e)) + (inside port))) +(defm collect-on ((t seq table) bf) + (let rv (table) + (bf (fn (val) + (let (k . v) val + (sref rv v k) + val))) + rv)) +(defm collect-on ((t seq bool) bf) + (if seq (err "attempt to collect on t")) + (w/collect-f bf)) + +(mac w/scanner-collect-each (var seq . body) + (let gseq (uniq) + `((fn (,gseq) + (symeval!collect-on ,gseq + (fn (collect) + (symeval!each ,gseq 0 + (fn (,var) ,@body t))))) + ,seq))) + +; override the default behaviour of 'len +(let self nil + (set self + (fn (a i) + (if a (self (cdr a) (+ i 1)) + i))) + (defm len (a) + (self (scanner a) 0))) + +; standard stuff + +(set >> + (l-reductor + (fn () (err "'>> requires at least one parameter")) + idfn + (fn (a b) (b a)))) +(docstring '>> 'fn' '(val . funs) + " Chains the value `val' through the functions in `fun'. + Example: + (>> 5 g f) + == + (f (g 5)) + See also [[compose]] ") + +(def map1 (f xs) + " Return a sequence with function f applied to every element in sequence xs. + See also [[map]] [[each]] [[mappend]] [[andmap]] [[ormap]] " + (w/scanner-collect-each e xs + (collect:f e))) + +(def pair (xs (o f list)) + " Applies pairs of elements to the function `f'. + See also [[tuples]] [[map]] " + (if (no xs) + nil + (no (cdr xs)) + (list (list (car xs))) + (cons (f (car xs) (cadr xs)) + (pair (cddr xs) f)))) + +(mac $ body + " Allows access to the underlying Scheme. " + (list 'seval (cons 'quasiquote body))) + +(def assoc (key al) + " Finds a (key value) pair in an associated list. + See also [[alref]] [[listtab]] [[tablist]] " + (if (atom al) + nil + (and (acons (car al)) (is (caar al) key)) + (car al) + (assoc key (cdr al)))) + +(def alref (al key) + " Get a value from a key in a associated list. + See also [[assoc]] [[listtab]] [[tablist]] " + (cadr (assoc key al))) + +(mac with (parms . body) + " Assigns a set of local variables for the given `body'. + Assignment is simultaneous. + See also [[withs]] [[given]] [[let]] [[fn]] [[do]] " + `((fn ,(map1 car (pair parms)) + ,@body) + ,@(map1 cadr (pair parms)))) + +(mac withs (parms . body) + " Assigns local variables for the given `body'. + The assignments are made in the given order. + See also [[with]] [[givens]] [[let]] [[fn]] [[do]] " + (if (no parms) + `(do ,@body) + `(let ,(car parms) ,(cadr parms) + (withs ,(cddr parms) ,@body)))) + +(def butlast (seq) + " Returns every element of `seq' but the last one. + See also [[last]] [[cut]] " + (cut seq 0 -1)) + +(mac given body + " Simultaneously assigns the given (unparenthesized) local variables in the + one-statement body. + See also [[let]] [[with]] [[givens]]" + (with (args (butlast body) + expr (last body)) + `(with ,args + ,expr))) + +(mac givens body + " Sequentially assigns the given (unparenthesized) local variables in the + one-statement body. + See also [[let]] [[withs]] [[given]]" + (with (args (butlast body) + expr (last body)) + `(withs ,args + ,expr))) + +; Rtm prefers to overload + to do this + +(def join args + " Joins all scanner arguments together. + See also [[cons]] [[+]] " + (join-inner args)) +(def join-inner (args) + (if (no args) + nil + (let a (car args) + (if (no a) + (join-inner (cdr args)) + (w/collect-on a + (each i a (collect i)) + (each s (cdr args) + (each i s (collect i)))))))) + +(mac rfn (name parms . body) + " Creates a function which calls itself as `name'. + See also [[fn]] [[afn]] " + `(let ,name nil + (set ,name (fn ,parms ,@body)))) + +(mac afn (parms . body) + " Creates a function which calls itself with the name `self'. + See also [[fn]] [[rfn]] [[aif]] [[awhen]] [[aand]] " + `(rfn self ,parms ,@body)) + +(def rev (xs) + " Reverses a copy of the sequence `xs' + See also [[copy]] " + (let v nil + (each x xs + (= v (cons x v))) + (unscan xs v))) + +(mac w/uniq (names . body) + " Assigns a set of variables to unique symbols. + Generally used for macro functions. + See also [[uniq]] " + (if (acons names) + `(with ,(apply + nil (map1 (fn (n) (list n '(uniq))) + names)) + ,@body) + `(let ,names (uniq) ,@body))) + +(mac or args + " Computes arguments until one of them is true and returns that result. + See also [[and]] [[orf]] [[ormap]] [[check]] " + (and args + (w/uniq g + `(let ,g ,(car args) + (if ,g ,g (or ,@(cdr args))))))) + +(def alist (x) + " Return true if argument is a possibly empty list + Unlike 'acons, this function returns t when given an empty list + See also [[atom]] [[acons]] [[dotted]] [[isa]] [[cons]] [[list]] " + (or (no x) (is (type x) 'cons))) + +(mac in (x . choices) + " Returns true if the first argument is one of the other arguments. + See also [[some]] [[mem]] " + (w/uniq g + `(let ,g ,x + (or ,@(map1 (fn (c) `(is ,g ,c)) choices))))) + +(set iso + (t-reductor + (fn () (err "'iso requires at least one argument")) + (fn (a) (fn (b) (iso a b))) + (fn (a b) (iso a b)))) +(docstring 'iso 'fn 'rest + " Isomorphic compare - compares structure (can be slow). + See also [[is]] ") +(def iso (x y) + (is x y)) +(IDEAL + (defm iso ((t x cons) (t y cons)) + (or (is x y) + (and (iso (car x) (car y)) + (iso (car x) (car y))))) + REAL + ; true multimethods not implemented yet T.T + (defm iso ((t x cons) y) + (or (is x y) + (and (acons y) + (iso (car x) (car y)) + (iso (cdr x) (cdr y)))))) + +(mac when (test . body) + " When `test' is true, do `body'. + See also [[unless]] [[if]] [[awhen]] " + `(if ,test (do ,@body))) + +(mac unless (test . body) + " When `test' is not true, do `body'. + See also [[when]] [[if]] [[no]] " + `(if (no ,test) (do ,@body))) + +(mac breakable body + " Allows a (break ...) form to return a value from within the + body of a control structure. + Example: + (breakable:while t + (aif (something) (break it))) + See also [[catch]] [[point]] [[accum]] [[while]] " + `(symeval!ccc (fn (break) ,@body))) + +(mac while (test . body) + " While `test' is true, perform `body' in a loop. + See also [[until]] [[loop]] [[whilet]] [[whiler]] [[for]] + [[repeat]] [[drain]] [[always]] " + (w/uniq (gf gp) + `((rfn ,gf (,gp) + (when ,gp ,@body (,gf ,test))) + ,test))) + +(mac always body + " Executes the contents of `body' in an infinite loop. + See also [[while]] " + (w/uniq gf + `((rfn ,gf () + ,@body + (,gf))))) + +(def empty (seq) + " Test to see if `seq' is an empty list or other sequence. + See also [[no]] [[acons]] [[len]] " + (is (len seq) 0)) +(defm empty ((t seq bool)) + (no seq)) +(defm empty ((t seq cons)) + nil) + +(def reclist (f xs) + " Applies the function `f' on succeeding `cdr' of + the sequence `xs' until `f' returns true. + See also [[ormap]] [[andmap]] [[map]] " + (reclist-internal f (scanner xs))) +(def reclist-internal (f xs) + (and xs (or (f xs) (reclist-internal f (cdr xs))))) + +(def recstring (test s (o start 0)) + " Applies the function `test' on indices of `s' + until `test' returns true. + See also [[map]] [[reclist]] " + (let n (len s) + ((afn (i) + (and (< i (len s)) + (or (test i) + (self (+ i 1))))) + start))) + +(def isa (x y) + " Checks if x is of type y. + See also [[acons]] [[alist]] [[atom]] " + (is (type x) y)) + +(def testify (x) + " Creates a test that determines if a given argument is `x'. + See also [[is]] " + (if (isa x 'fn) x (fn (_) (is _ x)))) + +(def some (test seq) + " Determines if at least one element of `seq' satisfies `test'. + See also [[ormap]] [[all]] [[mem]] [[in]] [[pos]] " + (let f (testify test) + (some-internal seq f))) +(def some-internal (seq f) + (reclist f:car (scanner seq))) +(defm some-internal ((t seq string) f) + (recstring f:seq seq)) +(defm some-internal ((t seq table) f) + (let rv nil + (each-early-out i seq + (set rv (f i)) + (no rv)) + rv)) + +(def all (test seq) + " Determines if all elements of `seq' satisfy `test'. + See also [[andmap]] [[some]] " + (~some-internal seq (complement (testify test)))) + +(def dotted (x) + " Determines if `x' is a dotted cons pair. + See also [[acons]] [[alist]] " + (if (atom x) + nil + (and (cdr x) (or (atom (cdr x)) + (dotted (cdr x)))))) + +; I couldn't find a pre-existing total macro-expander +(def expand (expr) + " Completely expands all macros in `expr'. + See also [[macex]] [[mac]] " + (if (and (acons expr) (~dotted expr) (~is 'quote (car expr))) + (let expansion (macex (cons (expand (car expr)) + (map1 expand (cdr expr)))) + (if (and (acons expansion) (acons:car expansion)) + (cons (expand:car expansion) (cdr expansion)) + expansion)) + expr)) + +(def makeproper (lst) + " Transforms `list' to a proper list if it is a dotted list. + Note that we mean actual cons cells; it does not work with + scanners. + See also [[dotted]] [[list]] " + (if (no (acons lst)) + lst + (w/collect (makeproper-internal lst collect)))) +(def makeproper-internal (lst collect) + (collect lst)) +(defm makeproper-internal ((t lst cons) collect) + (collect:car lst) + (makeproper-internal (cdr lst) collect)) + +(def andmap (pred seq) + " Applies `pred' to elements of `seq' until an element fails. + See also [[all]] [[and]] [[andf]] [[map]] " + (some-internal seq ~pred)) + +(def ormap (pred seq) + " Applies `pred' to elements of `seq' until an element passes. + See also [[some]] [[or]] [[orf]] [[map]] " + (some-internal seq pred)) + +; The call* global function defines how to deal with non-functions +; in functional positions. + +(mac defcall (name parms . body) + " Defines a function to run when an object of the given type + is encountered in functional position. + The first argument to this function is the `rep' of the object, + and the rest are passed as arguments to the object. + See also [[rep]] [[annotate]] [[type]] " + (w/uniq (gsym grest) + (if (acons parms) + `(defm call* ,(cons `(t ,gsym ,name) (cdr parms)) + ((fn (,(car parms)) + ,@body) + (symeval!rep ,gsym))) + `(defm call* ,(cons `(t ,gsym ,name) grest) + (apply (fn ,parms + ,@body) + (symeval!rep ,gsym) + ,grest))))) + +(defcall num (num . args) + (if (acons args) + (if (or (isa (car args) 'num) (isa (car args) 'int)) + (err:tostring:prn "Number applied to number - " num " - parameters - " args) + (apply (car args) num (cdr args))) + num)) +(defcall int (num . args) + (if (acons args) + (if (or (isa (car args) 'num) (isa (car args) 'int)) + (err:tostring:prn "Number applied to number - " num " - parameters - " args) + (apply (car args) num (cdr args))) + num)) + +; almkglor: simplify 'make-br-fn? +; (mac make-br-fn (expr) +; (w/uniq rest +; `(fn ,(cons '(o _) rest) +; ,expr))) +; - i.e. make it a variadic function +; whose first optional argument is _ + +(def *mbf-arglist-vars (arglist) + " Returns the variables bound in an argument list. + See also [[make-br-fn]] " + (if (isa arglist 'cons) + (apply join + (map1 + (fn (_) + (if (isa _ 'cons) + (if (is (car _) 'o) + (list:cadr _) + _) + (list _))) + (makeproper arglist))) + arglist)) + +(def *mbf-arglist-frees (arglist) + " Returns the free variables used in default values for optional arguments + of an argument list. + See also [[make-br-fn]] " + (if (isa arglist 'cons) + (apply join + (map1 + (fn (_) + (and (isa _ 'cons) + (is (car _) 'o) + (*mbf-all-vars (cddr _)))) + (makeproper arglist))) + nil)) + +(def *mbf-all-vars (form) + " Extracts all the variables in the fully macro-expanded s-expression `form'. + See also [[make-br-fn]] " + (let head (and (isa form 'cons) (car form)) + (if + (or (no form) (and (no (isa form 'sym)) (no (isa form 'cons)))) + nil + (isa form 'sym) + (list form) + (is head 'quote) + nil + (is head 'quasiquote) + (ormap + (fn (_) + (and (isa _ 'cons) + (in (car _) 'unquote 'unquote-splicing) + (apply join (map1 *mbf-all-vars (cdr _))))) + (cdr form)) + (is head 'if) + (apply join (map1 *mbf-all-vars (cdr form))) + (is head 'fn) + (join (apply join (map1 *mbf-all-vars (*mbf-arglist-vars (cadr form)))) + (apply join (map1 *mbf-all-vars (*mbf-arglist-frees (cadr form)))) + (apply join (map1 *mbf-all-vars (cddr form)))) + ; else (including set) + (apply join (map1 *mbf-all-vars form))))) + +(def *mbf-free? (form var) + " Checks if the variable named `var' occurs free (unbound) in `form'. + See also [[make-br-fn]] " + ; I'd like to use case, but it doesn't exist yet. + (with (kind (type form) + find (afn (x lst) + (if (and (alist lst) lst) + (or (is x (car lst) (self x (cdr lst)))) + nil))) + (if + (is kind 'sym) + (is form var) + (is kind 'cons) + (let head (car form) + (if + (is head 'fn) + (or (find var (*mbf-arglist-frees (cadr form))) + (and (no (find var (*mbf-arglist-vars (cadr form)))) + (*mbf-free? (cddr form) var))) + (is head 'quote) + #f + (is head 'quasiquote) + (ormap + (fn (_) + (and (isa _ 'cons) + (in (car _) 'unquote 'unquote-splicing) + (*mbf-free? (cdr _) var))) + form) + ; else + (ormap (fn (_) (*mbf-free? _ var)) form))) + ; else + nil))) + +(mac make-br-fn (body) + " Constructs an anonymous procedure with the body `body'; the procedure will + have bound variables of the form _1 ... _N, where N is the largest of those + variables used in the function. __ will be a rest parameter, and _ is an + alias for _1. Each variable is declared iff it is used. This is used to + implement the [] anonymous functions. " + (with (max 0 arbno nil) + (map1 ; Just for the side-effect; used as "max" + (fn (_) + (withs (s (coerce _ 'string) first (s 0) rest (coerce (cdr (coerce s 'cons)) 'string)) + (and (is (s 0) #\_) + (or (is rest "") + (is rest "_") + (and (some (fn (c) (isnt c #\0)) rest) + (all (fn (c) (in c #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)) rest))) + (*mbf-free? body _) + (let num (or (and (is rest "") 1) (and (is rest "_") (do (set arbno t) -1)) (coerce rest 'int)) + (when (> num max) (set max num))) + nil))) + (*mbf-all-vars (expand body))) + `(fn ,((afn (n) + (if (< n (+ max 1)) + (cons (coerce (+ "_" (coerce n 'string)) 'sym) (self (+ n 1))) + (if arbno + '__ + (if (is max 0) '(_) nil)))) 1) + ,(if (> max 0) + `(let _ _1 ,body) + body)))) + +;;; NO []s ABOVE THIS LINE ;;; + +(def mem (test seq) + " Returns the sublist of `seq' whose first element + satisfies `test'. + This function always returns a scanner. + See also [[find]] [[some]] [[in]]" + (let f (testify test) + (reclist [if (f:car _) _] (scanner seq)))) + +(def find (test seq) + " Returns the first element that matches the test function. + See also [[mem]] [[some]] [[in]] " + (let f (testify test) + (find-internal seq f))) +(def find-internal (seq f) + (reclist [let v (car_) (if (f v) v)] (scanner seq))) +(defm find-internal ((t seq string) f) + (recstring [let v (seq _) (if (f v) v)] seq)) +(defm find-internal ((t seq table) f) + (let rv nil + (each-early-out v seq + (if (f v) + (do (set rv v) + nil) + t)) + rv)) + +(def map (f . seqs) + " Applies the elements of the sequences to the given function. + Returns a sequence containing the results of the function. + See also [[each]] [[mapeach]] [[map1]] [[mappend]] [[andmap]] + [[ormap]] [[reduce]] " + (if (no (cdr seqs)) + (map1 f (car seqs)) + (w/collect-on (car seqs) + ((afn (seqs) + (if (some no seqs) + nil + (do (collect (apply f (map1 car seqs))) + (self (map1 cdr seqs))))) + (map1 scanner seqs))))) + +(def mappend (f . args) + " Applies the elements of the sequences to the given function. + Returns a sequence containing the concatenation of the results + of the function. + See also [[map]] [[join]] " + (apply + nil (apply map f args))) + +(def firstn (n xs) + " Returns the first `n' elements of the given sequence + `xs'. + See also [[cut]] [[nthcdr]] " + (if (no n) + xs + (w/collect-on xs + ((afn (n xs) + (if (and (> n 0) xs) + (do (collect (car xs)) + (self (- n 1) (cdr xs))))) + n (scanner xs))))) + +; Generalization of pair: (tuples x) = (pair x) + +(def tuples (xs (o n 2)) + " Returns a list of sequences of the elements of + the sequence `xs', grouped by `n' elements. + See also [[pair]] " + (w/collect + ((afn (xs) + (collect:firstn n xs) + (self:nthcdr n xs)) + (scanner xs)))) + +(def caris (x val) + " Determines if (car x) is a valid + operation, and that the result of + that operation is `val'. + See also [[is]] [[car]] [[carif]] " + (breakable + (is (on-err (fn (_) (break nil)) + (fn () (car x))) + val))) + +(def warn (msg . args) + " Displays a warning message on its arguments. + See also [[ero]] [[pr]] " + (disp (+ "Warning: " msg ". ")) + (map [do (write _) (disp " ")] args) + (disp #\newline)) + +(mac atomic body + " Performs `body' atomically, blocking other threads. + See also [[atlet]] [[atwith]] [[atwiths]] " + `(atomic-invoke (fn () ,@body))) + +(mac atlet args + " Performs a `let' atomically, blocking other threads. + See also [[atomic]] [[atwith]] [[atwiths]] " + `(atomic (let ,@args))) + +(mac atwith args + " Performs a `with' atomically, blocking other threads. + See also [[atomic]] [[atlet]] [[atwiths]] " + `(atomic (with ,@args))) + +(mac atwiths args + " Performs a `withs' atomically, blocking other threads. + See also [[atomic]] [[atlet]] [[atwith]] " + `(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) + " Defines a setter for the named form. + See also [[=]] " + (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) + (if (ssyntax expr) + (setforms (ssexpand expr)) + (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) + (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 (and (isa place 'sym) (~ssyntax place)) + `(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 + " Assigns values to variables. + See also [[assert]] [[wipe]] [[++]] [[--]] [[rotate]] [[defset]] " + (expand=list args)) + +(mac loop (start test update . body) + " First performs `start'; while `test' is true, performs `body' then + `update' in a loop. + See also [[while]] " + (w/uniq (gfn gparm) + `(do ,start + ((rfn ,gfn (,gparm) + (if ,gparm + (do ,@body ,update (,gfn ,test)))) + ,test)))) + +(mac for (v init max . body) + " Loops for the variable `v' from `init' to `max'. + See also [[repeat]] [[forlen]] " + (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) + " Repeats the `body' `n' times. + See also [[for]] [[forlen]] [[n-of]] " + `(for ,(uniq) 1 ,n ,@body)) + +(mac mapeach (var expr . body) + " Performs `body' for each element of the list returned by `expr', + with each element assigned to `var'; the result of the last expression + in `body' is stored in a returned list of values. + See also [[each]] [[map]] " + `(map1 (fn (,var) ,@body) ,expr)) + +; (nthcdr x y) = (cut y x). + +(def cut (seq start (o end)) + " Returns a subsequence of the given `seq' + If `end' is negative, + it's a 0-based index into the end of the string. + For example, + + > (cut \"abcde\" 1, -1) + \"bcd\" + + See also [[firstn]] [[nthcdr]] [[split]] " + (if (< start 0) (= start (+ (len seq) start))) + (w/collect-on seq + (if end + (do (if (< end 0) (= end (+ (len seq) start -1))) + (each-skip-early-out start i seq + (if (<= end 0) + nil + (do (collect i) + (= end (- end 1)) + t)))) + (each-skip start i seq + (collect i))))) + +(def at (lst n) + " Get the `n'th item of lst, *including* negative indicies. + See also [[cut]] " + (lst (mod n (len lst)))) + +(def prefix (pre str) + " Determines if `pre' is the same as the first part of `str'. " + (and (<= (len pre) (len str)) + (iso pre (cut str 0 (len pre))))) + +(mac ontable (k v h . body) + " Loops through the entries of table or object `h', with key-value pairs + assigned to `k' and `v', respectively. + See also [[each]] [[keys]] " + `(maptable (fn (,k ,v) ,@body) ,h)) + +(mac whilet (var test . body) + " While `test' is true, perform `body' in a loop. + The result of `test' is assigned to `var'. + See also [[while]] [[whiler]] [[drain]] " + (w/uniq (gf gp) + `((rfn ,gf (,gp) + (let ,var ,gp + (when ,var ,@body (,gf ,test)))) + ,test))) + +(def last (xs) + " Returns the last element of `seq'. " + (last-internal:scanner xs)) +(def last-internal (xs) + (if (cdr xs) + (last-internal:cdr xs) + (car xs))) + +(def rem (test seq) + " Returns a sequence with the elements of `seq' that pass `test' removed. + See also [[keep]] [[pull]] " + (keep-internal seq (complement (testify test)))) + +(def keep (test seq) + " Returns a list with the elements of `seq' that pass `test'. + See also [[rem]] [[pull]] " + (keep-internal seq test)) +(def keep-internal (seq f) + (w/scanner-collect-each i seq + (if (f i) (collect i)))) + +(def trues (f seq) + " Returns a list with all `nil's removed. + See also [[rem]] [[keep]] " + (w/scanner-collect-each i seq + (let rv (f i) + (if rv (collect rv))))) + +(mac do1 args + " Performs the body in sequence, then returns the value of the + first expression. + See also [[do]] " + (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. +; almkglor: no, the above can't actually be done, because of +; free variables in expressions + +(mac caselet (var expr . args) + " Matches the result of `expr' to arguments until one matches. + The result of `expr' is assigned to `var'. + See also [[case]] [[if]] [[iflet]] " + (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) + " Matches the result of `expr' to arguments until one matches. + See also [[caselet]] [[if]] " + `(caselet ,(uniq) ,expr ,@args)) + +(mac push (x place) + " Pushes the value `x' on the front of the list in `place'. + See also [[pop]] [[cons]] " + (w/uniq gx + (let (binds val setter) (setforms place) + `(let ,gx ,x + (atwiths ,binds + (,setter (cons ,gx ,val))))))) + +(mac swap (place1 place2) + " Swaps the values of the specified places. + See also [[rotate]] [[=]] " + (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 + " Rotates the values of the specified places, from right to left. + See also [[swap]] [[=]] " + (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) + " Pops a value from the front of the list in `place'. + See also [[push]] [[car]] " + (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)) + " Returns a list with `x' in front of `xs', unless `test' returns true + for some element of `xs' when matched with `x'. + See also [[cons]] [[pushnew]] [[consif]] " + (if (some [test x _] xs) + xs + (cons x xs))) + +(mac pushnew (x place . args) + " Pushes `x' into the front of the list in `place' unless it is + already in that list. + See also [[push]] [[adjoin]] [[cons]] [[consif]] " + (w/uniq gx + (let (binds val setter) (setforms place) + `(atwiths ,(+ (list gx x) binds) + (,setter (adjoin ,gx ,val ,@args)))))) + +(mac pull (test place) + " Removes all elements that pass `test' from the list in `place'. + See also [[rem]] [[keep]] " + (w/uniq g + (let (binds val setter) (setforms place) + `(atwiths ,(+ (list g test) binds) + (,setter (rem ,g ,val)))))) + +(mac ++ (place (o i 1)) + " Increments `place' by the given increment `i' (defaults to 1). + See also [[--]] [[zap]] [[=]] " + (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)) + " Decrements `place' by the given decrement `i' (defaults to 1). + See also [[++]] [[zap]] [[=]] " + (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) + " Modifies `place' with the result of `op' on that `place'. + See also [[++]] [[--]] [[pull]] [[push]] [[pop]] [[=]] + [[wipe]] [[assert]] " + (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)))))) + +(mac wipe args + " Sets each of the given places to nil. + See also [[assert]] [[zap]] [[=]] " + `(do ,@(map (fn (a) `(= ,a nil)) args))) + +(mac assert args + " Sets each of the given places to t. + See also [[wipe]] [[zap]] [[=]] " + `(do ,@(map (fn (a) `(= ,a t)) args))) + +; 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 + " Prints the arguments. + See also [[prn]] [[warn]] [[ero]] " + (map1 disp args) + (car args)) + +(def prn args + " Prints the arguments followed by a newline. + See also [[pr]] [[warn]] [[ero]] " + (do1 (apply pr args) + (writec #\newline))) + +; Destructuring means ambiguity: are pat vars bound in else? (no) + +(mac iflet (var expr then . rest) + " Checks if `expr' is true, and if so, assigns it to `var' and + performs the `then' clause. + See also [[caselet]] [[whenlet]] [[if]] " + (w/uniq gv + `(let ,gv ,expr + (if ,gv (let ,var ,gv ,then) ,@rest)))) + +(mac whenlet (var expr . body) + " Checks if `expr' is true, and if so, assigns it to `var' and + performs the `body'. + See also [[caselet]] [[iflet]] [[when]] [[if]] " + `(iflet ,var ,expr (do ,@body))) + +(mac aif (expr . body) + " Similar to `if' but assigns the result of 'expr' to the variable `it'. + See also [[if]] [[awhen]] [[aand]] [[afn]] " + `(let it ,expr + (if it + ,@(if (cddr body) + `(,(car body) (aif ,@(cdr body))) + body)))) + +(mac awhen (expr . body) + " Similar to `when' but assigns the result of 'expr' to the variable `it'. + See also [[when]] [[aif]] [[aand]] [[afn]] " + `(let it ,expr (if it (do ,@body)))) + +(mac aand args + " Similar to `and' but assigns the previous expression to the variable `it'. + See also [[and]] [[aif]] [[awhen]] [[afn]] " + (if (no args) + 't + (no (cdr args)) + (car args) + `(let it ,(car args) (and it (aand ,@(cdr args)))))) + +(mac accum (accfn . body) + " Collects or accumulates the values given to all calls to `accfn' within + `body' and returns a list of those values. Order is not preserved. + See also [[w/collect]] [[accums]] [[summing]] " + (w/uniq gacc + `(withs (,gacc nil ,accfn [push _ ,gacc]) + ,@body + ,gacc))) + +(mac accums (accfns . body) + " Collects or accumulates the values given to all calls to functions + named in `accfns' in body. Returns a list of lists of those values. + Order is not preserved. + See also [[accum]] " + (let gaccs (map [uniq] accfns) + `(withs ,(mappend (fn (gacc accfn) + (list gacc 'nil accfn `[push _ ,gacc])) + gaccs accfns) + ,@body + (list ,@(map [list 'rev _] gaccs))))) + +; Repeatedly evaluates its body till it returns nil, then returns vals. + +(mac drain (expr (o eof nil)) + " Repeatedly evaluates `expr' until it returns nil, then returns a list + of the true values. + See also [[while]] [[whiler]] [[whilet]] " + (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) + " Performs `body' while `expr' is not `endval', assigning the result of + `expr' to `var'. + See also [[while]] [[whilet]] [[drain]] " + (w/uniq (gf ge) + `(let ,ge ,endval + ((rfn ,gf (,var) + (when (and ,var (no (is ,var ,ge))) + ,@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) + " Adds `x' to the front of the list `y' if `x' is true. + See also [[cons]] [[if]] [[adjoin]] " + (if x (cons x y) y)) + +(def string args + " Creates a string from its arguments + See also [[sym]] " + (apply + "" (map [coerce _ 'string] args))) + +(def flat (x (o stringstoo)) + " Flattens a nested list. + See also [[list]] " + ((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)) + +(mac check (x test (o alt)) + " Returns `x' if it passes `test', otherwise returns `alt'. + See also [[or]] " + (w/uniq gx + `(let ,gx ,x + (if (,test ,gx) ,gx ,alt)))) + +(def pos (test seq (o start 0)) + " Returns the position of the first element in `seq' that passes `test'. + See also [[some]] " + (with (f (testify test) + rv nil) + (each-skip-early-out start i seq + (if (f i) + (do (set rv start) + nil) + (do (++ start) + t))) + rv)) + +(def even (n) " Determines if a number is even. See also [[odd]] " (is (mod n 2) 0)) + +(def odd (n) " Determines if a number is odd. See also [[even]] " (no (even n))) + +(mac after (x . ys) + " Ensures that the body is performed after the expression `x', + even if it fails. + See also [[do]]" + `(protect (fn () ,x) (fn () ,@ys))) + +(let expander + (fn (f var name body) + `(let ,var (,f ,name) + (after (do ,@body) (close ,var)))) + + ; TODO: fix these to use 'dynamic-wind instead: + ; have the exit function save the conditions of + ; the stream to be closed (i.e. file position) + ; have the enter function check for saved + ; conditions and restore them if so. + ; This will allow them to be safely used in + ; coroutines. + (mac w/infile (var name . body) + " Opens the given file `name' for input, assigning the stream to `var'. + The stream is automatically closed on exit from the `body'. + See also [[w/outfile]] [[w/instring]] [[w/stdin]] [[w/socket]] " + (expander 'infile var name body)) + + (mac w/outfile (var name . body) + " Opens the given file `name' for output, assigning the stream to `var'. + The stream is automatically closed on exit from the `body'. + See also [[w/infile]] [[w/appendfile]] [[w/outstring]] [[w/stdout]] " + (expander 'outfile var name body)) + + (mac w/instring (var str . body) + " Opens the given string `str' for input, assigning the stream to `var'. + The stream is automatically closed on exit from the `body'. + See also [[w/outstring]] [[fromstring]] [[w/infile]] [[w/stdin]] + [[w/socket]] " + (expander 'instring var str body)) + + (mac w/socket (var port . body) + " Opens the port for listening, assigning the stream to `var'. + The stream is automatically closed on exit from the `body'. + See also [[w/infile]] [[w/instring]] [[w/stdin]] " + (expander 'open-socket var port body)) + ) + +(mac w/outstring (var . body) + " Opens a string for output, assigning the stream to `var'. + The stream is automatically closed on exit from the `body'. + The contents of the string can be accessed via (inside `var') + See also [[w/instring]] [[tostring]] [[w/outfile]] [[w/stdout]] " + `(let ,var (outstring) ,@body)) + +(mac w/appendfile (var name . body) + " Opens a file `name' for append, assigning the stream to `var'. + The stream is automatically closed on exit from the `body'. + See also [[w/outfile]] [[w/infile]] " + `(let ,var (outfile ,name 'append) + (after (do ,@body) (close ,var)))) + +; rename this simply "to"? - prob not; rarely use + +(mac w/stdout (str . body) + " Opens the stream `str' for output; normal printed output from `body' + is redirected to the stream. + See also [[w/stdin]] [[w/outfile]] [[w/outstring]] " + `(call-w/stdout ,str (fn () ,@body))) + +(mac w/stdin (str . body) + " Opens the stream `str' for input; normal read input from `body' + is redirected from the stream. + See also [[w/stdout]] [[w/infile]] [[w/instring]] [[w/socket]] " + `(call-w/stdin ,str (fn () ,@body))) + +(mac tostring body + " Returns the printed standard output from `body' as a string. + See also [[fromstring]] [[w/stdout]] [[w/outstring]] " + (w/uniq gv + `(w/outstring ,gv + (w/stdout ,gv ,@body) + (inside ,gv)))) + +(mac fromstring (str . body) + " Redirects read standard input to `body' from the given string `str'. + See also [[tostring]] [[w/stdin]] [[w/instring]] " + (w/uniq gv + `(w/instring ,gv ,str + (w/stdin ,gv ,@body)))) + +(def readstring1 (s (o eof nil)) + " Reads a single expression from the string. + See also [[read]] " + (w/instring i s (read i eof))) + +(def read ((o s (stdin)) (o eof)) + " Reads a single expression from a string or stream. + See also [[readstring1]] [[readfile]] [[readfile1]] [[readall]] " + (sread s eof)) +(defm read ((t s string) (o eof)) + (readstring1 s eof)) + +(def readfile (name) + " Reads the expressions from the file `name', and returns a list of + expressions read from the file. + See also [[read]] " + (w/infile s name (drain (read s)))) + +(def readfile1 (name) + " Reads a single expression from the file `name'. + See also [[read]] " + (w/infile s name (read s))) + +(def writefile1 (val name) + " Writes the value to the file `name'. + See also [[writefileraw]] " + (w/outfile s name (write val s)) val) + +(def writefileraw (val name) + " Write a list of bytes in val to a file. + See also [[writefile1]] " + (w/outfile s name (map [writeb _ s] val))) + +(def readall (src (o eof nil)) + " Reads the expressions from the string or stream `src', and returns a + list of expressions read from the file. + See also [[read]] " + ((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) + " Returns the symbol for `x'. + See also [[string]] " + (coerce x 'sym)) + +(mac rand-choice exprs + " Returns the result of one of the given `exprs', chosen at random. + See also [[random-elt]] " + `(case (rand ,(len exprs)) + ,@(let key -1 + (mappend [list (++ key) _] + exprs)))) + +(mac n-of (n expr) + " Repeats `expr' `n' times, then returns the results in a list. + See also [[repeat]] " + (w/uniq ga + `(let ,ga nil + (repeat ,n (push ,expr ,ga)) + (rev ,ga)))) + +(def rand-string (n) + " Generates a random string of letters and numbers, starting with a letter. " + (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) + " Loops across the length of the sequence `s'. + See also [[repeat]] [[each]] [[on]] " + `(for ,var 0 (- (len ,s) 1) ,@body)) + +(mac on (var s . body) + " Loops across the sequence `s', assigning each element to `var', + and providing the current index in `index'. + See also [[each]] [[forlen]] " + (if (is var 'index) + (err "Can't use index as first arg to on.") + `(symeval!on-f ,s (fn (,var index) ,@body)))) +(def on-f (s bf) + (let index 0 + (each i s + (bf i index) + ++.index))) + +(def best (f seq) + " Selects the best element of `seq' according to `f'. + `f' is a comparison function between elements of `seq'. + See also [[max]] [[most]] " + (if (no seq) + nil + (let wins (car seq) + (each elt (cdr seq) + (if (f elt wins) (= wins elt))) + wins))) + +(def max args + " Returns the highest argument. + See also [[min]] [[best]] [[most]] " + (best > args)) +(def min args + " Returns the lowest argument. + See also [[max]] [[best]] [[most]] " + (best < args)) + +; (mac max2 (x y) +; (w/uniq (a b) +; `(with (,a ,x ,b ,y) (if (> ,a ,b) ,a ,b)))) + +(def most (f seq) + " Selects the element of `seq' with the highest [f _]. + `f' is a score function for elements of `seq'. + See also [[best]] [[least]] " + (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))) + +(def least (f seq) + " Selects the element of `seq' with the lowest [f _]. + `f' is a score function for elements of `seq'. + See also [[most]] " + (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. + +; almkglor: these are part of the vN-sort-internals +(def insert-sorted (test elt seq) + " Inserts `elt' into a sequence `seq' sorted by `test'. + See also [[sort]] [[insort]] [[reinsert-sorted]] " + (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) + " Inserts `elt' into a sequence in the place `seq' sorted by `test'. + See also [[insert-sorted]] [[sort]] " + `(zap [insert-sorted ,test ,elt _] ,seq)) + +(def reinsert-sorted (test elt seq) + " Inserts `elt' into a sequence `seq', partially sorted by `test'. + See also [[insert-sorted]] [[insortnew]] [[sort]] " + (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) + " Inserts `elt' into a sequence in the place `seq', partially sorted + by `test'. + See also [[reinsert-sorted]] [[sort]] " + `(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) + " Creates a function that will store results of calls to the given + source function. + For each set of arguments, the source function will only be called + once; if the memo'ed function is called again with the same arguments, + it will return the stored result instead of calling the source function. + See also [[defmemo]] " + (let cache (table) + (fn args + (or (cache args) + (= (cache args) (apply f args)))))) + +(mac defmemo (name parms . body) + " Defines a function that automatically stores the results of calls. + For each set of arguments, this function will only execute once. + If the function is called again with the same arguments, it will + immediately return the stored result for that set of arguments. + See also [[memo]] " + `(safeset ,name (memo (fn ,parms ,@body)))) + +(def whitec (c) + " Determines if the given `c' is a whitespace character. + See also [[alphadig]] [[nonwhite]] [[punc]] " + (in c #\space #\newline #\tab #\return)) + +(def nonwhite (c) + " Determines if the given `c' is not a whitespace character. + See also [[whitec]] [[alphadig]] [[punc]] " + (no (whitec c))) + +(def alphadig (c) + " Determines if the given `c' is an alphanumeric character. + See also [[whitec]] [[nonwhite]] [[punc]] " + (or (<= #\a c #\z) (<= #\A c #\Z) (<= #\0 c #\9))) + +(def punc (c) + " Determines if the given `c' is punctuation character. + See also [[whitec]] [[nonwhite]] [[alphadig]] [[punc]] " + (in c #\. #\, #\; #\: #\! #\?)) + +(def readline ((o str (stdin))) + " Reads a string terminated by a newline from the stream `str'. " + (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) + " Counts the number of times `sumfn' is called with a true value + within `body'. + See also [[accum]] " + (w/uniq (gc gt) + `(let ,gc 0 + (let ,sumfn (fn (,gt) (if ,gt (++ ,gc))) + ,@body) + ,gc))) + +(def treewise (f base tree) + " Traverses a list as a binary tree. + See also [[trav]] [[tree-subst]] [[ontree]] " + (if (atom tree) + (base tree) + (f (treewise f base (car tree)) + (treewise f base (cdr tree))))) + +(def carif (x) + " Returns the first element of a list if the argument + is a scanner. + See also [[car]] [[caris]] " + (on-err (fn (c) nil) + (fn () (car x)))) + +; Could prob be generalized beyond printing. + +(def prall (elts (o init "") (o sep ", ")) + " Prints several arguments with an initial header and separated by a + given separator. + See also [[prs]] " + (when elts + (pr init (car elts)) + (map [pr sep _] (cdr elts)) + elts)) + +(def prs args + " Prints several arguments separated by spaces. + See also [[prall]] " + (prall args "" #\space)) + +(def tree-subst (old new tree) + " Replaces an element of a list with that list treated as a binary tree. + See also [[treewise]] [[trav]] " + (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) + " Applies a function across each node of a list with that list treated + as a binary tree. + See also [[treewise]] [[trav]] " + (f tree) + (unless (atom tree) + (ontree f (car tree)) + (ontree f (cdr tree)))) + +(def fill-table (table data) + " Fills `table' with key-value pairs in the `data' list. + See also [[table]] " + (each (k v) (pair data) (= (table k) v)) + table) + +(mac obj args + " Creates an object with the specified entries. + See also [[inst]] [[table]] " + (w/uniq g + `(let ,g (table) + ,@(map (fn ((k v)) `(= (,g ',k) ,v)) + (pair args)) + ,g))) + +(def keys (h) + " Returns a list of keys in the table or object `h'. + See also [[vals]] [[table]] " + (w/collect (ontable k v h (collect k)))) + +(def vals (h) + " Returns a list of values in the table or object `h'. + See also [[keys]] [[table]] " + (accum a (ontable k v h (a v)))) + +; These two should really be done by coerce. Wrap coerce? + +(def tablist (h) + " Transforms a table or object `h' into an association list. + See also [[listtab]] [[alref]] [[assoc]] " + (accum a (maptable (fn args (a args)) h))) + +(def listtab (al) + " Transforms an association list into a table or object. + See also [[tablist]] [[alref]] [[assoc]] " + (let h (table) + (map (fn ((k v)) (= (h k) v)) + al) + h)) + +(def load-table (file (o eof)) + " Loads an association list from `file' into a table or object. + See also [[load-tables]] [[read-table]] [[save-table]] [[listtab]] " + (w/infile i file (read-table i eof))) + +(def read-table ((o i (stdin)) (o eof)) + " Loads an association list from the stream `i' into a table or object. + See also [[load-tables]] [[load-table]] [[write-table]] [[listtab]] " + (let e (read i eof) + (if (alist e) (listtab e) e))) + +(def load-tables (file) + " Loads several association lists from `file' into a list of tables or + objects. + See also [[load-table]] [[read-table]] " + (w/infile i file + (w/uniq eof + (drain (read-table i eof) eof)))) + +(def save-table (h file) + " Writes a table or object `h' to `file'. + See also [[write-table]] [[load-table]] [[tablist]] " + (w/outfile o file (write-table h o))) + +(def write-table (h (o o (stdout))) + " Writes a table or object `h' to the stream `o'. + See also [[save-table]] [[read-table]] [[tablist]] " + (write (tablist h) o)) + +(def copy (x . args) + " Creates a copy of an existing argument `x'. + Additional arguments replace specified + indices. + Note that this function has assumptions + that are not exactly in-line with the + `scanner' idiom in Arc-F + See also [[rev]] [[copy-seq]] " + (let x2 (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)) + (map (fn ((k v)) (= (x2 k) v)) + (pair args)) + x2)) + +(def copy-seq (x) + " Creates a copy of the sequence `seq' " + (w/scanner-collect-each i x (collect i))) + +(def seq-to-list (x) + " Converts the sequence `seq' to a true list " + (w/collect:each i x + (collect i))) + +(def abs (n) + " Returns the absolute value of a number. + See also [[signop]] " + (if (< n 0) (- n) n)) + +(def signop (n) + " Returns the sign of a number as the function `+' or `-'. + See also [[abs]] " + (if (< n 0) - +)) + +; 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) + " Rounds off a fractional value to the nearest whole number. + See also [[roundup]] [[to-nearest]] " + (withs (base (trunc 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) + " Rounds off a fractional value to the nearest absolute highest + whole number. + See also [[round]] [[to-nearest]] " + (withs (base (trunc n) rem (abs (- n base))) + (if (>= rem 1/2) + ((if (> n 0) + -) base 1) + base))) + +(def to-nearest (n quantum) + " Rounds off `n' to the nearest multiple of `quantum'. + See also [[round]] [[roundup]] " + (* (roundup (/ n quantum)) quantum)) + +(def avg (ns) " Averages all numbers in `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) + " Sorts `seq' according to `test'. " + (unscan seq + (mergesort test (seq-to-list seq)))) + +; Destructive stable merge-sort, adapted from slib and improved +; by Eli Barzilay for MzLib; re-written in Arc. + +(def mergesort (less? lst) + " Destructively sorts a list `lst' according to `less?'. " + (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) + ; (and (not (less? (car next) last)) + ; (loop (car next) (cdr next))))) + ; lst + ((afn (n) + (if (> n 2) + ; needs to evaluate L->R + (withs (j (/ (if (even n) n (- n 1)) 2) ; faster than round + a (self j) + b (self (- n j))) + (merge less? a b)) + ; the following case just inlines the length 2 case, + ; it can be removed (and use the above case for n>1) + ; and the code still works, except a little slower + (is n 2) + (with (x (car lst) y (cadr lst) p lst) + (= lst (cddr lst)) + (when (less? y x) (scar p y) (scar (cdr p) x)) + (scdr (cdr p) nil) + p) + (is n 1) + (with (p lst) + (= lst (cdr lst)) + (scdr p nil) + p) + nil)) + n)))) + +; Also by Eli. + +(def merge (less? x y) + " Merges two sorted lists by `less?'. " + (if (no x) y + (no y) x + (let lup nil + (set lup + (fn (r x y r-x?) ; r-x? for optimization -- is r connected to x? + (if (less? (car y) (car x)) + (do (if r-x? (scdr r y)) + (if (cdr y) (lup y x (cdr y) nil) (scdr y x))) + ; (car x) <= (car y) + (do (if (no r-x?) (scdr r x)) + (if (cdr x) (lup x (cdr x) y t) (scdr x y)))))) + (if (less? (car y) (car x)) + (do (if (cdr y) (lup y x (cdr y) nil) (scdr y x)) + y) + ; (car x) <= (car y) + (do (if (cdr x) (lup x (cdr x) y t) (scdr x y)) + x))))) + +(def bestn (n f seq) + " Returns a list of the best `n' elements of seq according to + the comparison function `f'. + See also [[best]] " + (firstn n (sort f seq))) + +(def split (seq pos) + " Splits the list `seq' at offset `pos', returning a + two-element list of the split. + See also [[cut]] " + (withs (mid (nthcdr (- pos 1) seq) + s2 (cdr mid)) + (wipe (cdr mid)) + (list seq s2))) + +(def ssplit (str (o delim whitec) (o keepdelim) (o noblanks)) + "Split `str' on chars passing the test `delim', returning a list of + strings. If `keepdelim' is non-nil include the delimiters. If + `noblanks' is non-nil empty strings are excluded." + (if (isa delim 'string) (= delim [in _ (coerce delim 'cons)])) + (with (acc nil j 0) + (forlen i str + (if (and (or (no keepdelim) (> i 0)) + (delim (str i))) + (do (push (cut str j i) acc) + (= j (if keepdelim i (+ i 1))))) + (if (and (atend i str) + (<= j i)) + (push (cut str j (+ i 1)) acc))) ; add 1 because atend is true prematurely + (rev (if noblanks (rem empty acc) acc)))) + +(mac time (expr) + " Prints the time consumed by the `expr', returning the result. " + (w/uniq (t1 t2) + `(let ,t1 (msec) + (do1 ,expr + (let ,t2 (msec) + (prn "time: " (- ,t2 ,t1) " msec.")))))) + +(mac jtime (expr) + " Prints the time consumed by `expr', returning `ok' when the + expression completes. " + `(do1 'ok (time ,expr))) + +(mac time10 (expr) + " Prints the time consumed by executing `expr' 10 times " + `(time (repeat 10 ,expr))) + +(def union (f xs ys) + (w/collect-on xs + (each x xs (collect x)) + (each y ys (if (~some [f _ y] xs) + (collect y))))) + +(= templates* (table)) + +(mac deftem (tem . fields) + " Defines an object template for field values, with inclusion for + existing templates. + See also [[inst]] [[templatize]] [[temread]] [[temload]] [[temloadall]] " + (withs (name (carif tem) includes (if (acons tem) (cdr tem))) + `(= (templates* ',name) + (+ (mappend templates* ',(rev includes)) + (list ,@(map (fn ((k v)) `(list ',k (fn () ,v))) + (pair fields))))))) + +(mac addtem (name . fields) + `(= (templates* ',name) + (union (fn (x y) (is (car x) (car y))) + (list ,@(map (fn ((k v)) `(list ',k (fn () ,v))) + (pair fields))) + (templates* ',name)))) + +(def inst (tem . args) + " Creates an object instantiating a given template. + See also [[deftem]] [[templatize]] [[temread]] [[temload]] [[temloadall]] " + (let x (table) + (each (k v) (templates* tem) + (unless (no v) (= (x k) (v)))) + (each (k v) (pair args) + (= (x k) v)) + x)) + +; To write something to be read by temread, (write (tablist x)) + +(def temread (tem (o str (stdin))) + " Reads an association list from the stream `str' and creates an + object instantiating the given template containing the data in + the association list. + See also [[deftem]] [[inst]] [[templatize]] [[temload]] [[temloadall]] " + (templatize tem (read str))) + +; Converts alist to inst; ugly; maybe should make this part of coerce. +; Note: discards fields not defined by the template. + +(def templatize (tem raw) + " Creates an object instantiating a given template containing the + data in the association list `raw'. + See also [[deftem]] [[inst]] [[temread]] [[temload]] [[temloadall]] " + (with (x (inst tem) fields (templates* tem)) + (each (k v) raw + (when (assoc k fields) + (= (x k) v))) + x)) + +(def temload (tem file) + " Reads an association list from `file' and creates an object + instantiating the given template containing the data in the + association list. + See also [[deftem]] [[inst]] [[templatize]] [[temread]] [[temloadall]] " + (w/infile i file (temread tem i))) + +(def temloadall (tem file) + " Reads all association lists from `file' and creates a list + of objects instantiating the given template containing the + data in each association list. + See also [[deftem]] [[inst]] [[templatize]] [[temread]] [[temload]]" + (map (fn (pairs) (templatize tem pairs)) + (w/infile in file (readall in)))) + +(def tems () + " Pretty print templates defined in `templates*'. + See also [[deftem]] [[inst]] [[templatize]] [[temread]] [[temload]] " + (each k (keys templates*) + (prn k " " (map car (templates* k))))) + +(def number (n) " Determines if `n' is a number. " (in (type n) 'int 'num)) + +(def since (t1) (- (seconds) t1)) + +(def minutes-since (t1) (/ (since t1) 60)) + +(def hours-since (t1) (/ (since t1) 3600)) + +(def days-since (t1) (/ (since t1) 86400)) + +(def cache (timef valf) + " Caches the result of a call to `valf' until a number of seconds + greater than the result of a call to `timef' have passed. " + (with (cached nil gentime nil) + (fn () + (unless (and cached (< (since gentime) (timef))) + (= cached (valf) + gentime (seconds))) + cached))) + +(mac errsafe (expr) + " Executes `expr' and blocks any errors " + `(on-err (fn (c) nil) + (fn () ,expr))) + +(def saferead (arg) + " Reads an expression, blocking any errors. " + (errsafe (read arg))) + +(def safe-load-table (filename) + " Loads a table from `filename', blocking any errors. " + (or (errsafe (load-table filename)) + (table))) + +(def mkdir (path (o parents)) + " Creates a directory. + If `parents' is non-nil, parent directories are created as needed." + ((let os (which-os) + (if + ; If we're running Unix, MzScheme <371 has a bug + ; where make-directory sets the sticky bit. + ; Thus, we want to use system instead. + (or (is os 'unix) (is os 'macosx)) + [system (string "mkdir " (if parents "-p ") _)] + + parents make-directory* + make-directory)) + path)) + +(def ensure-dir (path) + " Ensures that the specified directory exists, and creates it if not + yet created. " + (unless (dir-exists path) + (mkdir path t))) + +(def pad (val digits (o char #\ )) + (= val (string val)) + (string (n-of (- digits (len val)) char) val)) + +(def date ((o time (seconds))) + " Returns the date as a string in YYYY-MM-DD format. " + (let date (datetbl time) + (string (pad (date 'year) 4 #\0) "-" + (pad (date 'month) 2 #\0) "-" + (pad (date 'day) 2 #\0)))) + +(def count (test x) + " Counts the number of elements in `x' which pass `test'. " + (with (n 0 testf (testify test)) + (each elt x + (if (testf elt) (++ n))) + n)) + +(def ellipsize (str (o limit 80)) + " Trims a string `str' with `...' if it is longer than the given `limit'. " + (if (<= (len str) limit) + str + (+ (cut str 0 limit) "..."))) + +(def random-elt (seq) + " Returns an element of `seq' chosen by random. + See also [[rand-choice]] " + (withs (l (len seq) + r (rand l)) + (each-skip-early-out r i seq + (= r i) + nil) + r)) + +(mac until (test . body) + " While `test' is false, perform `body' in a loop. + See also [[while]] " + `(while (symeval!no ,test) ,@body)) + +(def before (x y seq (o i 0)) + " Determines if `x' exists before `y' in `seq'. " + (with (x (testify x) + y (testify y) + rv nil) + (each-skip-early-out i v seq + (if + (y i) + nil + (x i) + (do (assert rv) + nil) + ; else just iterate + t)) + rv)) + +(def par (f . args) + " Partially apply `f' to `args'; i.e., return a function which, when called, + calls `f' with `args' and the arguments to the new function. " + (fn newargs (apply f (join args newargs)))) + +;(def orf fns +; " Creates a function which returns true on its argument if any of the +; given `fns' return true on that argument. " +; (fn (x) (some [_ x] fns))) + +;(def andf fns +; " Creates a function which returns true on its argument if all of the +; given `fns' return true on that argument. " +; (fn (x) (all [_ x] fns))) + +(def atend (i s) + " Determines if the index `i' is at or beyond the end of the sequence `s'. " + (> i (- (len s) 2))) + +(def multiple (x y) + " Determines if `x' is a multiple of `y'. " + (is 0 (mod x y))) + +(mac nor args + " Computes arguments until one of them returns true, then returns nil, + or else returns true. " + `(symeval!no (or ,@args))) + +; Consider making the default sort fn take compare's two args (when do +; you ever have to sort mere lists of numbers?) and rename current sort +; as prim-sort or something. + +; Could simply modify e.g. > so that (> len) returned the same thing +; as (compare > len). + +(def compare (comparer scorer) + " Creates a function that compares using `comparer' the result of `scorer' + on its arguments. " + (fn (x y) (comparer (scorer x) (scorer y)))) + +; Cleaner thus, but may only ever need in 2 arg case. + +;(def compare (comparer scorer) +; (fn args (apply comparer map scorer args))) + +; (def only (f g . args) (aif (apply g args) (f it))) + +(def only (f) + (fn args (if (car args) (apply f args)))) + +(mac conswhen (f x y) + " Adds `x' to the front of `y' if `x' passes the test `f'. " + (w/uniq (gf gx) + `(with (,gf ,f ,gx ,x) + (if (,gf ,gx) (symeval!cons ,gx ,y) ,y)))) + +; Could rename this get, but don't unless it's frequently used. +; Could combine with firstn if put f arg last, default to (fn (x) t). + +(def firstn-that (n f xs) + " Returns the first `n' elements of `xs' which pass `f'. " + (w/collect-on xs + (each-early-out i xs + (if + (<= n 0) + nil + (f i) + (do (collect i) + --.n) + t)))) + +(def dedup (xs) + " Removes duplicated elements from `xs'. " + (let h (table) + (w/collect:each x xs + (unless (h x) + (collect x) + (assert (h x)))))) + +(def single (x) + " Determines if `x' is a sequence with only one element. " + (breakable:no (cdr (on-err (fn (c) (break nil)) + (fn () (scanner x)))))) + +(def intersperse (x ys) + " Inserts `x' between elements of `ys'. " + (let first t + (w/scanner-collect-each y ys + (if first + (wipe first) + (collect x)) + (collect y)))) + +(def counts (seq (o c (table))) + " Returns a table with elements of `seq' as keys and the number of + occurences of that element as values. " + (each i seq + (zap [if _ (+ _ 1) 1] (c i))) + c) + +(def commonest (seq) + " Returns a two-element list containing the most common element of + `seq' and the number of times it occured in the sequence. " + (with (winner nil n 0) + (ontable k v (counts seq) + (when (> v n) (= winner k n v))) + (list winner n))) + +; I cleaned up PG's really, really weird version of +; 'reduce, which has really weird behavior in the case +; when xs is empty and init is not given +; @PG: Stop being a Larry Wall. Not everyone will +; need your particular peculiar specializations. +; + +(w/uniq initsym + ; Left-associative + (def reduce (f xs (o init initsym)) + " Applies `f' to an accumulated result on the elements of `xs'. + Elements are processsed left-to-right. " + (let (init . xs) + (if (is init initsym) + xs + (cons init xs)) + (each i xs + (zap f init xs)) + init)) + + ; Right-associative + ; Rather inefficent due to recursive call not being in the tail position. + ; also because of scanner conversion + (def rreduce (f xs (o init initsym)) + " Applies `f' to an accumulated result on the elements of `xs'. + Elements are processed right-to-left. " + (if (no xs) + (if (isnt init initsym) init) + ((afn (xs) + (if + (cdr xs) + (f (car xs) (self:cdr xs)) + (is init initsym) + (car xs) + (f (car xs) init))) + (scanner xs))))) + +(let argsym (uniq) + + (def parse-format (str) + " Parses a simple ~-format string. " + (rev (accum a + (with (chars nil i -1) + (w/instring s str + (whilet c (readc s) + (case c + #\# (do (a (coerce (rev chars) 'string)) + (wipe chars) + (a (read s))) + #\~ (do (a (coerce (rev chars) 'string)) + (wipe chars) + (readc s) + (a (list argsym (++ i)))) + (push c chars)))) + (when chars + (a (coerce (rev chars) 'string))))))) + + (mac prf (str . args) + " Prints according to a format string, replacing ~* with arguments. " + `(let ,argsym (list ,@args) + (pr ,@(parse-format str)))) +) + +(wipe load-file-stack*) +(def load (file (o hook idfn)) + " Reads the expressions in `file' and evaluates them. Read expressions + may be preprocessed by `hook'. + See also [[require]]. " + (atwith (file (load-resolve file) + context (cxt)) + (push current-load-file* load-file-stack*) + (= current-load-file* file) + (after + (w/uniq eof + (w/infile f file + (whiler e (read f eof) eof + (eval (hook:cxt-ref-d context e))))) + (do (= current-load-file* (pop load-file-stack*)) + nil)))) + +(= required-files* (table)) +(= (required-files* (load-resolve "arc.arc")) t) + +(def require (file) + " Loads `file' if it has not yet been `require'd. Can be fooled by changing + the name ((require \"foo.arc\") as opposed to (require \"./foo.arc\")), but + this should not be a problem. + See also [[load]]. " + (let file (load-resolve file) + (or (required-files* file) + (do + (= (required-files* file) t) + (load file))))) + +(def positive (x) + " Determines if `x' is a number and is positive. " + (and (number x) (> x 0))) + +(mac w/table (var . body) + " Creates a table assigned to `var' for use in `body'. " + `(let ,var (table) ,@body ,var)) + +(def ero args + " Outputs `args' to error output. " + (w/stdout (stderr) + (write (car args)) + (each a (cdr args) + (writec #\space) + (write a)) + (writec #\newline)) + (car args)) + +(def lock () + " Creates a mutex lock. + See also [[thread]] [[w/lock]] " + (let rv (sema) + (sema-post rv) + (annotate 'lock + rv))) + +(mac w/lock (l . body) + " Attempts to acquire a single mutex lock. + A single thread should not attempt to + acquire the same lock more than once, or + it will deadlock itself. + Care must be taken when acquiring + multiple locks. + See also [[lock]] " + `(symeval!w/lock-f ,l (fn () ,@body))) + +(def w/lock-f (l bf) + (err "'w/lock attempted to lock a non-lock object")) +(defm w/lock-f ((t l lock) bf) + (let sm (rep l) + (dynamic-wind + (fn () (sema-wait sm)) + bf + (fn () (sema-post sm))))) + +(def queue () + " Creates a queue. + See also [[enq]] [[deq]] [[qlen]] [[qlist]] [[enq-limit]]" + (list nil nil 0)) + +; Despite call to atomic, once had some sign this wasn't thread-safe. +; Keep an eye on it. + +(def enq (obj q) + " Adds `obj' to a queue. See also [[queue]] " + (atomic + (++ (q 2)) + (if (no (car q)) + (= (cadr q) (= (car q) (list obj))) + (= (cdr (cadr q)) (list obj) + (cadr q) (cdr (cadr q)))) + (car q))) + +(def deq (q) + " Removes and returns an item from a queue. See also [[queue]] " + (atomic (unless (is (q 2) 0) (-- (q 2))) + (pop (car q)))) + +; Should redef len to do this, and make queues lists annotated queue. + +(def qlen (q) " Returns the number of items in a queue. See also [[queue]] " + (q 2)) + +(def qlist (q) " Returns the queue contents as a list. See also [[queue]] " + (car q)) + +;; unsafe - suppose we have (enq-limit x q 10) and (enq-limit x q 1000) +;; somewhere else? +(def enq-limit (val q (o limit 1000)) + " Adds an item to the queue; removes a queue item if `limit' is + exceeded. See also [[queue]] " + (atomic + (unless (< (qlen q) limit) + (deq q)) + (enq val q))) + +(def median (ns) + " Computes the median of an unsorted list. " + ((sort > ns) (trunc (/ (len ns) 2)))) + +(mac noisy-each (n var val . body) + " Performs `body' for each element of the sequence returned by `expr', + with each element assigned to `var'; prints a `.' every `n' elements. " + `(symeval!noisy-each-f ,val ,n (fn (,var) ,@body))) +(def noisy-each-f (seq n bf) + (let i 0 + (each e seq + (when (multiple (++ i) n) + (pr #\.)) + (bf e)) + (prn))) + +(mac point (name . body) + " Creates a form which may be exited by calling `name' from within `body'. + See also [[catch]] [[breakable]] " + `(symeval!ccc (fn (,name) ,@body))) + +(mac catch body + " Catches any value returned by `throw' within `body'. + See also [[breakable]] [[point]] " + `(point throw ,@body)) + +(def downcase (x) + " Converts `x' to lowercase, if a character, string, or symbol; + otherwise, raises an error. " + (err "'downcase expects a character, string, or symbol")) + ; TODO: unicode support +(let downc (fn (c) + (let n (coerce c 'int) + (if (or (< 64 n 91) (< 191 n 215) (< 215 n 223)) + (coerce (+ n 32) 'char) + c))) + (defm downcase ((t x char)) + (downc x)) + (defm downcase ((t x string)) + (map downc x)) + (defm downcase ((t x sym)) + (sym (map downc (string x))))) + +(def upcase (x) + " Converts `x' to uppercase, if a character, string, or symbol; + otherwise, raises an error. " + (err "'upcase expects a character, string, or symbol")) + ; TODO: unicode support +(let upc (fn (c) + (let n (coerce c 'int) + (if (or (< 96 n 123) (< 223 n 247) (< 247 n 255)) + (coerce (- n 32) 'char) + c))) + (defm upcase ((t x char)) + (upc x)) + (defm upcase ((t x string)) + (map upc x)) + (defm upcase ((t x sym)) + (sym (map upc (string x))))) + +(def range (start end (o step 1)) + "Return a range of numbers from `start' to `end', by `step'." + (given stopcond (if (> step 0) > <) + acc (cons start nil) + (unless (stopcond start end) + ((afn (acc tl n) + (if (stopcond n end) + acc + (self acc (= (cdr tl) (cons n nil)) (+ n step)))) + acc acc (+ start step))))) + +(def mismatch (s1 s2) + " Returns the first index where `s1' and `s2' do not match. " + (breakable:let s2 (scanner s2) + (on i s1 + (unless (is i (car s2)) + (break index)) + (zap cdr s2)))) + +(def memtable (ks) + " Creates a membership table which returns t for each element in `ks' and + nil otherwise. " + (let h (table) + (each k ks (assert (h k))) + h)) + +(= bar* " | ") + +(mac w/bars body + " Prints out the strings printed by each expression in `body', + separated by vertical bars. " + (w/uniq (out needbars) + `(let ,needbars nil + (do ,@(map (fn (e) + `(let ,out (tostring ,e) + (unless (is ,out "") + (if ,needbars + (pr bar* ,out) + (do (assert ,needbars) + (pr ,out)))))) + body))))) + +(def len< (x n) (< (len x) n)) + +(def len> (x n) (> (len x) n)) + +(mac thread body + " Launches the expressions in `body' in a new thread, returning the + thread ID for that thread. " + `(new-thread (fn () ,@body))) + +(mac trav (x . fs) + " Traverses an object `x'; the object is applied to each function + in `fs', and sub-nodes of the object may be traversed by + (self ) in any of the functions. + See also [[trav+]] [[treewise]] [[ontree]] " + (w/uniq g + `((afn (,g) + (when ,g + ,@(map [list _ g] fs))) + ,x))) + +(mac trav+ ((go n) s . body) + " Traverses an object `s'; the object is named by `n' and sub-nodes + of the object may be traversed by (`go' ...) in `body'. + See also [[trav]] + p.s. a more lisplike version of pg's trav " + `((rfn ,go (,n) + (when ,n ,@body)) + ,s)) + +(= hooks* (table)) + +(def hook (name . args) + (aif (hooks* name) (apply it args))) + +(mac defhook (name . rest) + `(symeval!sref symeval!hooks* (fn ,@rest) ',name)) + +(mac varif (name (o default)) + "Returns the value of the variable `name' if it exists, or `default' + otherwise." + `(if (symeval!bound ',name) ,name ,default)) + +(mac redef (name parms . body) + " Redefine a function. The old function definition may be used within + `body' as the name `old'. " + `(do (tostring + (let old (varif ,name nilfn) + (= ,name (fn ,parms ,@body)))) + ,name)) + +(redef table args + " Creates a table initializing table entries from passed + key-value pairs. + See also [[obj]] [[inst]] " + (let tb (old) + (fill-table tb args) + tb)) + +(mac help ( (o name 'help)) + " Prints the documentation for the given symbol. To use, type + (help symbol) ; you may also use (help \"string\") to search + all documentation for that string. + See also [[docstring]] " + (if + (isa name 'sym) + `(do (pr ,(helpstr name)) + nil) + (isa name 'string) + `(helpsearch (downcase ,name)) + t + `(do (pr ,(helpstr 'help)) nil) )) + +(def helpsearch (str) + " Prints all symbols whose documentation matches or partly matches `str'. " + (prall (helpsearch-core str) "Related symbols:\n" "\n") + (prn) + nil) + +(def helpsearch-core (str) + " Returns a list of symbols whose documentation matches or partly matches + `str'. " + (let part-match + (let rx (re (downcase str)) + [re-match rx (downcase (coerce _ 'string))]) + (sort < + (accum add + (ontable k (typ d) help* + (when (or (part-match k) (part-match typ) (part-match d) (only.part-match (source-file* k))) + (add k))))))) + +(def helpstr (name (o verbose t)) + " Returns a help string for the symbol `name'. " + (tostring + (let h (help* name) + (if (no h) + (if verbose (prn name " is not documented.")) + (with (kind (car h) + doc (cadr h)) + (aand verbose ((only [prn "(from \"" _ "\")"]) (source-file* name))) + (pr "[" kind "]" (if (is kind 'mac) " " " ")) + (prn (if (sig name) + (cons name (sig name)))) + (and verbose doc (prn doc))))))) + +(def fns (pfx (o test [prefix pfx _])) + "Print sigs for macros & functions starting with pfx, or that pass test if given." + (each f (sort < (keep test (map [string _] (keys sig)))) + (pr (helpstr (sym f) nil)))) + +;almkglor: err... what's this? +;(= env ($ getenv)) + +(defset env (x) + (w/uniq g + (list (list g x) + `(env ,g) + `(fn (val) (($ putenv) ,g val))))) + +(in-package User) +(using v3) +(using v3-thread) +(using v3-scanner) +(using v3-IDEAL) + +(mac % () nil) +(mac %% () nil) +(mac %%% () nil) + +; used internally +(def input-history-update (expr) + (= %%% %% + %% %) + (tostring (mac % () expr))) + +(= ^ nil + ^^ nil + ^^^ nil) + +(def output-history-update (val) + (= ^^^ ^^ + ^^ ^ + ^ val)) + +(set current-load-file* nil) + + +; 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? + +; solution to the "problem" of improper lists: allow any atom as a list +; terminator, not just nil. means list recursion should terminate on +; atom rather than nil, (def empty (x) (or (atom x) (is x ""))) +; table should be able to take an optional initial-value. handle in sref. +; warn about code of form (if (= )) -- probably mean is +; warn when a fn has a parm that's already defined as a macro. +; (def foo (after) (after)) +; idea: a fn (nothing) that returns a special gensym which is ignored +; by map, so can use map in cases when don't want all the vals +; idea: anaph macro so instead of (aand x y) say (anaph and x y) +; idea: foo.bar!baz as an abbrev for (foo bar 'baz) +; or something a bit more semantic? +; could uniq be (def uniq () (annotate 'symbol (list 'u))) again? +; idea: use x- for (car x) and -x for (cdr x) (but what about math -?) +; idea: get rid of strings and just use symbols +; could a string be (#\a #\b . "") ? +; better err msg when , outside of a bq +; idea: parameter (p foo) means in body foo is (pair arg) +; idea: make ('string x) equiv to (coerce x 'string) ? or isa? +; quoted atoms in car valuable unused semantic space +; idea: if (defun foo (x y) ...), make (foo 1) return (fn (y) (foo 1 y)) +; probably would lead to lots of errors when call with missing args +; but would be really dense with . notation, (foo.1 2) +; or use special ssyntax for currying: (foo@1 2) +; remember, can also double; could use foo::bar to mean something +; wild idea: inline defs for repetitive code +; same args as fn you're in +; variant of compose where first fn only applied to first arg? +; (> (len x) y) means (>+len x y) +; use ssyntax underscore for a var? +; foo_bar means [foo _ bar] +; what does foo:_:bar mean? +; matchcase +; crazy that finding the top 100 nos takes so long: +; (let bb (n-of 1000 (rand 50)) (time10 (bestn 100 > bb))) +; time: 2237 msec. -> now down to 850 msec + diff --git a/arc-f/as.scm b/arc-f/as.scm new file mode 100644 index 000000000..5067e1d9b --- /dev/null +++ b/arc-f/as.scm @@ -0,0 +1,62 @@ +; mzscheme -m -f as.scm +; (tl) +; (asv) +; http://localhost:8080 + +;(require (lib "errortrace.ss" "errortrace")) +(require mzscheme) ; promise we won't redefine mzscheme bindings + +;(profiling-enabled #t) +;(profiling-record-enabled #f) + +;find the arc directory +;NOTE! Might not be very portable. +;In particular, it depends on the launching +;script to properly define this environment variable + +(define arc-path (getenv "arc_dir")) + +(define (from-arc s) + (if arc-path + (path->string (build-path arc-path s)) + s)) + +;require needs a string, and will reject expressions T.T +(define temp-cwd (current-directory)) +(current-directory arc-path) + +(require "ac.scm") +(require "brackets.scm") +(use-bracket-readtable) +(require "bitops.scm") +(load "ffi.scm") + +(current-directory temp-cwd) + +(define arc.arc.scm (from-arc "arc.arc.scm")) +(define arc.arc (from-arc "arc.arc")) +(if (and (file-exists? arc.arc.scm) (< (file-or-directory-modify-seconds arc.arc) + (file-or-directory-modify-seconds arc.arc.scm))) + (load arc.arc.scm) + (begin + (display "Compiling arc.arc...\n") + (flush-output (current-output-port)) + (acompile arc.arc))) + +(define ~/.arcshrc + (path->string (build-path (find-system-path 'home-dir) ".arcshrc"))) +(when (file-exists? ~/.arcshrc) + (aload ~/.arcshrc)) + +; If we have command-line arguments. +(if (> (vector-length argv) 0) + ; If we have a command line argument that represents a file-name of + ; a program. + (begin + (call-with-input-file + (vector-ref argv 0) + aload1) + (exit)) + ; else + (tl)) + diff --git a/arc-f/bitops.scm b/arc-f/bitops.scm new file mode 100644 index 000000000..f25201af4 --- /dev/null +++ b/arc-f/bitops.scm @@ -0,0 +1,19 @@ +; Operations on bits. + +;use: (require "bitops.scm") + +(module bitops mzscheme + +; so we can use xdef +(require "ac.scm") + + +(provide (all-defined)) + +(xdef 'bit-and bitwise-and) +(xdef 'bit-or bitwise-ior) +(xdef 'bit-not bitwise-not) +(xdef 'bit-xor bitwise-xor) +(xdef 'bit-shift arithmetic-shift) + +) diff --git a/arc-f/brackets.scm b/arc-f/brackets.scm new file mode 100644 index 000000000..ba3e1ba82 --- /dev/null +++ b/arc-f/brackets.scm @@ -0,0 +1,47 @@ +; From Eli Barzilay, eli@barzilay.org + +;> (require "brackets.scm") +;> (use-bracket-readtable) +;> ([+ _ 1] 10) +;11 + +(module brackets mzscheme + +; main reader function for []s +; recursive read starts with default readtable's [ parser, +; but nested reads still use the curent readtable: + +(define (read-square-brackets ch port src line col pos) + `(make-br-fn ,(read/recursive port #\[ #f))) + +; a readtable that is just like the builtin except for []s + +(define bracket-readtable + (make-readtable #f #\[ 'terminating-macro read-square-brackets)) + +; call this to set the global readtable + +(provide use-bracket-readtable) + +(define (use-bracket-readtable) + (current-readtable bracket-readtable)) + +; these two implement the required functionality for #reader + +;(define (*read inp) +; (parameterize ((current-readtable bracket-readtable)) +; (read inp))) + +(define (*read . args) + (parameterize ((current-readtable bracket-readtable)) + (read (if (null? args) (current-input-port) (car args))))) + +(define (*read-syntax src port) + (parameterize ((current-readtable bracket-readtable)) + (read-syntax src port))) + +; and the need to be provided as `read' and `read-syntax' + +(provide (rename *read read) (rename *read-syntax read-syntax)) + +) diff --git a/arc-f/ffi.scm b/arc-f/ffi.scm new file mode 100644 index 000000000..d28c8c39b --- /dev/null +++ b/arc-f/ffi.scm @@ -0,0 +1,43 @@ +(require (lib "foreign.ss")) +(unsafe!) + +(xdef 'ffi-lib ffi-lib) +(xdef 'get-ffi-obj get-ffi-obj) + +(xdef 'cbyte _byte) +(xdef 'cshort _short) +(xdef 'cushort _ushort) +(xdef 'cint _int) +(xdef 'cuint _uint) +(xdef 'clong _long) +(xdef 'culong _ulong) + +(xdef 'cfloat _float) +(xdef 'cdouble _double) + +(xdef 'cbytes _bytes) +(xdef 'cvec _cvector) +(xdef 'cstring _string) + +(xdef 'cvoid _void) +(xdef 'cfn _cprocedure) +(xdef 'csizeof ctype-sizeof) + +(xdef 'cptr _pointer) +(xdef 'cpref ptr-ref) +(xdef 'cpset ptr-set!) +(xdef 'cmalloc malloc) +(xdef 'cfree free) +(xdef 'cfinalize register-finalizer) +(xdef 'gc collect-garbage) + +;; needed to convert from arc's lists (nil terminated) and proper scheme lists +(define (to-prop l) + (if (eq? l 'nil) '() (cons (car l) (to-prop (cdr l))))) +(define (l->cvec l type) (list->cvector (to-prop l) type)) +(xdef 'l->cvec l->cvec) +(xdef 'acptr cpointer?) + +(require #%foreign) +(xdef 'ffi-callback ffi-callback) +(xdef 'cfptr _fpointer) diff --git a/arc-f/lib/lazy-scanner.arc b/arc-f/lib/lazy-scanner.arc new file mode 100644 index 000000000..ca424183c --- /dev/null +++ b/arc-f/lib/lazy-scanner.arc @@ -0,0 +1,107 @@ + +(in-package lazy-scanner) +(using v3) +(using v3-scanner) +(interface v1 + lazy-scanner lazy-destruct + generate) + +(def delay (v) + (fn () v)) + +(defm car ((t x lazy-scanner-type)) + ((car (rep x)))) +(defm cdr ((t x lazy-scanner-type)) + ((cdr (rep x)))) + +(defm scanner ((t x lazy-scanner-type)) + x) +(defm unscan ((t orig lazy-scanner-type) x) + x) + +(mac lazy-scanner (a d) + " Creates a scanner which evaluates the + given expressions only when 'car and + 'cdr are used on it. + See also [[lazy-destruct]] [[generate]] " + `(symeval!lazy-scanner-f (fn () ,a) (fn () ,d))) + +(def lazy-scanner-f (af df) + ; warning! Not *completely* lazy: it is + ; possible, in a multithread environment, + ; for two different threads to execute + ; a lazy expression simultaneously + ; we can use semaphore locks of some + ; sort, but it *might* get bashed by + ; collect-on ; (depending on + ; whether we use ; dynamic-wind, + ; potentially, but I'll ; have to figure + ; out the continuation ; guards first) + (let rv (cons nil nil) + (= (car rv) + (fn () + (let it (af) + (= (car rv) (delay it)) + it))) + (= (cdr rv) + (fn () + (let it (df) + (= (cdr rv) (delay it)) + it))) + (annotate 'lazy-scanner-type + rv))) + +(mac lazy-destruct (c) + " Creates a scanner from a single expression + that returns a cons cell or other scanner. + The expression is evaluated only when + 'car or 'cdr is applied to this scanner. + See also [[lazy-scanner]] [[generate]] " + `(symeval!lazy-destruct-f (fn () ,c))) + +(def lazy-destruct-f (cf) + (withs (rv (cons nil nil) + destruct + (fn () + (withs (v (cf) + a (car v) + d (cdr v)) + (= (car rv) (delay a)) + (= (cdr rv) (delay d))))) + (= (car rv) + (fn () + (destruct) + ((car rv)))) + (= (cdr rv) + (fn () + (destruct) + ((cdr rv)))) + (annotate 'lazy-scanner-type + rv))) + +; ensure constructing a new lazy-scanner from +; another is truly lazy +; this gets to affect pretty much every sequence-building +; thing in arc.arc +(defm collect-on ((t seq lazy-scanner-type) bf) + (point return + (bf + (fn (i) + (point body-return + (return + (lazy-scanner + i + (point new-return + (= return new-return) + (body-return i))))))) + ; return might have been reassigned + (return nil))) + +(def generate (f i) + " Creates an infinite lazy sequence from the + continued application of `f' on `i'. + See also [[lazy-scanner]] [[lazy-destruct]] " + (lazy-scanner + i + (generate f (f i)))) + diff --git a/arc-f/lib/vector.arc b/arc-f/lib/vector.arc new file mode 100644 index 000000000..0d172582c --- /dev/null +++ b/arc-f/lib/vector.arc @@ -0,0 +1,69 @@ + +; NOTE: Not necessarily needed for other implementations, i.e. +; other implementations may validly use built-in types. We +; can't safely use vectors on the mzscheme implementations, +; because we do a lot of trickery on the mzscheme side and use +; scheme vectors for that trickery. +; Potentially this can implemented on the mzscheme side using +; the same trickery of course. +; A second rationale for this is that it's also a demonstration +; of the usage of the "scanner" concept in building the language. + +(in-package vector) +(using v3) +(using v3-scanner) +(interface v1 + vector) + +(= len-tag (uniq)) + +(defcall vector (v i) + v.i) +(defm sref ((t v vector) val i) + (let v (rep v) + (if (> i v.len-tag) + (= v.len-tag (+ i 1))) + (= v.i val) + val)) + +(def vector rest + " Creates a vector. A vector is a sequence with O(1) index lookup. " + (unscan-vector rest)) + +(defm scanner ((t v vector)) + (w/collect:for i 0 (- v.len-tag 1) + (collect v.i))) +(defm unscan ((t v vector) s) + (unscan-vector s)) + +(def unscan-vector (s) + (collect-on + (fn (collect) + (each i s + (collect i))))) + +; optimization +(defm each ((t v vector) skip bf) + (withs (v (rep v) + l v.len-tag) + ((afn (i) + (if (and (< i l) (bf:v i)) + (self (+ i 1)))) + skip))) +(defm collect-on ((t v vector) bf) + (collect-on bf)) + +(def collect-on (bf) + (with (l 0 + rv (table)) + (bf (fn (i) + (= rv.l i) + ++.l + i)) + (= rv.len-tag l) + (annotate 'vector rv))) + +(defm len ((t v vector)) + ((rep v) len-tag)) + +