Permalink
Browse files

- remove thread parameter in java code all over the place

 - optimise compose/complement in fn position just like arc does
 - new andf ssyntax
 - new flushout builtin from arc3
 - coerce int->num fix
 - no longer use rainbow/init.arc; call* defined in Console
 - updated spiral.arc for arc3 changes
  • Loading branch information...
1 parent 3bc7e37 commit 671231f890416e9940857c5f5fa739a89c606972 conan committed Jun 25, 2009
Showing with 1,185 additions and 1,106 deletions.
  1. +1 −1 LICENSE.txt
  2. +156 −67 src/arc/ac.scm
  3. +1 −5 src/arc/app.arc
  4. +162 −114 src/arc/arc.arc
  5. +11 −2 src/arc/how-to-run-news
  6. +10 −2 src/arc/html.arc
  7. +6 −96 src/arc/lib/parser.arc
  8. +6 −6 src/arc/lib/source.arc
  9. +3 −3 src/arc/lib/tests/core-errors-continuations-test.arc
  10. +79 −1 src/arc/lib/tests/core-evaluation-test.arc
  11. +11 −13 src/arc/lib/tests/core-special-forms-test.arc
  12. +6 −2 src/arc/lib/tests/core-typing-test.arc
  13. +9 −9 src/arc/lib/tests/parser-test.arc
  14. +3 −0 src/arc/lib/unit-test.arc
  15. +234 −343 src/arc/news.arc
  16. +7 −7 src/arc/pprint.arc
  17. +0 −6 src/arc/rainbow/init.arc
  18. +40 −27 src/arc/rainbow/spiral.arc
  19. +5 −36 src/arc/rainbow/tests/chained-ssexpand-test.arc
  20. +66 −61 src/arc/srv.arc
  21. 0 {arc/public_html → src/arc/static}/spiral.css
  22. 0 {arc/public_html → src/arc/static}/spiral.js
  23. +0 −1 src/cc/ArcParser.jj
  24. +2 −2 src/java/rainbow/Console.java
  25. +1 −2 src/java/rainbow/Function.java
  26. +9 −2 src/java/rainbow/Nil.java
  27. +3 −4 src/java/rainbow/functions/Builtin.java
  28. +8 −9 src/java/rainbow/functions/Errors.java
  29. +47 −12 src/java/rainbow/functions/Evaluation.java
  30. +27 −22 src/java/rainbow/functions/IO.java
  31. +7 −8 src/java/rainbow/functions/InterpretedFunction.java
  32. +1 −2 src/java/rainbow/functions/Java.java
  33. +3 −4 src/java/rainbow/functions/Macex.java
  34. +4 −4 src/java/rainbow/functions/Predicates.java
  35. +4 −5 src/java/rainbow/functions/SystemFunctions.java
  36. +2 −3 src/java/rainbow/functions/Tables.java
  37. +11 −12 src/java/rainbow/functions/Threads.java
  38. +11 −4 src/java/rainbow/functions/Typing.java
  39. +11 −4 src/java/rainbow/types/ArcObject.java
  40. +3 −4 src/java/rainbow/types/ArcString.java
  41. +6 −7 src/java/rainbow/types/Hash.java
  42. +1 −1 src/java/rainbow/types/JavaProxy.java
  43. +4 −0 src/java/rainbow/types/Output.java
  44. +8 −5 src/java/rainbow/types/Pair.java
  45. +1 −2 src/java/rainbow/types/Symbol.java
  46. +3 −5 src/java/rainbow/types/Tagged.java
  47. +5 −0 src/java/rainbow/vm/Continuation.java
  48. +3 −5 src/java/rainbow/vm/compiler/AssignmentBuilder.java
  49. +30 −17 src/java/rainbow/vm/compiler/Compiler.java
  50. +4 −5 src/java/rainbow/vm/compiler/FunctionBodyBuilder.java
  51. +3 −5 src/java/rainbow/vm/compiler/FunctionParameterListBuilder.java
  52. +7 −9 src/java/rainbow/vm/compiler/IfBuilder.java
  53. +3 −5 src/java/rainbow/vm/compiler/MacExpander.java
  54. +4 −5 src/java/rainbow/vm/compiler/PairExpander.java
  55. +1 −1 src/java/rainbow/vm/compiler/QuasiQuoteBuilder.java
  56. +15 −15 src/java/rainbow/vm/compiler/QuasiQuoteCompiler.java
  57. +1 −1 src/java/rainbow/vm/compiler/Rebuilder.java
  58. +3 −4 src/java/rainbow/vm/continuations/AssignmentContinuation.java
  59. +5 −5 src/java/rainbow/vm/continuations/Atomic.java
  60. +2 −3 src/java/rainbow/vm/continuations/CallWStdinContinuation.java
  61. +2 −3 src/java/rainbow/vm/continuations/CallWStdoutContinuation.java
  62. +2 −3 src/java/rainbow/vm/continuations/ConditionalContinuation.java
  63. +23 −0 src/java/rainbow/vm/continuations/ContinuationSupport.java
  64. +3 −4 src/java/rainbow/vm/continuations/ErrorHandler.java
  65. +1 −1 src/java/rainbow/vm/continuations/ErrorPassingContinuation.java
  66. +5 −6 src/java/rainbow/vm/continuations/EvaluatorContinuation.java
  67. +7 −8 src/java/rainbow/vm/continuations/FunctionEvaluator.java
  68. +4 −5 src/java/rainbow/vm/continuations/InvocationContinuation.java
  69. +5 −5 src/java/rainbow/vm/continuations/NamespaceBuilder.java
  70. +4 −5 src/java/rainbow/vm/continuations/Protector.java
  71. +10 −10 src/java/rainbow/vm/continuations/QuasiQuoteContinuation.java
  72. +1 −1 src/java/rainbow/vm/continuations/ResultPassingContinuation.java
  73. +3 −3 src/java/rainbow/vm/continuations/TableMapper.java
  74. +1 −1 src/java/rainbow/vm/continuations/UnquoteSplicer.java
  75. +2 −3 src/java/rainbow/vm/interpreter/Assignment.java
  76. +1 −2 src/java/rainbow/vm/interpreter/BoundSymbol.java
  77. +1 −1 src/java/rainbow/vm/interpreter/Else.java
  78. +2 −3 src/java/rainbow/vm/interpreter/IfClause.java
  79. +2 −2 src/java/rainbow/vm/interpreter/IfThen.java
  80. +2 −3 src/java/rainbow/vm/interpreter/Invocation.java
  81. +2 −2 src/java/rainbow/vm/interpreter/LastIfThen.java
  82. +6 −3 src/java/rainbow/vm/interpreter/QuasiQuotation.java
  83. +1 −2 src/java/rainbow/vm/interpreter/Quotation.java
  84. +4 −5 src/java/rainbow/vm/interpreter/SingleAssignment.java
  85. +1 −2 src/java/rainbow/vm/interpreter/invocation/FirstArg.java
  86. +3 −5 src/java/rainbow/vm/interpreter/invocation/FunctionInvocation.java
  87. +1 −2 src/java/rainbow/vm/interpreter/invocation/IntermediateArg.java
  88. +1 −2 src/java/rainbow/vm/interpreter/invocation/InvocationComponent.java
  89. +2 −3 src/java/rainbow/vm/interpreter/invocation/LastArg.java
  90. +2 −3 src/java/rainbow/vm/interpreter/invocation/NoArgs.java
  91. +2 −3 src/java/rainbow/vm/interpreter/invocation/SingleArg.java
