Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

progress on java interface

  • Loading branch information...
commit 656ab5ea8586685b266eb5c3a58720998a3e8aea 1 parent af158ca
conan authored
Showing with 382 additions and 8,099 deletions.
  1. +39 −1 README
  2. +33 −37 build.xml
  3. BIN  lib/junit.jar
  4. +0 −1,142 src/java/arc/ac.scm
  5. +0 −22 src/java/arc/anarki-compatibility-test.arc
  6. +0 −534 src/java/arc/app.arc
  7. +0 −1,542 src/java/arc/arc.arc
  8. +0 −1  src/java/arc/arc/logs/news-
  9. +0 −1  src/java/arc/arc/logs/srv-
  10. +0 −16 src/java/arc/as.scm
  11. +0 −107 src/java/arc/blog.arc
  12. +0 −48 src/java/arc/brackets.scm
  13. +0 −62 src/java/arc/code.arc
  14. +0 −2  src/java/arc/copyright
  15. +0 −1,390 src/java/arc/foundation-test.arc
  16. BIN  src/java/arc/grayarrow.gif
  17. BIN  src/java/arc/graydown.gif
  18. +0 −369 src/java/arc/html.arc
  19. +0 −48 src/java/arc/java-interface-test.arc
  20. +0 −8 src/java/arc/libs.arc
  21. +0 −1,769 src/java/arc/news.arc
  22. +0 −80 src/java/arc/pprint.arc
  23. +0 −16 src/java/arc/prime-bench.arc
  24. +0 −119 src/java/arc/prompt.arc
  25. 0  src/java/arc/robots.txt
  26. BIN  src/java/arc/s.gif
  27. +0 −462 src/java/arc/srv.arc
  28. +0 −169 src/java/arc/strings.arc
  29. +0 −20 src/java/arc/unit.arc
  30. BIN  src/java/arc/y18.gif
  31. +1 −1  src/java/rainbow/Function.java
  32. +2 −2 src/java/rainbow/Nil.java
  33. +4 −4 src/java/rainbow/Truth.java
  34. +20 −20 src/java/rainbow/functions/IO.java
  35. +3 −3 src/java/rainbow/functions/InterpretedFunction.java
  36. +26 −8 src/java/rainbow/functions/Java.java
  37. +7 −7 src/java/rainbow/functions/Macex.java
  38. +2 −2 src/java/rainbow/functions/Predicates.java
  39. +31 −11 src/java/rainbow/functions/SystemFunctions.java
  40. +2 −2 src/java/rainbow/functions/Tables.java
  41. +2 −2 src/java/rainbow/types/ArcString.java
  42. +4 −4 src/java/rainbow/types/Hash.java
  43. +141 −42 src/java/rainbow/types/JavaObject.java
  44. +11 −8 src/java/rainbow/types/JavaProxy.java
  45. +2 −2 src/java/rainbow/types/Pair.java
  46. +0 −1  src/java/rainbow/vm/BoundSymbol.java
  47. +13 −4 src/java/rainbow/vm/continuations/FunctionDispatcher.java
  48. +4 −0 src/java/rainbow/vm/continuations/FunctionEvaluator.java
  49. +5 −5 src/java/rainbow/vm/continuations/NamespaceBuilder.java
  50. +2 −2 src/java/rainbow/vm/continuations/PairExpander.java
  51. +2 −2 src/java/rainbow/vm/continuations/QuasiQuoteContinuation.java
  52. +2 −2 src/java/rainbow/vm/continuations/Rebuilder.java
  53. +24 −0 src/sh/install.sh
