Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

- added tests to demonstrate non-strictness of destructured args

 - optimise: reduce ( (fn (x) x) (foo) ) to (foo)
 - switch initialisation of th1 and th2 in handle-request in srv.arc to avoid killing non-existent thread
  • Loading branch information...
commit ce01683dcd497ef42d27318a462f5ec7ccf93301 1 parent 25c88ed
conan authored
View
1  .gitignore
@@ -10,3 +10,4 @@ src/rainbow.zip
rainbow.iws
todo.txt
out
+src/arc/arc
View
6 src/arc/lib/tests/core-maths-test.arc
@@ -35,7 +35,11 @@
("concatenates strings"
(+ "foo" 'bar 21)
- "foobar21"))
+ "foobar21")
+
+ ("string concatenation ignores nil"
+ (+ "a" "b" "c" nil)
+ "abc"))
(suite "-"
("subtracts second arg from first"
View
16 src/arc/lib/tests/core-special-forms-test.arc
@@ -126,6 +126,10 @@
( (fn () "foobar") )
"foobar")
+ ("single rest arg"
+ ( (fn args cdr.args) 'a 'b 'c )
+ (b c))
+
("a simple addition function"
( (fn (x y) (+ x y)) 17 13)
30)
@@ -217,9 +221,21 @@
) (outstring))
"id=4 class=myclass ")
+ ("destructured args are implicitly optional"
+ ( (fn (a (b c d)) (+ a b c d)) "foo" '("bar") )
+ "foobar")
+
+ ("extra destructured args are ignored"
+ ( (fn (a (b c d)) (+ a b c d)) "foo" '("bar" "baz" "toto" "extra" "and some more") )
+ "foobarbaztoto")
+
("empty body returns nil"
((fn ()))
nil)
+
+ ("rainbow optimises inline idfn"
+ ( (fn (x) (if x x nil)) "en vacances au sud de france")
+ "en vacances au sud de france")
)
(suite "assign"
View
3  src/arc/rainbow/rainbow.arc
@@ -60,3 +60,6 @@
(def canonical-path (file)
((File new file) 'getCanonicalPath))
+(def at-stringify (str)
+
+)
View
79 src/arc/srv.arc
@@ -4,7 +4,7 @@
(= arcdir* "arc/" logdir* "arc/logs/" staticdir* "static/")
-(= quitsrv* nil breaksrv* nil)
+(= quitsrv* nil breaksrv* nil)
(def serve ((o port 8080))
(wipe quitsrv*)
@@ -37,7 +37,7 @@
; to handle it. also arrange to kill that thread if it
; has not completed in threadlife* seconds.
-(= threadlife* 30 requests* 0 requests/ip* (table)
+(= threadlife* 5 requests* 0 requests/ip* (table)
throttle-ips* (table) ignore-ips* (table) spurned* (table))
(def handle-request (s breaksrv)
@@ -53,24 +53,24 @@
(do (++ requests*)
(++ (requests/ip* ip 0))
(with (th1 nil th2 nil)
- (= th1 (thread
- (after (handle-request-thread i o ip)
- (close i o)
- (kill-thread th2))))
(= th2 (thread
(sleep threadlife*)
(unless (dead th1)
(prn "srv thread took too long for " ip))
(break-thread th1)
- (force-close i o))))))))
+ (force-close i o)))
+ (= th1 (thread
+ (after (handle-request-thread i o ip)
+ (close i o)
+ (kill-thread th2)))))))))
; Returns true if ip has made req-limit* requests in less than
-; req-window* seconds. If an ip is throttled, only 1 request is
-; allowed per req-window* seconds. If an ip makes req-limit*
+; req-window* seconds. If an ip is throttled, only 1 request is
+; allowed per req-window* seconds. If an ip makes req-limit*
; requests in less than dos-window* seconds, it is a treated as a DoS
; attack and put in ignore-ips* (for this server invocation).
-; To adjust this while running, adjust the req-window* time, not
+; To adjust this while running, adjust the req-window* time, not
; req-limit*, because algorithm doesn't enforce decreases in the latter.
(= req-times* (table) req-limit* 30 req-window* 10 dos-window* 2)
@@ -79,7 +79,7 @@
(and (only.> (requests/ip* ip) 250)
(let now (seconds)
(do1 (if (req-times* ip)
- (and (>= (qlen (req-times* ip))
+ (and (>= (qlen (req-times* ip))
(if (throttle-ips* ip) 1 req-limit*))
(let dt (- now (deq (req-times* ip)))
(if (< dt dos-window*) (set (ignore-ips* ip)))
@@ -94,7 +94,7 @@
(whilet c (unless responded (readc i))
(if srv-noisy* (pr c))
(if (is c #\newline)
- (if (is (++ nls) 2)
+ (if (is (++ nls) 2)
(let (type op args n cooks) (parseheader (rev lines))
(let t1 (msec)
(case type
@@ -113,9 +113,9 @@
(def log-request (type op args cooks ip t0 t1)
(with (parsetime (- t1 t0) respondtime (- (msec) t1))
- (srvlog 'srv ip
- parsetime
- respondtime
+ (srvlog 'srv ip
+ parsetime
+ respondtime
(if (> (+ parsetime respondtime) 1000) "***" "")
type
op
@@ -134,7 +134,7 @@
(whilet c (and (> n 0) (readc i))
(if srv-noisy* (pr c))
(-- n)
- (push c line))
+ (push c line))
(if srv-noisy* (pr "\n\n"))
(respond o op (+ (parseargs (string (rev line))) args) cooks ip))))
@@ -168,13 +168,13 @@ Connection: close"))
(unless (optimes* name) (= (optimes* name) (queue)))
(enq-limit elapsed (optimes* name) 1000))
-; For ops that want to add their own headers. They must thus remember
+; For ops that want to add their own headers. They must thus remember
; to prn a blank line before anything meant to be part of the page.
(mac defop-raw (name parms . body)
(w/uniq t1
- `(= (srvops* ',name)
- (fn ,parms
+ `(= (srvops* ',name)
+ (fn ,parms
(let ,t1 (msec)
(do1 (do ,@body)
(save-optime ',name (- (msec) ,t1))))))))
@@ -186,7 +186,7 @@ Connection: close"))
(mac defop (name parm . body)
(w/uniq gs
`(do (wipe (redirector* ',name))
- (defop-raw ,name (,gs ,parm)
+ (defop-raw ,name (,gs ,parm)
(w/stdout ,gs (prn) ,@body)))))
; Defines op as a redirector. Its retval is new location.
@@ -207,6 +207,10 @@ Connection: close"))
(= unknown-msg* "Unknown." max-age* (table) static-max-age* nil)
(def respond (str op args cooks ip)
+ (on-err (fn (ex) (w/stdout (stderr) (prn "error for request " op " with args " args " : " (details ex))))
+ (fn () (respond-unsafe str op args cooks ip))))
+
+(def respond-unsafe (str op args cooks ip)
(w/stdout str
(iflet f (srvops* op)
(let req (inst 'request 'args args 'cooks cooks 'ip ip)
@@ -237,7 +241,8 @@ Connection: close"))
"jpg" 'jpg
"jpeg" 'jpg
"png" 'png
- "css" 'text/html
+ "js" 'javascript
+ "css" 'css
"txt" 'text/html
"htm" 'text/html
"html" 'text/html
@@ -283,7 +288,7 @@ Connection: close"))
(map [tokens _ #\=] (tokens s #\&))))
(def parsecookies (s)
- (map [tokens _ #\=]
+ (map [tokens _ #\=]
(cdr (tokens s [or (whitec _) (is _ #\;)]))))
(def arg (req key) (alref req!args key))
@@ -332,31 +337,31 @@ Connection: close"))
; (tag (a href (url-for (afnid (fn (req) (prn) (pr "my fnid is " it)))))
; (pr "click here")))
-; To be more sophisticated, instead of killing fnids, could first
-; replace them with fns that tell the server it's harvesting too
-; aggressively if they start to get called. But the right thing to
-; do is estimate what the max no of fnids can be and set the harvest
+; To be more sophisticated, instead of killing fnids, could first
+; replace them with fns that tell the server it's harvesting too
+; aggressively if they start to get called. But the right thing to
+; do is estimate what the max no of fnids can be and set the harvest
; limit there-- beyond that the only solution is to buy more memory.
(def harvest-fnids ((o n 50000)) ; was 20000
- (when (len> fns* n)
+ (when (len> fns* n)
(pull (fn ((id created lasts))
- (when (> (since created) lasts)
+ (when (> (since created) lasts)
(wipe (fns* id))
t))
timed-fnids*)
(atlet nharvest (trunc (/ n 10))
(let (kill keep) (split (rev fnids*) nharvest)
- (= fnids* (rev keep))
- (each id kill
+ (= fnids* (rev keep))
+ (each id kill
(wipe (fns* id)))))))
(= fnurl* "/x" rfnurl* "/r" rfnurl2* "/y" jfnurl* "/a")
(= dead-msg* "\nUnknown or expired link.")
-
+
(defop-raw x (str req)
- (w/stdout str
+ (w/stdout str
(aif (fns* (sym (arg req "fnid")))
(it req)
(pr dead-msg*))))
@@ -389,7 +394,7 @@ Connection: close"))
(def rflink (f)
(string rfnurl* "?fnid=" (fnid f)))
-
+
; Since it's just an expr, gensym a parm for (ignored) args.
(mac w/link (expr . body)
@@ -446,7 +451,7 @@ Connection: close"))
;(defop test1 req
; (fnform (fn (req) (prn) (pr req))
; (fn () (single-input "" 'foo 20 "submit"))))
-
+
;(defop test2 req
; (aform (fn (req) (pr req))
; (single-input "" 'foo 20 "submit")))
@@ -519,7 +524,7 @@ Connection: close"))
(when (admin (get-user req))
(whitepage
(sptab
- (each ip (let leaders nil
+ (each ip (let leaders nil
(maptable (fn (ip n)
(when (> n 100)
(insort (compare > requests/ip*)
@@ -553,7 +558,7 @@ Connection: close"))
(def new-bgthread (id f sec)
(aif (bgthreads* id) (break-thread it))
- (= (bgthreads* id) (new-thread (fn ()
+ (= (bgthreads* id) (new-thread (fn ()
(while t
(sleep sec)
(f))))))
@@ -562,7 +567,7 @@ Connection: close"))
(mac defbg (id sec . body)
`(do (pull [caris _ ',id] pending-bgthreads*)
- (push (list ',id (fn () ,@body) ,sec)
+ (push (list ',id (fn () ,@body) ,sec)
pending-bgthreads*)))
View
2  src/java/rainbow/Console.java
@@ -162,7 +162,7 @@ private static void load(VM vm, String name, InputStream stream) throws ParseExc
}
private static ArcObject compileAndEval(VM vm, ArcObject expression) {
- expression = rainbow.vm.compiler.Compiler.compile(vm, expression, new Map[0]);
+ expression = rainbow.vm.compiler.Compiler.compile(vm, expression, new Map[0]).reduce();
List i = new ArrayList();
expression.addInstructions(i);
return vm.thread(null, Pair.buildFrom(i));
View
4 src/java/rainbow/Nil.java
@@ -111,4 +111,8 @@ public boolean isSame(ArcObject other) {
public ArcObject or(ArcObject other) {
return other;
}
+
+ public boolean hasLen(int i) {
+ return i == 0;
+ }
}
View
2  src/java/rainbow/functions/eval/Eval.java
@@ -16,7 +16,7 @@ public Eval() {
public void invoke(VM vm, Pair args) {
ArcObject expression = args.car();
- expression = rainbow.vm.compiler.Compiler.compile(vm, expression, new Map[0]);
+ expression = rainbow.vm.compiler.Compiler.compile(vm, expression, new Map[0]).reduce();
List i = new ArrayList();
expression.addInstructions(i);
vm.pushFrame(null, Pair.buildFrom(i));
View
19 src/java/rainbow/functions/interpreted/InterpretedFunction.java
@@ -5,13 +5,13 @@
import rainbow.Nil;
import rainbow.functions.Builtin;
import rainbow.types.ArcObject;
-import rainbow.types.ArcString;
import rainbow.types.Pair;
import rainbow.types.Symbol;
import rainbow.vm.VM;
import rainbow.vm.instructions.Close;
import rainbow.vm.instructions.Literal;
import rainbow.vm.instructions.PopArg;
+import rainbow.vm.interpreter.BoundSymbol;
import java.util.*;
@@ -63,6 +63,23 @@ public void addInstructions(List i) {
i.add(new Close(this));
}
+ public boolean isIdFn() {
+ if (parameterList.len() == 1) {
+ if (parameterList.car() instanceof Symbol) {
+ if (body.length == 1) {
+ if (body[0] instanceof BoundSymbol) {
+ Symbol p1 = (Symbol) parameterList.car();
+ BoundSymbol rv = (BoundSymbol) body[0];
+ BoundSymbol equiv = new BoundSymbol(p1, 0, 0);
+ return rv.isSameBoundSymbol(equiv);
+ }
+ }
+
+ }
+ }
+ return false;
+ }
+
public int compareTo(ArcObject right) {
throw new ArcError("Can't compare " + this + " to " + right);
}
View
8 src/java/rainbow/types/ArcObject.java
@@ -127,6 +127,14 @@ public ArcObject invokeAndWait(VM vm, Pair args) {
return vm.thread();
}
+ public ArcObject reduce() {
+ return this;
+ }
+
+ public boolean hasLen(int i) {
+ throw new ArcError("has length: not a proper list: ends with " + this);
+ }
+
public static class NotNil extends Throwable {
}
}
View
4 src/java/rainbow/types/Pair.java
@@ -274,6 +274,10 @@ private static ArcObject nth(ArcObject p, long index) {
return p;
}
+ public boolean hasLen(int i) {
+ return cdr().hasLen(i - 1);
+ }
+
static class OOB extends RuntimeException {
}
View
2  src/java/rainbow/vm/VM.java
@@ -89,7 +89,7 @@ private void step() {
} catch (ArcError e) {
throw e;
} catch (Exception e) {
- String msg = "failed to execute instruction " + i +
+ String msg = "failed to execute instruction " + i.toString(currentLc) +
"\nremaining instructions in this frame: " + rest +
"\nlast arg: " + (ap > -1 ? peekA() : null) +
"\nLC: " + currentLc +
View
4 src/java/rainbow/vm/compiler/IfBuilder.java
@@ -33,11 +33,11 @@ public static ArcObject build(VM vm, ArcObject body, Map[] lexicalBindings) {
} catch (NotPair notPair) {
throw new ArcError("if: unexpected: " + body);
}
- ArcObject expr = compile(vm, body.car(), lexicalBindings);
+ ArcObject expr = compile(vm, body.car(), lexicalBindings).reduce();
clause.take(expr);
body = body.cdr();
}
- return clause;
+ return clause.reduce();
}
}
View
4 src/java/rainbow/vm/compiler/PairExpander.java
@@ -16,9 +16,9 @@ public static Pair expand(VM vm, ArcObject body, Map[] lexicalBindings) {
while (!(body instanceof Nil) && body instanceof Pair) {
ArcObject next = body.car();
body = body.cdr();
- result.add(Compiler.compile(vm, next, lexicalBindings));
+ result.add(Compiler.compile(vm, next, lexicalBindings).reduce());
}
- return Pair.buildFrom(result, Compiler.compile(vm, body, lexicalBindings));
+ return Pair.buildFrom(result, Compiler.compile(vm, body, lexicalBindings).reduce());
}
}
View
10 src/java/rainbow/vm/interpreter/IfClause.java
@@ -21,12 +21,20 @@ public void add(Conditional c) {
}
}
+ public ArcObject reduce() {
+ first = first.reduce();
+ if (first instanceof Else) {
+ return ((Else)first).ifExpression;
+ } else {
+ return this;
+ }
+ }
+
public void take(ArcObject expression) {
first.take(expression);
}
public void addInstructions(List i) {
- first = first.reduce();
first.addInstructions(i);
}
View
12 src/java/rainbow/vm/interpreter/Invocation.java
@@ -35,6 +35,18 @@ public void addInstructions(List i) {
boolean v = inlineDoForm(i) || addOptimisedHandler(i) || defaultAddInstructions(i);
}
+ // reduce ( (fn (x) x) y) to just y
+ public ArcObject reduce() {
+ if (parts.hasLen(2)) {
+ if (parts.car() instanceof InterpretedFunction) {
+ if (((InterpretedFunction) parts.car()).isIdFn()) {
+ return parts.cdr().car();
+ }
+ }
+ }
+ return this;
+ }
+
private boolean inlineDoForm(List i) {
if (parts.len() == 1L && parts.car() instanceof Bind) {
((InterpretedFunction) parts.car()).instructions().copyTo(i);
Please sign in to comment.
Something went wrong with that request. Please try again.