View
@@ -1,4 +1,4 @@
-This software is copyright (c) Conan Dalton 2008. All Rights Reserved. Permission to use it is granted under the Perl Foundations's Artistic License 2.0.
+This software is copyright (c) Conan Dalton 2008. Permission to use it is granted under the Perl Foundations's Artistic License 2.0.
This software includes software that is copyright (c) Paul Graham and Robert Morris, distributed under the Perl Foundations's Artistic License 2.0.
View
@@ -16,7 +16,7 @@
; 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
+ (cond ((string? s) (ac-string s env))
((literal? s) s)
((eqv? s 'nil) (list 'quote 'nil))
((ssyntax? s) (ac (expand-ssyntax s) env))
@@ -27,13 +27,30 @@
((eq? (xcar s) 'if) (ac-if (cdr s) env))
((eq? (xcar s) 'fn) (ac-fn (cadr s) (cddr s) env))
((eq? (xcar s) 'assign) (ac-set (cdr s) env))
- ; the next two clauses could be removed without changing semantics
+ ; the next three clauses could be removed without changing semantics
+ ; ... except that they work for macros (so prob should do this for
+ ; every elt of s, not just the car)
((eq? (xcar (xcar s)) 'compose) (ac (decompose (cdar s) (cdr s)) env))
((eq? (xcar (xcar s)) 'complement)
(ac (list 'no (cons (cadar s) (cdr s))) env))
+ ((eq? (xcar (xcar s)) 'andf) (ac-andf s env))
((pair? s) (ac-call (car s) (cdr s) env))
(#t (err "Bad object in expression" s))))
+(define atstrings #f)
+
+(define (ac-string s env)
+ (if atstrings
+ (if (atpos s 0)
+ (ac (cons 'string (map (lambda (x)
+ (if (string? x)
+ (unescape-ats x)
+ x))
+ (codestring s)))
+ env)
+ (unescape-ats s))
+ (string-copy s))) ; avoid immutable strings
+
(define (literal? x)
(or (boolean? x)
(char? x)
@@ -45,12 +62,17 @@
(and (symbol? x)
(not (or (eqv? x '+) (eqv? x '++) (eqv? x '_)))
(let ((name (symbol->string x)))
- (has-ssyntax-char? name (- (string-length name) 1)))))
+; (has-ssyntax-char? name (- (string-length name) 1)))))
+
+ (or (eqv? (string-ref name 0) #\~)
+ (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 #\_)
+ (or (eqv? c #\:) ;(eqv? c #\~)
+ (eqv? c #\+)
+ ;(eqv? c #\_)
(eqv? c #\.) (eqv? c #\!)))
(has-ssyntax-char? string (- i 1)))))
@@ -64,8 +86,16 @@
; because then _!foo becomes a function. Maybe use <>. For now
; leave this off and see how often it would have been useful.
+; Might want to make ~ have less precedence than +, because
+; ~foo+bar prob should mean (andf (complement foo) bar), not
+; (complement (andf foo bar)).
+
+(define (symstart? char sym) (eqv? char (car (symbol->chars sym))))
+
(define (expand-ssyntax sym)
- ((cond ((or (insym? #\: sym) (insym? #\~ sym)) expand-compose)
+ ;((cond ((or (insym? #\: sym) (insym? #\~ sym)) expand-compose)
+ ((cond ((or (insym? #\: sym) (symstart? #\~ sym)) expand-compose)
+ ((insym? #\+ sym) expand-and)
; ((insym? #\_ sym) expand-curry)
((or (insym? #\. sym) (insym? #\! sym)) expand-sexpr)
(#t (error "Unknown ssyntax" sym)))
@@ -87,6 +117,17 @@
(car elts)
(cons 'compose elts))))
+(define (expand-and sym)
+ (let ((elts (map chars->value
+ (tokens (lambda (c) (eqv? c #\+))
+ (symbol->chars sym)
+ '()
+ '()
+ #f))))
+ (if (null? (cdr elts))
+ (car elts)
+ (cons 'andf elts))))
+
; How to include quoted arguments? Can't treat all as quoted, because
; never want to quote fn given as first. Do we want to allow quote chars
; within symbols? Could be ugly.
@@ -175,15 +216,6 @@
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))))
@@ -513,6 +545,21 @@
((or (eq? x #f) (eq? x '())) 'nil)
(#t x)))
+; The next two are optimizations, except work for macros.
+
+(define (decompose fns args)
+ (cond ((null? fns) `((fn vals (car vals)) ,@args))
+ ((null? (cdr fns)) (cons (car fns) args))
+ (#t (list (car fns) (decompose (cdr fns) args)))))
+
+(define (ac-andf s env)
+ (ac (let ((gs (map (lambda (x) (ar-gensym)) (cdr s))))
+ `((fn ,gs
+ (and ,@(map (lambda (f) `(,f ,@gs))
+ (cdar s))))
+ ,@(cdr s)))
+ env))
+
(define err error)
; run-time primitive procedures
@@ -650,6 +697,10 @@
((null? (cdr args)) (ar-nil-terminate (car args)))
(#t (cons (car args) (ar-apply-args (cdr args))))))
+
+
+
+
(xdef cons cons)
(xdef car (lambda (x)
@@ -833,30 +884,24 @@
(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 readc (lambda str
+ (let ((c (read-char (if (pair? str)
+ (car str)
+ (current-input-port)))))
+ (if (eof-object? c) 'nil c))))
+
+
+(xdef readb (lambda str
+ (let ((c (read-byte (if (pair? str)
+ (car str)
+ (current-input-port)))))
+ (if (eof-object? c) 'nil c))))
+
+(xdef peekc (lambda str
+ (let ((c (peek-char (if (pair? str)
+ (car str)
+ (current-input-port)))))
+ (if (eof-object? c) 'nil c))))
(xdef writec (lambda (c . args)
(write-char c
@@ -904,41 +949,41 @@
(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))))
+ ((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))))
+ ((num) x)
+ ((char) (ascii->char x))
+ ((string) (apply number->string x args))
+ (else (err "Can't coerce" x type))))
((number? x) (case type
- ((int) (iround x))
- ((char) (ascii->char (iround x)))
- ((string) (apply number->string x args))
- (else (err "Can't coerce" x type))))
+ ((int) (iround x))
+ ((char) (ascii->char (iround x)))
+ ((string) (apply number->string x args))
+ (else (err "Can't coerce" x type))))
((string? x) (case type
- ((sym) (string->symbol x))
- ((cons) (ac-niltree (string->list x)))
- ((num) (or (apply string->number x args)
- (err "Can't coerce" x type)))
- ((int) (let ((n (apply string->number x args)))
- (if n
- (iround n)
- (err "Can't coerce" x type))))
- (else (err "Can't coerce" x type))))
+ ((sym) (string->symbol x))
+ ((cons) (ac-niltree (string->list x)))
+ ((num) (or (apply string->number x args)
+ (err "Can't coerce" x type)))
+ ((int) (let ((n (apply string->number x args)))
+ (if n
+ (iround n)
+ (err "Can't coerce" x type))))
+ (else (err "Can't coerce" x type))))
((pair? x) (case type
- ((string) (list->string
- (ar-nil-terminate x)))
- (else (err "Can't coerce" x 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))))
+ ((string) "")
+ (else (err "Can't coerce" x type))))
((symbol? x) (case type
- ((string) (symbol->string x))
- (else (err "Can't coerce" x type))))
+ ((string) (symbol->string x))
+ (else (err "Can't coerce" x type))))
(#t x))))
(xdef open-socket (lambda (num) (tcp-listen num 50 #t)))
@@ -964,6 +1009,7 @@
(xdef new-thread thread)
(xdef kill-thread kill-thread)
(xdef break-thread break-thread)
+(xdef current-thread current-thread)
(define (wrapnil f) (lambda args (apply f args) 'nil))
@@ -999,7 +1045,10 @@
; 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
+ (let ((h (make-hash-table 'equal)))
+ (if (pair? args) ((car args) h))
+ h)))
;(xdef table (lambda args
; (fill-table (make-hash-table 'equal)
@@ -1315,6 +1364,8 @@
(xdef declare (lambda (key val)
(case key
+ ((atstrings)
+ (set! atstrings (not (eq? val 'nil))))
((direct-calls)
(set! direct-calls (not (eq? val 'nil))))
((explicit-flush)
@@ -1339,5 +1390,43 @@
(xdef tan tan)
(xdef log log)
+(define (codestring s)
+ (let ((i (atpos s 0)))
+ (if i
+ (cons (substring s 0 i)
+ (let* ((rest (substring s (+ i 1)))
+ (in (open-input-string rest))
+ (expr (read in))
+ (i2 (let-values (((x y z) (port-next-location in))) z)))
+ (close-input-port in)
+ (cons expr (codestring (substring rest (- i2 1))))))
+ (list s))))
+
+; First unescaped @ in s, if any. Escape by doubling.
+
+(define (atpos s i)
+ (cond ((eqv? i (string-length s))
+ #f)
+ ((eqv? (string-ref s i) #\@)
+ (if (and (< (+ i 1) (string-length s))
+ (not (eqv? (string-ref s (+ i 1)) #\@)))
+ i
+ (atpos s (+ i 2))))
+ (#t
+ (atpos s (+ i 1)))))
+
+(define (unescape-ats s)
+ (list->string (letrec ((unesc (lambda (cs)
+ (cond
+ ((null? cs)
+ '())
+ ((and (eqv? (car cs) #\@)
+ (not (null? (cdr cs)))
+ (eqv? (cadr cs) #\@))
+ (unesc (cdr cs)))
+ (#t
+ (cons (car cs) (unesc (cdr cs))))))))
+ (unesc (string->list s)))))
+
)
View
@@ -228,7 +228,7 @@
(def username-taken (user)
(when (empty dc-usernames*)
- (ontable k v hpasswords*
+ (each (k v) hpasswords*
(set (dc-usernames* (downcase k)))))
(dc-usernames* (downcase user)))
@@ -549,10 +549,6 @@
(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))))))
Oops, something went wrong.

0 comments on commit 671231f

Please sign in to comment.