View
40 README
@@ -1,5 +1,43 @@
+
+
+BUILD:
+
to build rainbow and open an interactive arc console, run
- ./rainbow.sh
+ ant clean jar
+
+
+
+INSTALL:
+
+to install rainbow from a build, run
+
+ ant -Darc_home=/path/to/your/copy/of/arc/or/anarki install
+
+this will copy rainbow.jar to your arc directory, and some arc files to lib/rainbow in your arc directory.
+
+
+
+RUN:
+
+cd to the directory containing arc and rainbow.jar.
+
+run this:
+
+java -jar rainbow.jar [options]
+
+command-line options:
+ --strict-arc # don't include anarki-compatible extensions
+ -f file1 ... fileN # evaluate each file
+ -e '(arc axpr)' # evaluate arc expr (after having evaluated -f, if specified)
+ -args a b c # sets "*argv*" in the arc environment to (a b c). This option, if present, must be specified last.
+
+
+
+INSTALLING FROM A BINARY DISTRIBUTION:
+
+the binary distribution is built at build/dist/rainbow-bin.zip
+unzip this file anywhere, then cd to the contained rainbow directory, and run:
+./install.sh /path/to/your/copy/of/arc/or/anarki
View
70 build.xml
@@ -3,28 +3,31 @@
<property name="src" value="src/java"/>
<property name="compiler-src" value="src/cc"/>
+ <property name="arc-src" value="src/arc"/>
+ <property name="sh-src" value="src/sh"/>
<property name="test-src" value="src/test"/>
<property name="lib" value="lib"/>
- <property name="junit" value="${lib}/junit.jar"/>
<property name="javacc" value="${lib}/javacc.jar"/>
<property name="build" value="build/"/>
- <property name="dist" value="${build}/dist"/>
+ <property name="dist" value="${build}/dist/rainbow"/>
<property name="classes" value="${build}/classes"/>
<property name="test-classes" value="${build}/test-classes"/>
<property name="jarfile" value="${dist}/rainbow.jar"/>
- <property name="src-jarfile" value="${dist}/rainbow-src.zip"/>
+ <property name="src-jarfile" value="${build}/rainbow-src.zip"/>
+ <property name="bin-zipfile" value="${build}/rainbow-bin.zip"/>
<target name="clean">
<delete dir="${build}"/>
</target>
<target name="compile-parser">
+ <mkdir dir="${src}/rainbow/parser"/>
<javacc target="${compiler-src}/ArcParser.jj" javacchome="${lib}" outputdirectory="${src}/rainbow/parser"/>
</target>
- <target name="compile-sources" depends="compile-parser">
+ <target name="compile" depends="compile-parser">
<mkdir dir="${classes}"/>
<javac srcdir="${src}" destdir="${classes}" debug="on" source="1.5" target="1.5" failonerror="true"/>
<copy todir="${classes}">
@@ -35,43 +38,10 @@
</copy>
</target>
- <target name="compile-tests">
- <mkdir dir="${test-classes}"/>
- <javac srcdir="${test-src}" destdir="${test-classes}" debug="on" source="1.5" target="1.5">
- <classpath>
- <pathelement path="${classes}"/>
- <pathelement path="${junit}"/>
- </classpath>
- </javac>
- <copy todir="${test-classes}">
- <fileset dir="${test-src}">
- <include name="**/*"/>
- <exclude name="**/*.java"/>
- </fileset>
- </copy>
- </target>
-
- <target name="compile" depends="compile-sources, compile-tests"/>
-
<target name="run" depends="compile">
<java classname="rainbow.Console" classpath="${classes}"/>
</target>
- <target name="test" depends="compile">
- <java classname="junit.textui.TestRunner">
- <arg line="rainbow.functions.AllTests"/>
- <classpath>
- <pathelement path="${classes}"/>
- <pathelement path="${test-classes}"/>
- <pathelement path="${junit}"/>
- </classpath>
- </java>
- </target>
-
- <target name="bsv" depends="compile">
- <java classname="rainbow.Console" classpath="${classes}" args="'(bsv)'"/>
- </target>
-
<target name="jar" depends="compile">
<mkdir dir="${dist}"/>
<jar file="${jarfile}" basedir="${classes}" manifest="src/MANIFEST.MF">
@@ -89,5 +59,31 @@
<include name="rainbow/build.xml"/>
</fileset>
</zip>
+
+ <copy todir="${dist}">
+ <fileset dir="src">
+ <include name="arc/**"/>
+ </fileset>
+ </copy>
+ <copy todir="${dist}">
+ <fileset dir="${sh-src}">
+ <include name="*"/>
+ </fileset>
+ </copy>
+
+ <zip file="${bin-zipfile}">
+ <fileset dir="${build}/dist">
+ <include name="rainbow/**"/>
+ </fileset>
+ </zip>
+ </target>
+
+ <target name="install" depends="jar">
+ <copy todir="${arc_home}/lib/rainbow">
+ <fileset dir="${arc-src}">
+ <include name="**"/>
+ </fileset>
+ </copy>
+ <copy todir="${arc_home}" file="${jarfile}"/>
</target>
</project>
View
BIN  lib/junit.jar
Binary file not shown
View
1,142 src/java/arc/ac.scm
@@ -1,1142 +0,0 @@
-; scheme48
-; ,open tables sockets extended-ports c-system-function ascii i/o-internal
-; ,open posix-files handle random pp simple-conditions
-
-; to do:
-; select, perhaps with threads, or pltt events
-; check argument count for complex arguments
-
-; refs.arc, first 300 lines of x, total CPU time including startup. on powerbook.
-; scheme48: 31.944u 0.518s 2:13.65 24.2% 0+0k 5+7io 0pf+0w
-; mzscheme: 16.425u 0.489s 0:52.61 32.1% 0+0k 26+22io 0pf+0w
-
-; dynamic creation of local variables with =
-; can you create globals inside a procedure?
-; does action of = depend on whether, at run time,
-; the variable has a global definition?
-; what's the scope of such a variable?
-; though a.lisp seems to create a global, not a local!
-; run-time expansion of macros
-; how do I know if something is a macro at compile time?
-; macros have lexical scope. so how do i know if a lexical
-; variable is going to be bound to a procedure? or to a macro?
-; what is annotate doing to symbols?
-; tests.arc implies that '(a b) produces a mutable list
-; so (fn () '(a)) produces a list that can be modified,
-; and future calls will reflect the modifications
-; oy. clisp works this way too.
-; it's not that easy to simulate this.
-; what is this? (def foo1 (x (o y x)) (list x y))
-
-; it's not clear I translate NILs in the outputs of macros correctly.
-; I translate (NIL . NIL) to ('NIL . '())
-; I use Scheme apply to call macros.
-; Scheme apply demands a '()-terminated list.
-; most macros have a . body argument.
-; so body is '()-terminated, not NIL-terminated.
-; solution: ar-false? knows about '()
-; this doesn't work, since var isn't a variable name:
-; (mac or args
-; (and args
-; (let var (tag 'symbol (list 'or))
-; (list 'let var (car args)
-; (list 'if var var (cons 'or (cdr args)))))))
-
-(module ac mzscheme
-
-(provide (all-defined))
-(require (lib "port.ss"))
-(require (lib "process.ss"))
-(require (lib "pretty.ss"))
-
-; compile an Arc expression into a Scheme expression,
-; both represented as s-expressions.
-; env is a list of lexically bound variables, which we
-; need in order to decide whether set should create a global.
-
-(define (ac s env)
- (cond ((string? s) (string-copy s)) ; to avoid immutable strings
- ((literal? s) s)
- ((eqv? s 'nil) (list 'quote 'nil))
- ((ssyntax? s) (ac (expand-ssyntax s) env))
- ((symbol? s) (ac-var-ref s env))
- ((ssyntax? (xcar s)) (ac (cons (expand-ssyntax (car s)) (cdr s)) env))
- ((eq? (xcar s) 'quote) (list 'quote (ac-niltree (cadr s))))
- ((eq? (xcar s) 'quasiquote) (ac-qq (cadr s) env))
- ((eq? (xcar s) 'if) (ac-if (cdr s) env))
- ((eq? (xcar s) 'fn) (ac-fn (cadr s) (cddr s) env))
- ((eq? (xcar s) 'set) (ac-set (cdr s) env))
- ; this line could be removed without changing semantics
- ((eq? (xcar (xcar s)) 'compose) (ac (decompose (cdar s) (cdr s)) env))
- ((pair? s) (ac-call (car s) (cdr s) env))
- (#t (err "Bad object in expression" s))))
-
-(define (literal? x)
- (or (boolean? x)
- (char? x)
- (string? x)
- (number? x)
- (eq? x '())))
-
-(define (ssyntax? x)
- (and (symbol? x)
- (not (or (eqv? x '+) (eqv? x '++)))
- (let ((name (symbol->string x)))
- (has-ssyntax-char? name (- (string-length name) 1)))))
-
-(define (has-ssyntax-char? string i)
- (and (>= i 0)
- (or (let ((c (string-ref string i)))
- (or (eqv? c #\:) (eqv? c #\~) (eqv? c #\.) (eqv? c #\!)))
- (has-ssyntax-char? string (- i 1)))))
-
-(define (read-from-string str)
- (let ((port (open-input-string str)))
- (let ((val (read port)))
- (close-input-port port)
- val)))
-
-(define (expand-ssyntax sym)
- ((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)
- (string->symbol (string-append "_" (symbol->string s))))
-
-(define (ac-var-ref s env)
- (if (lex? s env)
- s
- (ac-global-name s)))
-
-; quasiquote
-
-(define (ac-qq args env)
- (list 'quasiquote (ac-qq1 1 args env)))
-
-; process the argument of a quasiquote. keep track of
-; depth of nesting. handle unquote only at top level (level = 1).
-; complete form, e.g. x or (fn x) or (unquote (fn x))
-(define (ac-qq1 level x env)
- (cond ((= level 0)
- (ac x env))
- ((and (pair? x) (eqv? (car x) 'unquote))
- (list 'unquote (ac-qq1 (- level 1) (cadr x) env)))
- ((and (pair? x) (eqv? (car x) 'unquote-splicing) (= level 1))
- (list 'unquote-splicing
- (list 'ar-nil-terminate (ac-qq1 (- level 1) (cadr x) env))))
- ((and (pair? x) (eqv? (car x) 'quasiquote))
- (list 'quasiquote (ac-qq1 (+ level 1) (cadr x) env)))
- ((pair? x)
- (map (lambda (x) (ac-qq1 level x env)) x))
- (#t x)))
-
-; (if) -> nil
-; (if x) -> x
-; (if t a ...) -> a
-; (if nil a b) -> b
-; (if nil a b c) -> (if b c)
-
-(define (ac-if args env)
- (cond ((null? args) ''nil)
- ((null? (cdr args)) (ac (car args) env))
- (#t `(if (not (ar-false? ,(ac (car args) env)))
-;(not (eq? 'nil ,(ac (car args) env)))
- ,(ac (cadr args) env)
- ,(ac-if (cddr args) env)))))
-
-; translate fn directly into a lambda if it has ordinary
-; parameters, otherwise use a rest parameter and parse it.
-(define (ac-fn args body env)
- (if (ac-complex-args? args)
- (ac-complex-fn args body env)
- `(lambda ,(let ((a (ac-denil args))) (if (eqv? a 'nil) '() a))
- 'nil
- ,@(ac-body body (append (ac-arglist args) env)))))
-
-; does an fn arg list use optional parameters or destructuring?
-; a rest parameter is not complex
-(define (ac-complex-args? args)
- (cond ((eqv? args '()) #f)
- ((symbol? args) #f)
- ((and (pair? args) (symbol? (car args)))
- (ac-complex-args? (cdr args)))
- (#t #t)))
-
-; translate a fn with optional or destructuring args
-; (fn (x (o y x) (o z 21) (x1 x2) . rest) ...)
-; arguments in top-level list are mandatory (unless optional),
-; but it's OK for parts of a list you're destructuring to
-; be missing.
-(define (ac-complex-fn args body env)
- (let* ((ra (ar-gensym))
- (z (ac-complex-args args env ra #t)))
- `(lambda ,ra
- (let* ,z
- 'nil
- ,@(ac-body body (append (ac-complex-getargs z) env))))))
-
-; returns a list of two-element lists, first is variable name,
-; second is (compiled) expression. to be used in a let.
-; caller should extract variables and add to env.
-; ra is the rest argument to the fn.
-; is-params indicates that args are function arguments
-; (not destructuring), so they must be passed or be optional.
-(define (ac-complex-args args env ra is-params)
- (cond ((or (eqv? args '()) (eqv? args 'nil)) '())
- ((symbol? args) (list (list args ra)))
- ((pair? args)
- (let* ((x (if (and (pair? (car args)) (eqv? (caar args) 'o))
- (ac-complex-opt (cadar args)
- (if (pair? (cddar args))
- (caddar args)
- 'nil)
- env
- ra)
- (ac-complex-args
- (car args)
- env
- (if is-params
- `(car ,ra)
- `(ar-xcar ,ra))
- #f)))
- (xa (ac-complex-getargs x)))
- (append x (ac-complex-args (cdr args)
- (append xa env)
- `(ar-xcdr ,ra)
- is-params))))
- (#t (err "Can't understand fn arg list" args))))
-
-; (car ra) is the argument
-; so it's not present if ra is nil or '()
-(define (ac-complex-opt var expr env ra)
- (list (list var `(if (pair? ,ra) (car ,ra) ,(ac expr env)))))
-
-; extract list of variables from list of two-element lists.
-(define (ac-complex-getargs a)
- (map (lambda (x) (car x)) a))
-
-; (a b . c) -> (a b c)
-; a -> (a)
-(define (ac-arglist a)
- (cond ((null? a) '())
- ((symbol? a) (list a))
- ((symbol? (cdr a)) (list (car a) (cdr a)))
- (#t (cons (car a) (ac-arglist (cdr a))))))
-
-(define (ac-body body env)
- (if (null? body)
- '()
- (cons (ac (car body) env) (ac-body (cdr body) env))))
-
-; (set v1 expr1 v2 expr2 ...)
-
-(define (ac-set x env)
- `(begin ,@(ac-setn x env)))
-
-(define (ac-setn x env)
- (if (null? x)
- '()
- (cons (ac-set1 (ac-macex (car x)) (ac (cadr x) env) env)
- (ac-setn (cddr x) env))))
-
-; = replaced by set, which is only for vars
-; = now defined in arc (is it?)
-; name is to cause fns to have their arc names for debugging
-
-(define (ac-set1 a b env)
- (if (symbol? a)
- (let ((name (string->symbol (string-append " " (symbol->string a)))))
- (list 'let `((,name ,b))
- (cond ((eqv? a 'nil) (err "Can't rebind nil"))
- ((eqv? a 't) (err "Can't rebind t"))
- ((lex? a env) `(set! ,a ,name))
- (#t `(namespace-set-variable-value! ',(ac-global-name a)
- ,name)))
- name))
- (err "First arg to set must be a symbol" a)))
-
-; compile a function call
-; special cases for speed, to avoid compiled output like
-; (ar-apply _pr (list 1 2))
-; which results in 1/2 the CPU time going to GC. Instead:
-; (ar-funcall2 _pr 1 2)
-(define (ac-call fn args env)
- (let ((macfn (ac-macro? fn)))
- (cond (macfn
- (ac-mac-call macfn args env))
- ((and (pair? fn) (eqv? (car fn) 'fn))
- `(,(ac fn env) ,@(map (lambda (x) (ac x env)) args)))
- ((= (length args) 0)
- `(ar-funcall0 ,(ac fn env) ,@(map (lambda (x) (ac x env)) args)))
- ((= (length args) 1)
- `(ar-funcall1 ,(ac fn env) ,@(map (lambda (x) (ac x env)) args)))
- ((= (length args) 2)
- `(ar-funcall2 ,(ac fn env) ,@(map (lambda (x) (ac x env)) args)))
- ((= (length args) 3)
- `(ar-funcall3 ,(ac fn env) ,@(map (lambda (x) (ac x env)) args)))
- ((= (length args) 4)
- `(ar-funcall4 ,(ac fn env) ,@(map (lambda (x) (ac x env)) args)))
- (#t
- `(ar-apply ,(ac fn env)
- (list ,@(map (lambda (x) (ac x env)) args)))))))
-
-(define (ac-mac-call m args env)
- (let ((x1 (apply m (map ac-niltree args))))
- (let ((x2 (ac (ac-denil x1) env)))
- x2)))
-
-; returns #f or the macro function
-
-(define (ac-macro? fn)
- (if (symbol? fn)
- (let ((v (namespace-variable-value (ac-global-name fn)
- #t
- (lambda () #f))))
- (if (and v
- (ar-tagged? v)
- (eq? (ar-type v) 'mac))
- (ar-rep v)
- #f))
- #f))
-
-; macroexpand the outer call of a form as much as possible
-
-(define (ac-macex e . once)
- (if (pair? e)
- (let ((m (ac-macro? (car e))))
- (if m
- (let ((expansion (ac-denil (apply m (map ac-niltree (cdr e))))))
- (if (null? once) (ac-macex expansion) expansion))
- e))
- e))
-
-; macros return Arc lists, ending with NIL.
-; but the Arc compiler expects Scheme lists, ending with '().
-; what to do with (is x nil . nil) ?
-; the first nil ought to be replaced with 'NIL
-; the second with '()
-; so the rule is: NIL in the car -> 'NIL, NIL in the cdr -> '().
-; NIL by itself -> NIL
-
-(define (ac-denil x)
- (cond ((pair? x) (cons (ac-denil-car (car x)) (ac-denil-cdr (cdr x))))
- (#t x)))
-
-(define (ac-denil-car x)
- (if (eq? x 'nil)
- 'nil
- (ac-denil x)))
-
-(define (ac-denil-cdr x)
- (if (eq? x 'nil)
- '()
- (ac-denil x)))
-
-; is v lexically bound?
-(define (lex? v env)
- (memq v env))
-
-(define (xcar x)
- (and (pair? x) (car x)))
-
-; #f and '() -> nil for a whole quoted list/tree.
-
-(define (ac-niltree x)
- (cond ((pair? x) (cons (ac-niltree (car x)) (ac-niltree (cdr x))))
- ((or (eq? x #f) (eq? x '())) 'nil)
- (#t x)))
-
-;(define (err msg . args)
-; (display msg)
-; (map (lambda (a) (display " ") (write a)) args)
-; (newline)
-; (xxundefined))
-
-(define err error) ; eli says need to remove xxundefined for speed
-
-; run-time primitive procedures
-
-(define (xdef a b)
- (namespace-set-variable-value! (ac-global-name a) b)
- b)
-
-(define fn-signatures (make-hash-table 'equal))
-
-; This is a replacement for xdef that stores opeator signatures.
-; Haven't started using it yet.
-
-(define (odef a parms b)
- (namespace-set-variable-value! (ac-global-name a) b)
- (hash-table-put! fn-signatures a (list parms))
- b)
-
-(xdef 'sig fn-signatures)
-
-; versions of car and cdr for parsing arguments for optional
-; parameters, that yield nil for nil. maybe we should use
-; full Arc car and cdr, so we can destructure more things
-
-(define (ar-xcar x)
- (if (or (eqv? x 'nil) (eqv? x '()))
- 'nil
- (car x)))
-
-(define (ar-xcdr x)
- (if (or (eqv? x 'nil) (eqv? x '()))
- 'nil
- (cdr x)))
-
-; convert #f from a Scheme predicate to NIL.
-
-(define (ar-nill x)
- (if (or (eq? x '()) (eq? x #f))
- 'nil
- x))
-
-; definition of falseness for Arc if.
-; must include '() since sometimes Arc functions see
-; Scheme lists (e.g. . body of a macro).
-
-(define (ar-false? x)
- (or (eq? x 'nil) (eq? x '()) (eq? x #f)))
-
-#|
- (if (eq? x 'nil) #t
- (if (eq? x '()) #t
- (not x)))
-|#
-
-; call a function or perform an array ref, hash ref, &c
-
-; Non-fn donstants in functional position are valuable real estate, so
-; should figure out the best way to exploit it.
-
-(define (ar-apply fn args)
- (cond ((procedure? fn) (apply fn args))
- ((pair? fn) (list-ref fn (car args)))
- ((string? fn) (string-ref fn (car args)))
- ((hash-table? fn) (ar-nill (hash-table-get fn (car args) #f)))
-; experiment: means e.g. [1] is a constant fn
-; ((or (number? fn) (symbol? fn)) fn)
-; another possibility: constant in functional pos means it gets
-; passed to the first arg, i.e. ('kids item) means (item 'kids).
- (#t (err "Function call on inappropriate object" fn args))))
-
-(xdef 'apply (lambda (fn . args)
- (ar-apply fn (ar-apply-args args))))
-
-; special cases of ar-apply for speed and to avoid consing arg lists
-(define (ar-funcall0 fn)
- (if (procedure? fn)
- (fn)
- (ar-apply fn (list))))
-
-(define (ar-funcall1 fn arg1)
- (if (procedure? fn)
- (fn arg1)
- (ar-apply fn (list arg1))))
-
-(define (ar-funcall2 fn arg1 arg2)
- (if (procedure? fn)
- (fn arg1 arg2)
- (ar-apply fn (list arg1 arg2))))
-
-(define (ar-funcall3 fn arg1 arg2 arg3)
- (if (procedure? fn)
- (fn arg1 arg2 arg3)
- (ar-apply fn (list arg1 arg2 arg3))))
-
-(define (ar-funcall4 fn arg1 arg2 arg3 arg4)
- (if (procedure? fn)
- (fn arg1 arg2 arg3 arg4)
- (ar-apply fn (list arg1 arg2 arg3 arg4))))
-
-; replace the nil at the end of a list with a '()
-
-(define (ar-nil-terminate l)
- (if (or (eqv? l '()) (eqv? l 'nil))
- '()
- (cons (car l) (ar-nil-terminate (cdr l)))))
-
-; turn the arguments to Arc apply into a list.
-; if you call (apply fn 1 2 '(3 4))
-; then args is '(1 2 (3 4 . nil) . ())
-; that is, the main list is a scheme list.
-; and we should return '(1 2 3 4 . ())
-; was once (apply apply list (ac-denil args))
-; but that didn't work for (apply fn nil)
-
-(define (ar-apply-args args)
- (cond ((null? args) '())
- ((null? (cdr args)) (ar-nil-terminate (car args)))
- (#t (cons (car args) (ar-apply-args (cdr args))))))
-
-(xdef 'cons cons)
-
-(xdef 'car (lambda (x)
- (cond ((pair? x) (car x))
- ((eqv? x 'nil) 'nil)
- ((eqv? x '()) 'nil)
- (#t (err "Can't take car of" x)))))
-
-(xdef 'cdr (lambda (x)
- (cond ((pair? x) (cdr x))
- ((eqv? x 'nil) 'nil)
- ((eqv? x '()) 'nil)
- (#t (err "Can't take cdr of" x)))))
-
-; reduce?
-
-(define (pairwise pred args base)
- (let ((n (length args)))
- (cond ((< n 2) base)
- ((= n 2) (apply pred args))
- (#t (and (pred (car args) (cadr args))
- (pairwise pred (cdr args) base))))))
-
-(define (tnil x) (if x 't 'nil))
-
-; not quite right, because behavior of underlying eqv unspecified
-; in many cases according to r5rs
-; do we really want is to ret t for distinct strings?
-
-(xdef 'is (lambda args
- (tnil (or (all (lambda (a) (eqv? (car args) a)) (cdr args))
- (and (all string? args)
- (apply string=? args))
- (all ar-false? args)))))
-
-(xdef 'err err)
-(xdef 'nil 'nil)
-(xdef 't 't)
-
-(define (all test seq)
- (or (null? seq)
- (and (test (car seq)) (all test (cdr seq)))))
-
-(define (arc-list? x) (or (pair? x) (eqv? x 'nil) (eqv? x '())))
-
-; generic +: strings, lists, numbers.
-; problem with generic +: what to return when no args?
-; could even coerce based on type of first arg...
-
-(xdef '+ (lambda args
- (cond ((null? args) 0)
- ((all string? args)
- (apply string-append args))
- ((all arc-list? args)
- (ac-niltree (apply append (map ar-nil-terminate args))))
- (#t (apply + args)))))
-
-(xdef '- -)
-(xdef '* *)
-(xdef '/ /)
-(xdef 'mod modulo)
-(xdef 'expt expt)
-(xdef 'sqrt sqrt)
-
-; generic comparison
-
-(define (arc> . args)
- (cond ((all number? args) (apply > args))
- ((all string? args) (pairwise string>? args #f))
- ((all symbol? args) (pairwise (lambda (x y)
- (string>? (symbol->string x)
- (symbol->string y)))
- args
- #f))
- ((all char? args) (pairwise char>? args #f))
- (#t (apply > args))))
-
-(xdef '> (lambda args (tnil (apply arc> args))))
-
-(define (arc< . args)
- (cond ((all number? args) (apply < args))
- ((all string? args) (pairwise string<? args #f))
- ((all symbol? args) (pairwise (lambda (x y)
- (string<? (symbol->string x)
- (symbol->string y)))
- args
- #f))
- ((all char? args) (pairwise char<? args #f))
- (#t (apply < args))))
-
-(xdef '< (lambda args (tnil (apply arc< args))))
-
-(xdef 'len (lambda (x)
- (cond ((string? x) (string-length x))
- ((hash-table? x) (hash-table-count x))
- (#t (length (ar-nil-terminate x))))))
-
-(define (ar-tagged? x)
- (and (vector? x) (eq? (vector-ref x 0) 'tagged)))
-
-(define (ar-tag type rep)
- (cond ((eqv? (ar-type rep) type) rep)
- (#t (vector 'tagged type rep))))
-
-(xdef 'annotate ar-tag)
-
-; (type nil) -> sym
-
-(define (ar-type x)
- (cond ((ar-tagged? x) (vector-ref x 1))
- ((pair? x) 'cons)
- ((symbol? x) 'sym)
- ((null? x) 'sym)
- ((procedure? x) 'fn)
- ((char? x) 'char)
- ((string? x) 'string)
- ((integer? x) 'int)
- ((number? x) 'num) ; unsure about this
- ((hash-table? x) 'table)
- ((output-port? x) 'output)
- ((input-port? x) 'input)
- ((tcp-listener? x) 'socket)
- ((exn? x) 'exception)
- ((thread? x) 'thread)
- (#t (err "Type: unknown type" x))))
-(xdef 'type ar-type)
-
-(define (ar-rep x)
- (if (ar-tagged? x)
- (vector-ref x 2)
- x))
-
-(xdef 'rep ar-rep)
-
-; currently rather a joke: returns interned symbols
-
-(define ar-gensym-count 0)
-
-(define (ar-gensym)
- (set! ar-gensym-count (+ ar-gensym-count 1))
- (string->symbol (string-append "gs" (number->string ar-gensym-count))))
-
-(xdef 'uniq ar-gensym)
-
-(xdef 'ccc call-with-current-continuation)
-
-(xdef 'infile open-input-file)
-
-(xdef 'outfile (lambda (f . args)
- (open-output-file f
- 'text
- (if (equal? args '(append))
- 'append
- 'truncate))))
-
-(xdef 'instring open-input-string)
-(xdef 'outstring open-output-string)
-
-; use as general fn for looking inside things
-
-(xdef 'inside get-output-string)
-
-(xdef '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)
- (f (ac-denil (car args)) port))
- (flush-output port))
- 'nil)
-
-(xdef 'write (lambda args (printwith write args)))
-(xdef 'disp (lambda args (printwith display args)))
-
-; sread = scheme read. eventually replace by writing read
-
-(xdef 'sread (lambda (p eof)
- (let ((expr (read p)))
- (if (eof-object? expr) eof expr))))
-
-; these work in PLT but not scheme48
-
-(define char->ascii char->integer)
-(define ascii->char integer->char)
-
-(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)))
-
-; need to use a better seed
-
-(xdef 'rand random)
-
-(xdef 'dir (lambda (name) (map path->string (directory-list name))))
-
-(xdef 'file-exists (lambda (name)
- (if (file-exists? name) name 'nil)))
-
-(xdef 'dir-exists (lambda (name)
- (if (directory-exists? name) name 'nil)))
-
-(xdef 'rmfile (wrapnil delete-file))
-
-; top level read-eval-print
-; tle kept as a way to get a break loop when a scheme err
-
-(define (arc-eval expr)
- (eval (ac expr '()) (interaction-environment)))
-
-(define (tle)
- (display "Arc> ")
- (let ((expr (read)))
- (when (not (eqv? expr ':a))
- (write (arc-eval expr))
- (newline)
- (tle))))
-
-(define last-condition* #f)
-
-(define (tl)
- (display "Use (quit) to quit, (tl) to return here after an interrupt.\n")
- (tl2))
-
-(define (tl2)
- (display "arc> ")
- (on-err (lambda (c)
- (set! last-condition* c)
- (display "Error: ")
- (write (exn-message c))
- (newline)
- (tl2))
- (lambda ()
- (let ((expr (read)))
- (if (eqv? expr ':a)
- 'done
- (let ((val (arc-eval expr)))
- (write (ac-denil val))
- (namespace-set-variable-value! '_that val)
- (namespace-set-variable-value! '_thatexpr expr)
- (newline)
- (tl2)))))))
-
-(define (aload1 p)
- (let ((x (read p)))
- (if (eof-object? x)
- #t
- (begin
- (arc-eval x)
- (aload1 p)))))
-
-(define (atests1 p)
- (let ((x (read p)))
- (if (eof-object? x)
- #t
- (begin
- (write x)
- (newline)
- (let ((v (arc-eval x)))
- (if (ar-false? v)
- (begin
- (display " FAILED")
- (newline))))
- (atests1 p)))))
-
-(define (aload filename)
- (call-with-input-file filename aload1))
-
-(define (test filename)
- (call-with-input-file filename atests1))
-
-(define (acompile1 ip op)
- (let ((x (read ip)))
- (if (eof-object? x)
- #t
- (let ((scm (ac x '())))
- (eval scm (interaction-environment))
- (pretty-print scm op)
- (newline op)
- (newline op)
- (acompile1 ip op)))))
-
-; compile xx.arc to xx.arc.scm
-; useful to examine the Arc compiler output
-(define (acompile inname)
- (let ((outname (string-append inname ".scm")))
- (if (file-exists? outname)
- (delete-file outname))
- (call-with-input-file inname
- (lambda (ip)
- (call-with-output-file outname
- (lambda (op)
- (acompile1 ip op)))))))
-
-(xdef 'macex (lambda (e) (ac-macex (ac-denil e))))
-
-(xdef 'macex1 (lambda (e) (ac-macex (ac-denil e) 'once)))
-
-(xdef 'eval (lambda (e)
- (eval (ac (ac-denil e) '()) (interaction-environment))))
-
-; If an err occurs in an on-err expr, no val is returned and code
-; after it doesn't get executed. Not quite what I had in mind.
-
-(define (on-err errfn f)
- ((call-with-current-continuation
- (lambda (k)
- (lambda ()
- (with-handlers ((exn:fail? (lambda (c)
- (k (lambda () (errfn c))))))
- (f)))))))
-(xdef 'on-err on-err)
-
-(define (disp-to-string x)
- (let ((o (open-output-string)))
- (display x o)
- (close-output-port o)
- (get-output-string o)))
-
-(xdef 'details (lambda (c)
- (disp-to-string (exn-message c))))
-
-(xdef 'scar (lambda (x val)
- (if (string? x)
- (string-set! x 0 val)
- (set-car! x val))
- val))
-
-(xdef 'scdr (lambda (x val)
- (if (string? x)
- (err "Can't set cdr of a string" x)
- (set-cdr! x val))
- val))
-
-; When and if cdr of a string returned an actual (eq) tail, could
-; say (if (string? x) (string-replace! x val 1) ...) in scdr, but
-; for now would be misleading to allow this, because fails for cddr.
-
-(define (string-replace! str val index)
- (if (eqv? (string-length val) (- (string-length str) index))
- (do ((i index (+ i 1)))
- ((= i (string-length str)) str)
- (string-set! str i (string-ref val (- i index))))
- (err "Length mismatch between strings" str val index)))
-
-(xdef 'sref (lambda (com val ind) ; later make ind rest arg
- (cond ((hash-table? com) (if (eqv? val 'nil)
- (hash-table-remove! com ind)
- (hash-table-put! com ind val)))
- ((string? com) (string-set! com ind val))
- ((pair? com) (nth-set! com ind val))
- (#t (err "Can't set reference " com ind val)))
- val))
-
-(define (nth-set! lst n val)
- (set-car! (list-tail lst n) val))
-
-; rewrite to pass a (true) gensym instead of #f in case var bound to #f
-
-(define (bound? arcname)
- (namespace-variable-value (ac-global-name arcname)
- #t
- (lambda () #f)))
-
-(xdef 'bound (lambda (x) (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.
-; XXX make sure cell is set #f after an exception?
-; maybe it doesn't matter since thread will die?
-
-(define ar-the-sema (make-semaphore 1))
-
-(define ar-sema-cell (make-thread-cell #f))
-
-(xdef 'atomic-invoke (lambda (f)
- (if (thread-cell-ref ar-sema-cell)
- (ar-apply f '())
- (begin
- (thread-cell-set! ar-sema-cell #t)
- (let ((ret
- (call-with-semaphore
- ar-the-sema
- (lambda () (ar-apply f '())))))
- (thread-cell-set! ar-sema-cell #f)
- ret)))))
-
-(xdef 'dead (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 (ssyntax? x))))
-
-(xdef 'ssexpand (lambda (x)
- (if (symbol? x) (expand-ssyntax x) x)))
-
-(xdef 'quit exit)
-
-
-)
-
-(require ac)
View
22 src/java/arc/anarki-compatibility-test.arc
@@ -1,22 +0,0 @@
-(sref call* (fn (the-bobo size) (* the-bobo size)) 'bobo)
-
-(set show-failed-only t)
-
-(set anarki-test-suite '(suite "Anarki Compatibility Tests"
- (suite "maths"
- ("Quotient"
- (quotient 15 2)
- 7)
- )
-
- (suite "defcall"
- ("defcall on custom type"
- ((fn (a-bobo)
- (a-bobo 3)
- ) (annotate 'bobo 23))
- 69)
- )
-))
-
-(prn (run-tests anarki-test-suite))
-
View
534 src/java/arc/app.arc
@@ -1,534 +0,0 @@
-; Application Server. Layer inserted 2 Sep 06.
-
-; todo: def a general notion of apps of which the programming app is
-; one and the news site another.
-; give each user a place to store data? A home dir?
-
-; A user is simply a string: "pg". Use /whoami to test user cookie.
-
-(= hpwfile* "arc/hpw"
- adminfile* "arc/admins"
- cookfile* "arc/cooks")
-
-(def asv ((o port 8080))
- (load-userinfo)
- (serve port))
-
-(def load-userinfo ()
- (= hpasswords* (safe-load-table hpwfile*)
- admins* (map string (errsafe (readfile adminfile*)))
- cookie->user* (safe-load-table cookfile*))
- (maptable (fn (k v) (= (user->cookie* v) k))
- cookie->user*))
-
-; idea: a bidirectional table, so don't need two vars (and sets)
-
-(= cookie->user* (table) user->cookie* (table) logins* (table))
-
-(def get-user (req)
- (let u (aand (alref (req 'cooks) "user") (cookie->user* (sym it)))
- (when u (= (logins* u) (req 'ip)))
- u))
-
-(mac when-umatch (user req . body)
- `(if (is ,user (get-user ,req))
- (do ,@body)
- (mismatch-message)))
-
-(def mismatch-message () (prn "Dead link: users don't match."))
-
-(mac when-umatch/r (user req . body)
- `(if (is ,user (get-user ,req))
- (do ,@body)
- "mismatch"))
-
-(defop mismatch req (mismatch-message))
-
-(mac uform (user req after . body)
- `(aform (fn (,req)
- (when-umatch ,user ,req
- ,after))
- ,@body))
-
-(mac urform (user req after . body)
- `(arform (fn (,req)
- (when-umatch/r ,user ,req
- ,after))
- ,@body))
-
-; Like onlink, but checks that user submitting the request is the
-; same it was generated for. Really should log the username and
-; ip addr of every genlink, and check if they match.
-
-(mac userlink (user text . body)
- (w/uniq req
- `(linkf ,text (,req)
- (when-umatch ,user ,req ,@body))))
-
-
-(defop admin req (admin-gate (get-user req)))
-
-(def admin-gate (u)
- (if (admin u)
- (admin-page u)
- (login-page 'login nil
- (fn (u ip) (admin-gate u)))))
-
-(def admin (u) (and u (mem u admins*)))
-
-(def user-exists (u) (and u (hpasswords* u) u))
-
-(def admin-page (user . msg)
- (whitepage
- (prbold "Admin: ")
- (hspace 20)
- (pr user " | ")
- (w/link (do (logout-user user)
- (whitepage (pr "Bye " user ".")))
- (pr "logout"))
- (when msg (hspace 10) (map pr msg))
- (br2)
- (aform (fn (req)
- (when-umatch user req
- (with (u (arg req "u") p (arg req "p"))
- (if (or (no u) (no p) (is u "") (is p ""))
- (pr "Bad data.")
- (user-exists u)
- (admin-page user "User already exists: " u)
- (do (create-acct u p)
- (admin-page user))))))
- (pwfields "create (server) account"))))
-
-; need to define a notion of a hashtable that's always written
-; to a file when modified
-
-(def cook-user (user)
- (let id (new-user-cookie)
- (= (cookie->user* id) user
- (user->cookie* user) id)
- (save-table cookie->user* cookfile*)
- id))
-
-; Unique-ids are only unique per server invocation.
-
-(def new-user-cookie ()
- (let id (unique-id)
- (if (cookie->user* id) (new-user-cookie) id)))
-
-(def logout-user (user)
- (wipe (logins* user))
- (wipe (cookie->user* (user->cookie* user)) (user->cookie* user))
- (save-table cookie->user* cookfile*))
-
-(def create-acct (user pw)
- (set-pw user pw))
-
-(def disable-acct (user)
- (set-pw user (rand-string 20))
- (logout-user user))
-
-(def set-pw (user pw)
- (= (hpasswords* user) (and pw (shash pw)))
- (save-table hpasswords* hpwfile*))
-
-(def hello-page (user ip)
- (whitepage (prs "hello" user "at" ip)))
-
-(defop login req (login-page 'login))
-
-; switch is one of: register, login, both
-; afterward is a function on the newly created user, ip addr
-; or can be a list of such a fn and a string, in which case call fn
-; then redirect to string
-
-; classic example of something that should just "return" a val
-; via a continuation rather than going to a new page.
-
-; ugly code-- too much duplication
-
-(def login-page (switch (o msg nil) (o afterward hello-page))
- (whitepage
- (pagemessage msg)
- (when (in switch 'login 'both)
- (prbold "Login")
- (br2)
- (if (acons afterward)
- (let (f url) afterward
- (arformh (fn (req)
- (logout-user (get-user req))
- (aif (good-login (arg req "u") (arg req "p") (req 'ip))
- (do (= (logins* it) (req 'ip))
- (prcookie (user->cookie* it))
- (f it (req 'ip))
- url)
- (flink (fn ignore (login-page switch
- "Bad login."
- afterward)))))
- (pwfields)))
- (aformh (fn (req)
- (logout-user (get-user req))
- (aif (good-login (arg req "u") (arg req "p") (req 'ip))
- (do (= (logins* it) (req 'ip))
- (prcookie (user->cookie* it))
- (prn)
- (afterward it (req 'ip)))
- (do (prn)
- (login-page switch "Bad login." afterward))))
- (pwfields)))
- (br2))
- (when (in switch 'register 'both)
- (prbold "Create Account")
- (br2)
- (if (acons afterward)
- (let (f url) afterward
- (arformh (fn (req)
- (logout-user (get-user req))
- (with (user (arg req "u") pw (arg req "p"))
- (aif (bad-newacct user pw)
- (flink (fn ignore
- (login-page switch it afterward)))
- (do (create-acct user pw)
- (= (logins* user) (req 'ip))
- (prcookie (cook-user user))
- (f user (req 'ip))
- url))))
- (pwfields "create account")))
- (aformh (fn (req)
- (logout-user (get-user req))
- (with (user (arg req "u") pw (arg req "p"))
- (aif (bad-newacct user pw)
- (do (prn)
- (login-page switch it afterward))
- (do (create-acct user pw)
- (= (logins* user) (req 'ip))
- (prcookie (cook-user user))
- (prn)
- (afterward user (req 'ip))))))
- (pwfields "create account"))))))
-
-(def prcookie (cook)
- (prn "Set-Cookie: user=" cook "; expires=Sun, 17-Jan-2038 19:14:07 GMT"))
-
-(def pwfields ((o label "login"))
- (inputs u username 20 nil
- p password 20 nil)
- (br)
- (submit label))
-
-(= good-logins* (queue) bad-logins* (queue))
-
-(def good-login (user pw ip)
- (let record (list (seconds) ip user)
- (if (and user pw (aand (shash pw) (is it (hpasswords* user))))
- (do (unless (user->cookie* user) (cook-user user))
- (enq-limit record good-logins*)
- user)
- (do (enq-limit record bad-logins*)
- nil))))
-
-; can remove this once sha1 installed on pi
-
-; Create a file in case people have quote chars in their pws. I can't
-; believe there's no way to just send the chars.
-
-(def shash (str)
- (let fname (+ "/tmp/shash" (rand-string 10))
- (w/outfile f fname (disp str f))
- (let res (tostring (system (+ "openssl dgst -sha1 <" fname)))
- (do1 (cut res 0 (- (len res) 1))
- (rmfile fname)))))
-
-(def bad-newacct (user pw)
- (if (no (goodname user 2 15))
- "Usernames can only contain letters, digits, dashes and
- underscores, and should be between 2 and 15 characters long.
- Please choose another."
- (let dcuser (downcase user)
- (some [is dcuser (downcase _)] (keys hpasswords*)))
- "That username is taken. Please choose another."
- (or (no pw) (< (len pw) 4))
- "Passwords should be a least 4 characters long. Please
- choose another."
- nil))
-
-(def goodname (str (o min 1) (o max nil))
- (and (isa str 'string)
- (>= (len str) min)
- (~find (fn (c) (no (or (alphadig c) (in c #\- #\_))))
- str)
- (isnt (str 0) #\-)
- (or (no max) (<= (len str) max))
- str))
-
-
-(defop logout req
- (aif (get-user req)
- (do (logout-user it)
- (pr "Logged out."))
- (pr "You were not logged in.")))
-
-(defop whoami req
- (aif (get-user req)
- (prs it 'at (req 'ip))
- (do (pr "You are not logged in. ")
- (w/link (login-page 'both) (pr "Log in"))
- (pr "."))))
-
-
-
-(= formwid* 60 bigformwid* 80 numwid* 8 formatdoc-url* nil)
-
-; Eventually figure out a way to separate type name from format of
-; input field, instead of having e.g. toks and bigtoks
-
-(def varfield (typ id val)
- (if (in typ 'string 'string1 'url)
- (gentag input type 'text name id value val size formwid*)
- (in typ 'num 'int 'posint)
- (gentag input type 'text name id value val size numwid*)
- (in typ 'users 'toks)
- (gentag input type 'text name id value (tostring (apply prs val))
- size formwid*)
- (is typ 'sexpr)
- (gentag input type 'text name id
- value (tostring (map [do (write _) (sp)] val))
- size formwid*)
- (in typ 'syms 'text 'doc 'mdtext 'mdtext2 'lines 'bigtoks)
- (let text (if (in typ 'syms 'bigtoks)
- (tostring (apply prs val))
- (in typ 'mdtext 'mdtext2)
- (unmarkdown val)
- (no val)
- ""
- val)
- (tag (textarea cols (if (is typ 'doc) bigformwid* formwid*)
- rows (needrows text formwid* 4)
- wrap 'virtual
- style (if (is typ 'doc) "font-size:8.5pt")
- name id)
- (prn) ; needed or 1 initial newline gets chopped off
- (pr text))
- (when (and formatdoc-url* (in typ 'mdtext 'mdtext2))
- (pr " ")
- (tag (font size -2)
- (link "help" formatdoc-url* (gray 175)))))
- (caris typ 'choice)
- (menu id (cddr typ) val)
- (is typ 'yesno)
- (menu id '("yes" "no") (if val "yes" "no"))
- (is typ 'hexcol)
- (gentag input type 'text name id value val); was (hexrep val)
- (err "unknown varfield type" typ)))
-
-(def text-rows (text wid (o pad 3))
- (+ (trunc (/ (len text) (* wid .8))) pad))
-
-(def needrows (text cols (o pad 0))
- (+ pad (max (+ 1 (count #\newline text))
- (roundup (/ (len text) (- cols 5))))))
-
-(def varline (typ id val)
- (if (in typ 'users 'syms 'toks 'bigtoks) (apply prs val)
- (is typ 'lines) (map prn val)
- (is typ 'yesno) (pr (if val 'yes 'no))
- (caris typ 'choice) (varline (cadr typ) nil val)
- (text-type typ) (pr (or val ""))
- (pr val)))
-
-(def text-type (typ) (in typ 'string 'string1 'url 'text 'mdtext 'mdtext2))
-
-; Newlines in forms come back as /r/n. Only want the /ns. Currently
-; remove the /rs in individual cases below. Could do it in aform or
-; even in the parsing of http requests, in the server.
-
-; Need the calls to striptags so that news users can't get html
-; into a title or comment by editing it. If want a form that
-; can take html, just create another typ for it.
-
-(def readvar (typ str (o fail nil))
- (case (carif typ)
- string (striptags str)
- string1 (if (is str "") fail (striptags str))
- url (if (is str "") str (valid-url str) (striptags str) fail)
- num (let n (saferead str) (if (number n) n fail))
- int (let n (saferead str)
- (if (number n) (round n) fail))
- posint (let n (saferead str)
- (if (and (number n) (> n 0)) (round n) fail))
- text (striptags str)
- doc (striptags str)
- mdtext (md-from-form str)
- mdtext2 (md-from-form str t) ; for md with no links
- ; sym (aif (tokens str) (sym (car it)) fail)
- ; syms (map sym (tokens str))
- sexpr (errsafe (readall str))
- users (rem [no (goodname _)] (tokens str))
- toks (tokens str)
- bigtoks (tokens str)
- ; lines (or (splitlines (= sss str)) fail)
- choice (readvar (cadr typ) str)
- yesno (is str "yes")
- hexcol (if (hex>color str) str fail) ; was (or (hex>color str) fail)
- (err "unknown readvar type" typ)))
-
-(def splitlines (str)
- (map [rem #\return _] (split (cons #\newline "") str)))
-
-(= fail* (uniq))
-
-; Takes a list of fields of the form (type label value view modify) and
-; a fn f and generates a form such that when submitted (f label newval)
-; will be called for each valid value. Finally done is called.
-
-(def vars-form (user fields f done (o button "update") (o lasts))
- (timed-aform lasts
- (fn (req)
- (when-umatch user req
- (each (k v) (req 'args)
- (let name (sym k)
- (awhen (find [is (cadr _) name] fields)
- (let (typ id val mod) it
- (when (and mod v)
- (let newval (readvar typ v fail*)
- (unless (is newval fail*)
- (f name newval))))))))
- (done)))
- (tab
- (showvars fields))
- (unless (all [no (_ 4)] fields) ; no modifiable fields
- (br)
- (submit button))))
-
-(def showvars (fields)
- (each (typ id val view mod question) fields
- (when view
- (when question
- (tr (td (prn question))))
- (tr (unless question (tag (td valign 'top) (pr id ":")))
- (td ((if mod varfield varline) typ id val)))
- (prn))))
-
-; http://daringfireball.net/projects/markdown/syntax
-
-(def md-from-form (str (o nolinks))
- (markdown (trim (rem #\return (esc<>& str)) 'end) 60 nolinks))
-
-(def markdown (s (o maxurl) (o nolinks))
- (let ital nil
- (tostring
- (forlen i s
- (iflet (newi spaces) (indented-code s i (if (is i 0) 2 0))
- (do (pr "<p><pre><code>")
- (let cb (code-block s (- newi spaces 1))
- (pr cb)
- (= i (+ (- newi spaces 1) (len cb))))
- (pr "</code></pre>"))
- (iflet newi (parabreak s i (if (is i 0) 1 0))
- (do (unless (is i 0) (pr "<p>"))
- (= i (- newi 1)))
- (and (is (s i) #\*)
- (or ital
- (atend i s)
- (and (~whitec (s (+ i 1)))
- (pos #\* s (+ i 1)))))
- (do (pr (if ital "</i>" "<i>"))
- (= ital (no ital)))
- (and (no nolinks)
- (or (litmatch "http://" s i)
- (litmatch "https://" s i)))
- (withs (n (urlend s i)
- url (cut s i n))
- (tag (a href url rel 'nofollow)
- (pr (if (no maxurl) url (ellipsize url maxurl))))
- (= i (- n 1)))
- (writec (s i))))))))
-
-(def indented-code (s i (o newlines 0) (o spaces 0))
- (let c (s i)
- (if (nonwhite c)
- (if (and (> newlines 1) (> spaces 1))
- (list i spaces)
- nil)
- (atend i s)
- nil
- (is c #\newline)
- (indented-code s (+ i 1) (+ newlines 1) 0)
- (indented-code s (+ i 1) newlines (+ spaces 1)))))
-
-(def parabreak (s i (o newlines 0))
- (let c (s i)
- (if (or (nonwhite c) (atend i s))
- (if (> newlines 1) i nil)
- (parabreak s (+ i 1) (+ newlines (if (is c #\newline) 1 0))))))
-
-
-; Returns the index of the first char not part of the url beginning
-; at i, or len of string if url goes all the way to the end.
-
-; Note that > immediately after a url (http://foo.com>) will cause
-; an odd result, because the > gets escaped to something beginning
-; with &, which is treated as part of the url. Perhaps the answer
-; is just to esc<>& after markdown instead of before.
-
-(def urlend (s i)
- (let c (s i)
- (if (atend i s)
- (if ((orf punc delimc whitec) c) i (+ i 1))
- (if (or (whitec c)
- (delimc c)
- (and (punc c)
- ((orf whitec delimc) (s (+ i 1)))))
- i
- (urlend s (+ i 1))))))
-
-(def delimc (c)
- (in c #\( #\) #\[ #\] #\{ #\} #\"))
-
-
-(def code-block (s i)
- (tostring
- (until (let left (- (len s) i 1)
- (or (is left 0)
- (and (> left 2)
- (is (s (+ i 1)) #\newline)
- (nonwhite (s (+ i 2))))))
- (writec (s (++ i))))))
-
-(def unmarkdown (s)
- (tostring
- (forlen i s
- (if (litmatch "<p>" s i)
- (do (++ i 2)
- (unless (is i 2) (pr "\n\n")))
- (litmatch "<i>" s i)
- (do (++ i 2) (pr #\*))
- (litmatch "</i>" s i)
- (do (++ i 3) (pr #\*))
- (litmatch "<a href=" s i)
- (let endurl (posmatch [in _ #\> #\space] s (+ i 9))
- (if endurl
- (do (pr (cut s (+ i 9) (- endurl 1)))
- (= i (aif (posmatch "</a>" s endurl)
- (+ it 3)
- endurl)))
- (writec (s i))))
- (litmatch "<pre><code>" s i)
- (awhen (findsubseq "</code></pre>" s (+ i 12))
- (pr (cut s (+ i 11) it))
- (= i (+ it 12)))
- (litmatch "<pre><code>" s i)
- (awhen (findsubseq "</code></pre>" s (+ i 12))
- (pr (cut s (+ i 11) it))
- (= i (+ it 12)))
- (writec (s i))))))
-
-
-(mac defopl (name parm . body)
- `(defop ,name ,parm
- (if (get-user ,parm)
- (do ,@body)
- (login-page 'both
- "You need to be logged in to do that."
- (list (fn (u ip))
- (string ',name (reassemble-args ,parm)))))))
-
View
1,542 src/java/arc/arc.arc
@@ -1,1542 +0,0 @@
-; Main Arc lib. Ported to Scheme version Jul 06.
-
-; 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
-; 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
-
-
-(set do (annotate 'mac
- (fn args `((fn () ,@args)))))
-
-(set safeset (annotate 'mac
- (fn (var val)
- `(do (if (bound ',var)
- (do (disp "*** redefining ")
- (disp ',var)
- (writec #\newline)))
- (set ,var ,val)))))
-
-(set def (annotate 'mac
- (fn (name parms . body)
- `(do (sref sig ',parms ',name)
- (safeset ,name (fn ,parms ,@body))))))
-
-(def caar (xs) (car (car xs)))
-(def cadr (xs) (car (cdr xs)))
-(def cddr (xs) (cdr (cdr xs)))
-
-(def no (x) (is x nil))
-
-(def acons (x) (is (type x) 'cons))
-
-(def atom (x) (no (acons x)))
-
-(def list args args)
-
-(def idfn (x) x)
-
-; Maybe later make this internal. Useful to let xs be a fn?
-
-(def map1 (f xs)
- (if (no xs)
- nil
- (cons (f (car xs)) (map1 f (cdr xs)))))
-
-(def pair (xs (o f list))
- (if (no xs)
- nil
- (no (cdr xs))
- (list (list (car xs)))
- (cons (f (car xs) (cadr xs))
- (pair (cddr xs) f))))
-
-(set mac (annotate 'mac
- (fn (name parms . body)
- `(do (sref sig ',parms ',name)
- (safeset ,name (annotate 'mac (fn ,parms ,@body)))))))
-
-(mac and args
- (if args
- (if (cdr args)
- `(if ,(car args) (and ,@(cdr args)))
- (car args))
- 't))
-
-(def assoc (key al)
- (if (atom al)
- nil
- (and (acons (car al)) (is (caar al) key))
- (car al)
- (assoc key (cdr al))))
-
-(def alref (al key) (cadr (assoc key al)))
-
-(mac with (parms . body)
- `((fn ,(map1 car (pair parms))
- ,@body)
- ,@(map1 cadr (pair parms))))
-
-(mac let (var val . body)
- `(with (,var ,val) ,@body))
-
-(mac withs (parms . body)
- (if (no parms)
- `(do ,@body)
- `(let ,(car parms) ,(cadr parms)
- (withs ,(cddr parms) ,@body))))
-
-; Rtm prefers to overload + to do this
-
-(def join args
- (if (no args)
- nil
- (let a (car args)
- (if (no a)
- (apply join (cdr args))
- (cons (car a) (apply join (cdr a) (cdr args)))))))
-
-; Need rfn for use in macro expansions.
-
-(mac rfn (name parms . body)
- `(let ,name nil
- (set ,name (fn ,parms ,@body))))
-
-(mac afn (parms . body)
- `(let self nil
- (set self (fn ,parms ,@body))))
-
-; Ac expands x:y:z into (compose x y z), ~x into (complement x)
-
-; Only used when the call to compose doesn't occur in functional position.
-; Composes in functional position are transformed away by ac.
-
-(mac compose args
- (let g (uniq)
- `(fn ,g
- ,((afn (fs)
- (if (cdr fs)
- (list (car fs) (self (cdr fs)))
- `(apply ,(if (car fs) (car fs) 'idfn) ,g)))
- args))))
-
-(mac complement (f)
- (let g (uniq)
- `(fn ,g (no (apply ,f ,g)))))
-
-(def rev (xs)
- ((afn (xs acc)
- (if (no xs)
- acc
- (self (cdr xs) (cons (car xs) acc))))
- xs nil))
-
-(def isnt (x y) (no (is x y)))
-
-(mac w/uniq (names . body)
- (if (acons names)
- `(with ,(apply + nil (map1 (fn (n) (list n '(uniq)))
- names))
- ,@body)
- `(let ,names (uniq) ,@body)))
-
-(mac or args
- (and args
- (w/uniq g
- `(let ,g ,(car args)
- (if ,g ,g (or ,@(cdr args)))))))
-
-(def alist (x) (or (no x) (is (type x) 'cons)))
-
-(mac in (x . choices)
- (w/uniq g
- `(let ,g ,x
- (or ,@(map1 (fn (c) `(is ,g ,c)) choices)))))
-
-; should take n args
-
-(def iso (x y)
- (or (is x y)
- (and (acons x)
- (acons y)
- (iso (car x) (car y))
- (iso (cdr x) (cdr y)))))
-
-(mac when (test . body)
- `(if ,test (do ,@body)))
-
-(mac unless (test . body)
- `(if (no ,test) (do ,@body)))
-
-(mac while (test . body)
- (w/uniq (gf gp)
- `((rfn ,gf (,gp)
- (when ,gp ,@body (,gf ,test)))
- ,test)))
-
-(def empty (seq)
- (or (no seq)
- (and (no (acons seq)) (is (len seq) 0))))
-
-(def reclist (f xs)
- (and xs (or (f xs) (reclist f (cdr xs)))))
-
-(def recstring (test s (o start 0))
- (let n (len s)
- ((afn (i)
- (and (< i (len s))
- (or (test i)
- (self (+ i 1)))))
- start)))
-
-(def testify (x)
- (if (isa x 'fn) x [is _ x]))
-
-(def some (test seq)
- (let f (testify test)
- (if (alist seq)
- (reclist f:car seq)
- (recstring f:seq seq))))
-
-(def all (test seq)
- (~some (complement (testify test)) seq))
-
-(def mem (test seq)
- (let f (testify test)
- (reclist [if (f:car _) _] seq)))
-
-(def find (test seq)
- (let f (testify test)
- (if (alist seq)
- (reclist [if (f:car _) (car _)] seq)
- (recstring [if (f:seq _) (seq _)] seq))))
-
-(def isa (x y) (is (type x) y))
-
-; Possible to write map without map1, but makes News 3x slower.
-
-;(def map (f . seqs)
-; (if (some1 no seqs)
-; nil
-; (no (cdr seqs))
-; (let s1 (car seqs)
-; (cons (f (car s1))
-; (map f (cdr s1))))
-; (cons (apply f (map car seqs))
-; (apply map f (map cdr seqs)))))
-
-
-(def map (f . seqs)
- (if (some [isa _ 'string] seqs)
- (withs (n (apply min (map len seqs))
- new (newstring n))
- ((afn (i)
- (if (is i n)
- new
- (do (sref new (apply f (map [_ i] seqs)) i)
- (self (+ i 1)))))
- 0))
- (no (cdr seqs))
- (map1 f (car seqs))
- ((afn (seqs)
- (if (some no seqs)
- nil
- (cons (apply f (map1 car seqs))
- (self (map1 cdr seqs)))))
- seqs)))
-
-(def mappend (f . args)
- (apply + nil (apply map f args)))
-
-(def firstn (n xs)
- (if (no n) xs
- (and (> n 0) xs) (cons (car xs) (firstn (- n 1) (cdr xs)))
- nil))
-
-(def nthcdr (n xs)
- (if (no n) xs
- (> n 0) (nthcdr (- n 1) (cdr xs))
- xs))
-
-; Generalization of pair: (tuples x) = (pair x)
-
-(def tuples (xs (o n 2))
- (if (no xs)
- nil
- (cons (firstn n xs)
- (tuples (nthcdr n xs) n))))
-
-(def caris (x val)
- (and (acons x) (is (car x) val)))
-
-(def warn (msg . args)
- (disp (+ "Warning: " msg ". "))
- (map [do (write _) (disp " ")] args)
- (disp #\newline))
-
-(mac atomic body
- `(atomic-invoke (fn () ,@body)))
-
-(mac atlet args
- `(atomic (let ,@args)))
-
-(mac atwith args
- `(atomic (with ,@args)))
-
-(mac atwiths args
- `(atomic (withs ,@args)))
-
-; setforms returns (vars get set) for a place based on car of an expr
-; vars is a list of gensyms alternating with expressions whose vals they
-; should be bound to, suitable for use as first arg to withs
-; get is an expression returning the current value in the place
-; set is an expression representing a function of one argument
-; that stores a new value in the place
-
-; A bit gross that it works based on the *name* in the car, but maybe
-; wrong to worry. Macros live in expression land.
-
-; seems meaningful to e.g. (push 1 (pop x)) if (car x) is a cons.
-; can't in cl though. could I define a setter for push or pop?
-
-(set setter (table))
-
-(mac defset (name parms . body)
- (w/uniq gexpr
- `(sref setter
- (fn (,gexpr)
- (let ,parms (cdr ,gexpr)
- ,@body))
- ',name)))
-
-(defset car (x)
- (w/uniq g
- (list (list g x)
- `(car ,g)
- `(fn (val) (scar ,g val)))))
-
-(defset cdr (x)
- (w/uniq g
- (list (list g x)
- `(cdr ,g)
- `(fn (val) (scdr ,g val)))))
-
-(defset caar (x)
- (w/uniq g
- (list (list g x)
- `(caar ,g)
- `(fn (val) (scar (car ,g) val)))))
-
-(defset cadr (x)
- (w/uniq g
- (list (list g x)
- `(cadr ,g)
- `(fn (val) (scar (cdr ,g) val)))))
-
-(defset cddr (x)
- (w/uniq g
- (list (list g x)
- `(cddr ,g)
- `(fn (val) (scdr (cdr ,g) val)))))
-
-; Note: if expr0 macroexpands into any expression whose car doesn't
-; have a setter, setforms assumes it's a data structure in functional
-; position. Such bugs will be seen only when the code is executed, when
-; sref complains it can't set a reference to a function.
-
-(def setforms (expr0)
- (let expr (macex expr0)
- (if (isa expr 'sym)
- (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)
- (or (ssyntax x)
- (and (acons x) (in (car x) 'compose 'complement))))
-
-(def expand-metafn-call (f args)
- (if (is (car f) 'compose)
- ((afn (fs)
- (if (caris (car fs) 'compose) ; nested compose
- (self (join (cdr (car fs)) (cdr fs)))
- (cdr fs)
- (list (car fs) (self (cdr fs)))
- (cons (car fs) args)))
- (cdr f))
- (err "Can't invert " (cons f args))))
-
-(def expand= (place val)
- (if (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
- (expand=list args))
-
-(mac loop (start test update . body)
- (w/uniq (gfn gparm)
- `(do ,start
- ((rfn ,gfn (,gparm)
- (if ,gparm
- (do ,@body ,update (,gfn ,test))))
- ,test))))
-
-(mac for (v init max . body)
- (w/uniq (gi gm)
- `(with (,v nil ,gi ,init ,gm (+ ,max 1))
- (loop (set ,v ,gi) (< ,v ,gm) (set ,v (+ ,v 1))
- ,@body))))
-
-(mac repeat (n . body)
- `(for ,(uniq) 1 ,n ,@body))
-
-; could bind index instead of gensym
-
-(mac each (var expr . body)
- (w/uniq (gseq g)
- `(let ,gseq ,expr
- (if (alist ,gseq)
- ((afn (,g)
- (when (acons ,g)
- (let ,var (car ,g) ,@body)
- (self (cdr ,g))))
- ,gseq)
- (isa ,gseq 'table)
- (maptable (fn (,g ,var) ,@body)
- ,gseq)
- (for ,g 0 (- (len ,gseq) 1)
- (let ,var (,gseq ,g) ,@body))))))
-
-; (nthcdr x y) = (cut y x).
-
-(def cut (seq start (o end (len seq)))
- (let end (if (< end 0) (+ (len seq) end) end)
- (if (isa seq 'string)
- (let s2 (newstring (- end start))
- (for i 0 (- end start 1)
- (= (s2 i) (seq (+ start i))))
- s2)
- (firstn (- end start) (nthcdr start seq)))))
-
-(mac ontable (k v h . body)
- `(maptable (fn (,k ,v) ,@body) ,h))
-
-(mac whilet (var test . body)
- (w/uniq (gf gp)
- `((rfn ,gf (,gp)
- (let ,var ,gp
- (when ,var ,@body (,gf ,test))))
- ,test)))
-
-(def last (xs)
- (if (cdr xs)
- (last (cdr xs))
- (car xs)))
-
-(def rem (test seq)
- (let f (testify test)
- (if (alist seq)
- ((afn (s)
- (if (no s) nil
- (f (car s)) (self (cdr s))
- (cons (car s) (self (cdr s)))))
- seq)
- (coerce (rem test (coerce seq 'cons)) 'string))))
-
-(def keep (test seq)
- (rem (complement (testify test)) seq))
-
-(def trues (f seq)
- (rem nil (map f seq)))
-
-(mac do1 args
- (w/uniq g
- `(let ,g ,(car args)
- ,@(cdr args)
- ,g)))
-
-; Would like to write a faster case based on table generated by a macro,
-; but can't insert objects into expansions in Mzscheme.
-
-(mac caselet (var expr . args)
- (let ex (afn (args)
- (if (no (cdr args))
- (car args)
- `(if (is ,var ',(car args))
- ,(cadr args)
- ,(self (cddr args)))))
- `(let ,var ,expr ,(ex args))))
-
-(mac case (expr . args)
- `(caselet ,(uniq) ,expr ,@args))
-
-(mac push (x place)
- (w/uniq gx
- (let (binds val setter) (setforms place)
- `(let ,gx ,x
- (atwiths ,binds
- (,setter (cons ,gx ,val)))))))
-
-(mac swap (place1 place2)
- (w/uniq (g1 g2)
- (with ((binds1 val1 setter1) (setforms place1)
- (binds2 val2 setter2) (setforms place2))
- `(atwiths ,(+ binds1 (list g1 val1) binds2 (list g2 val2))
- (,setter1 ,g2)
- (,setter2 ,g1)))))
-
-(mac rotate places
- (with (vars (map [uniq] places)
- forms (map setforms places))
- `(atwiths ,(mappend (fn (g (binds val setter))
- (+ binds (list g val)))
- vars
- forms)
- ,@(map (fn (g (binds val setter))
- (list setter g))
- (+ (cdr vars) (list (car vars)))
- forms))))
-
-(mac pop (place)
- (w/uniq g
- (let (binds val setter) (setforms place)
- `(atwiths ,(+ binds (list g val))
- (do1 (car ,g)
- (,setter (cdr ,g)))))))
-
-(def adjoin (x xs (o test iso))
- (if (some [test x _] xs)
- xs
- (cons x xs)))
-
-(mac pushnew (x place . args)
- (w/uniq gx
- (let (binds val setter) (setforms place)
- `(atwiths ,(+ (list gx x) binds)
- (,setter (adjoin ,gx ,val ,@args))))))
-
-(mac pull (test place)
- (w/uniq g
- (let (binds val setter) (setforms place)
- `(atwiths ,(+ (list g test) binds)
- (,setter (rem ,g ,val))))))
-
-(mac ++ (place (o i 1))
- (if (isa place 'sym)
- `(= ,place (+ ,place ,i))
- (w/uniq gi
- (let (binds val setter) (setforms place)
- `(atwiths ,(+ binds (list gi i))
- (,setter (+ ,val ,gi)))))))
-
-(mac -- (place (o i 1))
- (if (isa place 'sym)
- `(= ,place (- ,place ,i))
- (w/uniq gi
- (let (binds val setter) (setforms place)
- `(atwiths ,(+ binds (list gi i))
- (,setter (- ,val ,gi)))))))
-
-; E.g. (inc x) equiv to (zap + x 1)
-
-(mac zap (op place . args)
- (with (gop (uniq)
- gargs (map [uniq] args)
- mix (afn seqs
- (if (some no seqs)
- nil
- (+ (map car seqs)
- (apply self (map cdr seqs))))))
- (let (binds val setter) (setforms place)
- `(atwiths ,(+ binds (list gop op) (mix gargs args))
- (,setter (,gop ,val ,@gargs))))))
-
-; Can't simply mod pr to print strings represented as lists of chars,
-; because empty string will get printed as nil. Would need to rep strings
-; as lists of chars annotated with 'string, and modify car and cdr to get
-; the rep of these. That would also require hacking the reader.
-
-(def pr args
- (map1 disp args)
- (car args))
-
-(def prn args
- (do1 (apply pr args)
- (writec #\newline)))
-
-(mac wipe args
- `(do ,@(map (fn (a) `(= ,a nil)) args)))
-
-(mac assert args
- `(do ,@(map (fn (a) `(= ,a t)) args)))
-
-; Destructuring means ambiguity: are pat vars bound in else? (no)
-
-(mac iflet (var expr then . rest)
- (w/uniq gv
- `(let ,gv ,expr
- (if ,gv (let ,var ,gv ,then) ,@rest))))
-
-(mac whenlet (var expr . body)
- `(iflet ,var ,expr (do ,@body)))
-
-(mac aif (expr . body)
- `(let it ,expr
- (if it
- ,@(if (cddr body)
- `(,(car body) (aif ,@(cdr body)))
- body))))
-
-(mac awhen (expr . body)
- `(let it ,expr (if it (do ,@body))))
-
-(mac aand args
- (if (no args)
- 't
- (no (cdr args))
- (car args)
- `(let it ,(car args) (and it (aand ,@(cdr args))))))
-
-(mac accum (accfn . body)
- (w/uniq gacc
- `(withs (,gacc nil ,accfn [push _ ,gacc])
- ,@body
- ,gacc)))
-
-; Repeatedly evaluates its body till it returns nil, then returns vals.
-
-(mac drain (expr (o eof nil))
- (w/uniq (gacc gdone gres)
- `(with (,gacc nil ,gdone nil)
- (while (no ,gdone)
- (let ,gres ,expr
- (if (is ,gres ,eof)
- (= ,gdone t)
- (push ,gres ,gacc))))
- (rev ,gacc))))
-
-; For the common C idiom while x = snarfdata != stopval.
-; Rename this if use it often.
-
-(mac whiler (var expr endval . body)
- (w/uniq gf
- `((rfn ,gf (,var)
- (when (and ,var (no (is ,var ,endval)))
- ,@body
- (,gf ,expr)))
- ,expr)))
-
-;(def macex (e)
-; (if (atom e)
-; e
-; (let op (and (atom (car e)) (eval (car e)))
-; (if (isa op 'mac)
-; (apply (rep op) (cdr e))
-; e))))
-
-(def consif (x y) (if x (cons x y) y))
-
-(def string args
- (apply + "" (map [coerce _ 'string] args)))
-
-(def flat (x (o stringstoo))
- ((rfn f (x acc)
- (if (or (no x) (and stringstoo (is x "")))
- acc
- (and (atom x) (no (and stringstoo (isa x 'string))))
- (cons x acc)
- (f (car x) (f (cdr x) acc))))
- x nil))
-
-(mac check (x test (o alt))
- (w/uniq gx
- `(let ,gx ,x
- (if (,test ,gx) ,gx ,alt))))
-
-(def pos (test seq (o start 0))
- (let f (testify test)
- (if (alist seq)
- ((afn (seq n)
- (if (no seq)
- nil
- (f (car seq))
- n
- (self (cdr seq) (+ n 1))))
- (nthcdr start seq)
- start)
- (recstring [if (f (seq _)) _] seq start))))
-
-(def even (n) (is (mod n 2) 0))
-
-(def odd (n) (no (even n)))
-
-(mac after (x . ys)
- `(protect (fn () ,x) (fn () ,@ys)))
-
-(let expander
- (fn (f var name body)
- `(let ,var (,f ,name)
- (after (do ,@body) (close ,var))))
-
- (mac w/infile (var name . body)
- (expander 'infile var name body))
-
- (mac w/outfile (var name . body)
- (expander 'outfile var name body))
-
- (mac w/instring (var str . body)
- (expander 'instring var str body))
-
- (mac w/socket (var port . body)
- (expander 'open-socket var port body))
- )
-
-(mac w/outstring (var . body)
- `(let ,var (outstring) ,@body))
-
-(mac w/appendfile (var name . body)
- `(let ,var (outfile ,name 'append)
- (after (do ,@body) (close ,var))))
-
-; rename this simply "to"? - prob not; rarely use
-
-(mac w/stdout (str . body)
- `(call-w/stdout ,str (fn () ,@body)))
-
-(mac w/stdin (str . body)
- `(call-w/stdin ,str (fn () ,@body)))
-
-(mac tostring body
- (w/uniq gv
- `(w/outstring ,gv
- (w/stdout ,gv ,@body)
- (inside ,gv))))
-
-(mac fromstring (str . body)
- (w/uniq gv
- `(w/instring ,gv ,str
- (w/stdin ,gv ,@body))))
-
-(def readstring1 (s (o eof nil)) (w/instring i s (read i eof)))
-
-(def read ((o x (stdin)) (o eof nil))
- (if (isa x 'string) (readstring1 x eof) (sread x eof)))
-
-(def readfile (name) (w/infile s name (drain (read s))))
-
-(def readfile1 (name) (w/infile s name (read s)))
-
-(def writefile1 (val name) (w/outfile s name (write val s)) val)
-
-(def readall (src (o eof nil))
- ((afn (i)
- (let x (read i eof)
- (if (is x eof)
- nil
- (cons x (self i)))))
- (if (isa src 'string) (instring src) src)))
-
-(def sym (x) (coerce x 'sym))
-
-(mac rand-choice exprs
- `(case (rand ,(len exprs))
- ,@(let key -1
- (mappend [list (++ key) _]
- exprs))))
-
-(mac n-of (n expr)
- (w/uniq ga
- `(let ,ga nil
- (repeat ,n (push ,expr ,ga))
- (rev ,ga))))
-
-(def rand-string (n)
- (with (cap (fn () (+ 65 (rand 26)))
- sm (fn () (+ 97 (rand 26)))
- dig (fn () (+ 48 (rand 10))))
- (coerce (map [coerce _ 'char]
- (cons (rand-choice (cap) (sm))
- (n-of (- n 1) (rand-choice (cap) (sm) (dig)))))
- 'string)))
-
-(mac forlen (var s . body)
- `(for ,var 0 (- (len ,s) 1) ,@body))
-
-(mac on (var s . body)
- (if (is var 'index)
- (err "Can't use index as first arg to on.")
- (w/uniq gs
- `(let ,gs ,s
- (forlen index ,gs
- (let ,var (,gs index)
- ,@body))))))
-
-(def best (f seq)
- (if (no seq)
- nil
- (let wins (car seq)
- (each elt (cdr seq)
- (if (f elt wins) (= wins elt)))
- wins)))
-
-(def max args (best > args))
-(def min args (best < args))
-
-; (mac max2 (x y)
-; (w/uniq (a b)
-; `(with (,a ,x ,b ,y) (if (> ,a ,b) ,a ,b))))
-
-(def most (f seq)
- (unless (no seq)
- (withs (wins (car seq) topscore (f wins))
- (each elt (cdr seq)
- (let score (f elt)
- (if (> score topscore) (= wins elt topscore score))))
- wins)))
-
-; Insert so that list remains sorted. Don't really want to expose
-; these but seem to have to because can't include a fn obj in a
-; macroexpansion.
-
-(def insert-sorted (test elt seq)
- (if (no seq)
- (list elt)
- (test elt (car seq))
- (cons elt seq)
- (cons (car seq) (insert-sorted test elt (cdr seq)))))
-
-(mac insort (test elt seq)
- `(zap [insert-sorted ,test ,elt _] ,seq))
-
-(def reinsert-sorted (test elt seq)
- (if (no seq)
- (list elt)
- (is elt (car seq))
- (reinsert-sorted test elt (cdr seq))
- (test elt (car seq))
- (cons elt (rem elt seq))
- (cons (car seq) (reinsert-sorted test elt (cdr seq)))))
-
-(mac insortnew (test elt seq)
- `(zap [reinsert-sorted ,test ,elt _] ,seq))
-
-; Could make this look at the sig of f and return a fn that took the
-; right no of args and didn't have to call apply (or list if 1 arg).
-
-(def memo (f)
- (let cache (table)
- (fn args
- (or (cache args)
- (= (cache args) (apply f args))))))
-
-(mac defmemo (name parms . body)
- `(safeset ,name (memo (fn ,parms ,@body))))
-
-(def <= args
- (or (no args)
- (no (cdr args))
- (and (no (> (car args) (cadr args)))
- (apply <= (cdr args)))))
-
-(def >= args
- (or (no args)
- (no (cdr args))
- (and (no (< (car args) (cadr args)))
- (apply >= (cdr args)))))
-
-(def whitec (c)
- (in c #\space #\newline #\tab #\return))