From 529fd1278b7e5cff893753ca7d4a6b5415ab3a3b Mon Sep 17 00:00:00 2001 From: "Kartik K. Agaram" Date: Fri, 17 Feb 2012 00:24:37 -0800 Subject: [PATCH] 1559 - tests now pass; mfn is indeed redundant --- 030.wart | 75 ++++++++++++++-- 031test.test | 5 ++ 032check.test | 206 ++++++++++++++++++++++++++++++++++++++++++++ 032check.wart | 51 +++++++++++ 033type.wart | 73 ++++++++++++++++ 034bind.test | 7 ++ 034bind.wart | 40 +++++++++ 035generic.test | 12 +++ 035generic.wart | 24 ++++++ 036control.test | 13 +++ 036control.wart | 100 +++++++++++++++++++++ 037assign.wart | 32 +++++++ 038list.test | 124 ++++++++++++++++++++++++++ 038list.wart | 128 +++++++++++++++++++++++++++ 039mutate.test | 38 ++++++++ 039mutate.wart | 36 ++++++++ 040num.test | 59 +++++++++++++ 040num.wart | 55 ++++++++++++ 041string.test | 76 ++++++++++++++++ 041string.wart | 41 +++++++++ 042table.test | 40 +++++++++ 042table.wart | 37 ++++++++ 043queue.test | 22 +++++ 043queue.wart | 20 +++++ 044collect.test | 3 + 044collect.wart | 6 ++ 045stream.test | 24 ++++++ 045stream.wart | 24 ++++++ 046sym.test | 23 +++++ 046sym.wart | 15 ++++ 047fork.wart | 14 +++ 048patmatch.test | 19 ++++ 048patmatch.wart | 17 ++++ 050http-server.wart | 26 ++++++ ugliness | 1 - 35 files changed, 1480 insertions(+), 6 deletions(-) create mode 100644 031test.test create mode 100644 032check.test create mode 100644 032check.wart create mode 100644 033type.wart create mode 100644 034bind.test create mode 100644 034bind.wart create mode 100644 035generic.test create mode 100644 035generic.wart create mode 100644 036control.test create mode 100644 036control.wart create mode 100644 037assign.wart create mode 100644 038list.test create mode 100644 038list.wart create mode 100644 039mutate.test create mode 100644 039mutate.wart create mode 100644 040num.test create mode 100644 040num.wart create mode 100644 041string.test create mode 100644 041string.wart create mode 100644 042table.test create mode 100644 042table.wart create mode 100644 043queue.test create mode 100644 043queue.wart create mode 100644 044collect.test create mode 100644 044collect.wart create mode 100644 045stream.test create mode 100644 045stream.wart create mode 100644 046sym.test create mode 100644 046sym.wart create mode 100644 047fork.wart create mode 100644 048patmatch.test create mode 100644 048patmatch.wart create mode 100644 050http-server.wart diff --git a/030.wart b/030.wart index c8654440..a4ebca4c 100644 --- a/030.wart +++ b/030.wart @@ -1,5 +1,70 @@ -= foo (fn'(y) (eval `(if 3 ,y))) -= bar (fn(x) (foo pr.x)) -debug.1 -bar 111 -quit. += mac! (fn '(name params . body) + (eval `(= ,name (fn ',params + (eval ((fn() ,@body))))))) + +mac! def!(name params . body) + `(= ,name (fn ,params ,@body)) + +mac! do body + `((fn() ,@body)) + +def! prn args + (if args + (do + pr car.args + prn @cdr.args + car.args) + (pr " +")) + +mac! def(name params . body) + if bound?.name + (prn "redef: " name) + `(def! ,name ,params ,@body) + +mac! mac(name params . body) + if bound?.name + (prn "redef: " name) + `(mac! ,name ,params ,@body) + +mac alias(new old) ; include later refinements + `(mac ,new $args + `(,,old ,@$args)) + +def compose(f g) + fn 'args + eval `(,f (,g ,@args)) + +def complement(f) + (compose not f) + +mac let(var val . body) + `((fn(,var) ,@body) ,val) + +def list args + if args + (cons car.args + (list @cdr.args)) + +let $iso iso ; ignore later refinements + def isa(x t) + ($iso t type.x) + += cadr car:cdr += cddr cdr:cdr + +def id(_) + _ + += quote (car:car (cons ' 'a)) +def quote?(_) (iso _ quote) += backquote (car '`(1)) +def backquote?(_) (iso _ backquote) += unquote (car:cadr '`(,1)) +def unquote?(_) (iso _ unquote) += unquote-splice (car:cadr '`(,@1)) +def unquote-splice?(_) (iso _ unquote-splice) + +def die args + prn @args + quit. diff --git a/031test.test b/031test.test new file mode 100644 index 00000000..310db0f1 --- /dev/null +++ b/031test.test @@ -0,0 +1,5 @@ +(test "test using keyword args" + :valueof (+ 1 1) + :should be 2) + +(test "test using positional args" iso (+ 1 1) 2) diff --git a/032check.test b/032check.test new file mode 100644 index 00000000..90b3e5c0 --- /dev/null +++ b/032check.test @@ -0,0 +1,206 @@ +(test "if handles 0 args" + :valueof (if) + :should be nil) + +(test "if handles 1 arg" + :valueof if.3 + :should be 3) + +(test "if handles 2 args" + :valueof (if 3 4) + :should be 4) + +(test "if handles then branch" + :valueof (if 3 4 5) + :should be 4) + +(test "if handles else branch" + :valueof (if nil 4 5) + :should be 5) + +(test "if handles 3 args" + :valueof (if nil 4 5) + :should be 5) + +(test "if handles 4 args" + :valueof (if nil 4 5 6) + :should be 6) + +(test "if handles 5 args" + :valueof (if nil 4 nil 6 7) + :should be 7) + +(test "if handles :else" + :valueof (if nil 4 :else 6) + :should be 6) + +(test "if handles lexical scope" + :valueof (let x 34 (if x)) + :should be 34) + +(test "if handles dynamic scope" + :valueof (do (= x 34) + (if x 35)) + :should be 35) + + + +(test "or handles 0 args" + :valueof or. + :should be nil) + +(test "or handles nil arg" + :valueof or.nil + :should be nil) + +(test "or handles non-nil arg" + :valueof or.3 + :should be 3) + +(test "or handles 2 args" + :valueof (or nil 3) + :should be 3) + +(test "or handles multiple non-nil args" + :valueof (or 3 4) + :should be 3) + +(test "or short-circuits on first non-nil arg" + :valueof (let x nil + (or 3 (= x 4)) + x) + :should be nil) + +(test "or evals each arg at most once" + :valueof (let x 0 + (or (do (= x (+ x 1)) + 3) + (do (= x (+ x 1)) + 4)) + x) + :should be 1) + +(test "or handles lexical scope" + :valueof (do (= x 35) + (let x 3 + (or nil x))) + :should be 3) + + + +(test "and handles 0 args" + :valueof and. + :should ~be nil) + +(test "and handles nil arg" + :valueof and.nil + :should be nil) + +(test "and handles non-nil arg" + :valueof and.3 + :should be 3) + +(test "and handles 2 args" + :valueof (and nil 3) + :should be nil) + +(test "and handles 2 non-nil args" + :valueof (and 3 4) + :should be 4) + +(test "and handles lexical scope" + :valueof ((fn(x) (and 3 x 4)) nil) + :should be nil) + +(test "and short-circuits" + :valueof (let x 0 + (and (= x 3) + nil + (= x 4)) + x) + :should be 3) + +(test "and handles dynamic scope" + :valueof (do (= x 35) + (and x 36)) + :should be 36) + + + +(test "iso handles nils" + :valueof (iso nil 3) + :should be nil) + +(test "iso compares nils" + :valueof (iso nil nil) + :should ~be nil) + +(test "iso handles ints" + :valueof (iso 3 4) + :should be nil) + +(test "iso handles ints - 2" + :valueof (iso 3 3) + :should ~be nil) + +(test "iso handles strings" + :valueof (iso "a" "b") + :should be nil) + +(test "iso handles strings - 2" + :valueof (iso "a" "a") + :should ~be nil) + +(test "iso handles lists" + :valueof (iso list.1 list.2) + :should be nil) + +(test "iso handles lists - 2" + :valueof (iso list.1 list.1) + :should ~be nil) + +(test "iso handles user-defined types" + :valueof (iso '(type foo 3) '(type foo 3)) + :should ~be nil) + + + +(test "match - atom positive" + :valueof (match 3 3) + :should ~be nil) + +(test "match - atom negative" + :valueof (match 3 4) + :should be nil) + +(test "match - list positive" + :valueof (match '(1 (2 3)) '(1 (2 3))) + :should ~be nil) + +(test "match - list negative" + :valueof (match '(2 (2 3)) '(1 (2 3))) + :should be nil) + +(test "match treats _ as atom wildcard" + :valueof (match '_ 3) + :should ~be nil) + +(test "match - _ positive" + :valueof (match '(1 (_ 3 4)) '(1 (2 3 4))) + :should ~be nil) + +(test "match - _ negative" + :valueof (match '(2 (_ 3 4)) '(1 (2 3 4))) + :should be nil) + +(test "match - _ matches lists" + :valueof (match '_ '(3)) + :should ~be nil) + +(test "match - _ matches lists when dotted" + :valueof (match '(1 . _) '(1 2 3)) + :should ~be nil) + +(test "match treats any sym beginning with _ as wildcard" + :valueof (match '(1 . _x) '(1 2 3)) + :should ~be nil) diff --git a/032check.wart b/032check.wart new file mode 100644 index 00000000..4b7b19ee --- /dev/null +++ b/032check.wart @@ -0,0 +1,51 @@ += compiled-if if +let $if if + mac! if args + $if !cdr.args + car.args + `(,$if ,car.args + ,cadr.args + (if ,@cddr.args)) + +mac or args + if args + `(let $x ,car.args + if $x + $x + or ,@cdr.args) + +mac and args + if !args + 1 + if !cdr.args + car.args + `(if ,car.args + and ,@cdr.args) + +alias nil? not +alias no not + +def match(a b) + (or (iso a b) + (iso str.a.0 "_") + (and cons?.a cons?.b + (match car.a car.b) + (match cdr.a cdr.b))) + +let $iso iso + def! iso(a b) + or ($iso a b) + and (cons? a) + (cons? b) + (iso car.a car.b) + (iso cdr.a cdr.b) + +def only(f) + (fn args + (if f (f @args))) + +mac check(x test else) + `(let $x ,x + if (,test $x) + $x + ,else) diff --git a/033type.wart b/033type.wart new file mode 100644 index 00000000..8b7507a6 --- /dev/null +++ b/033type.wart @@ -0,0 +1,73 @@ +def sym?(_) + (isa _ 'symbol) +def list?(_) + (isa _ 'list) +def num?(_) + (isa _ 'number) +def string?(_) + (isa _ 'string) +def table?(_) + (isa _ 'table) +def fn?(_) + (isa _ 'function) +def mac?(_) + (isa _ 'macro) +def callable?(_) + (or fn?._ mac?._) +def compiled-fn?(_) + (and (fn? _) + (~cons? rep._!body)) + + + +def tag(type val) + (list 'object type val) + +def rep(x) + if (or ~cons?.x (~iso 'object car.x)) + x + car:cddr.x + +def coerce(x dest-type) + eval `(coerce-quoted ,x ,dest-type) += coercions* (table) + +mac defcoerce(src dest f) + `(do + if (~table_get coercions* ',dest) + (table_set coercions* ',dest (table)) + (table_set (table_get coercions* ',dest) ',src ,f)) + +defcoerce nil list + id + +; arbitrary types in function position +mac defcall(type params . body) + `(defcoerce ,type function + (fn(,car.params) + (fn ,cdr.params + ,@body))) + + + +mac as(type expr) + `(coerce ,expr ',type) + +defcoerce function macro + id + +defcoerce macro function + id + +def! compose(f g) + fn 'args + eval `(,(as function f) (,(as function g) ,@args)) + +def sig(f) + rep.f!sig + +def! body(f) + rep.f!body + +def env(f) + rep.f!env diff --git a/034bind.test b/034bind.test new file mode 100644 index 00000000..8619dd72 --- /dev/null +++ b/034bind.test @@ -0,0 +1,7 @@ +(test "pair works" + :valueof (pair '(1 2 3 4 5)) + :should be '((1 2) (3 4) (5))) + +(test "withs works" + :valueof (withs (x 3 y '(1 2 3)) (list x @y)) + :should be '(3 1 2 3)) diff --git a/034bind.wart b/034bind.wart new file mode 100644 index 00000000..1d04765d --- /dev/null +++ b/034bind.wart @@ -0,0 +1,40 @@ +def pair(l) + (if + !l + nil + !cdr.l + (list:list car.l) + :else + (cons (list car.l cadr.l) + (pair cddr.l))) + +mac with(params . body) + `((fn ,(map car pair.params) + ,@body) + ,@(map cadr pair.params)) + +mac withs(params . body) + if !params + `(do ,@body) + `(let ,car.params ,cadr.params + (withs ,cddr.params ,@body)) + + + +mac proc(name params . body) + `(def ,name ,params + ,@body + nil) + +mac ret(var val . body) + `(let ,var ,val + ,@body + ,var) + +mac rfn(name params . body) + `(ret ,name nil + (= ,name (fn ,params + ,@body))) + +mac afn(params . body) + `(rfn self ,params ,@body) diff --git a/035generic.test b/035generic.test new file mode 100644 index 00000000..c0718e50 --- /dev/null +++ b/035generic.test @@ -0,0 +1,12 @@ +def foogen args + args +def foogen(s . rest) :case (and !rest sym?.s) + s + +(test "def :case can handle rest params" + :valueof foogen.3 + :should be '(3)) + +(test "def :case can handle rest params - 2" + :valueof foogen!a + :should be 'a) diff --git a/035generic.wart b/035generic.wart new file mode 100644 index 00000000..dc6e80d1 --- /dev/null +++ b/035generic.wart @@ -0,0 +1,24 @@ +; given params, return code to construct the args +; (mac arg1 arg2 . body) => `(,mac ,arg1 ,arg2 ,@body) +def construct-macro-call(args) + if list?.args + `(cons ,car.args ,(construct-macro-call cdr.args)) + args + +let $mac mac + mac! mac(name params . body) + if (~iso :case car.body) + `(,$mac ,name ,params ,@body) + `(let $super ,name + (mac! ,name ,params + if ,cadr.body + (do ,@cddr.body) + ,(construct-macro-call (cons '$super params)))) ; call super with params + +mac def(name params . body) :case (iso :case car.body) + `(let $old ,name + (def! ,name $params + let ,params $params + if ,cadr.body + (do ,@body) + ($old @$params))) diff --git a/036control.test b/036control.test new file mode 100644 index 00000000..ddee7136 --- /dev/null +++ b/036control.test @@ -0,0 +1,13 @@ +(test "while works" + :valueof (ret ans 0 + (let x 3 + (while (> x 0) + ++.ans + --.x))) + :should be 3) + +(test "for works" + :valueof (ret ans 0 + (for x 0 (< x 3) ++.x + ++.ans)) + :should be 3) diff --git a/036control.wart b/036control.wart new file mode 100644 index 00000000..e59fc2cb --- /dev/null +++ b/036control.wart @@ -0,0 +1,100 @@ +mac do1 body + `(ret $ret ,car.body + ,@cdr.body) + +mac between(before after/and . body) + `(do1 + (do ,before ,@body) + ,after) + +mac before(cleanup . body) + `(do1 + (do ,@body) + ,cleanup) + +mac when(cond . body) + `(if ,cond + (do ,@body)) + +mac unless(cond . body) + `(if !,cond + (do ,@body)) + +mac iflet(var expr . branches) + if !branches + expr + `(let $tmp ,expr + if $tmp + (let ,var $tmp + ,car.branches) + ,(if cdr.branches + `(iflet ,var ,@cdr.branches))) + +mac aif(expr . branches) + `(iflet it ,expr ,@branches) + +mac whenlet(var test . body) + `(iflet ,var ,test + (do ,@body)) + +mac awhen(test . body) + `(whenlet it ,test + ,@body) + + + +mac while(test . body) + `(when ,test + ,@body + while ,test + ,@body) + +mac whilet(var test . body) + `(let ,var nil + while (= ,var ,test) + ,@body) + +mac awhile(test . body) + `(whilet it ,test + ,@body) + +mac for(var start test update . body) + `(let ,var ,start + while ,test + ,@body + ,update) + +mac each(var expr . body) + `(for $i (as list ,expr) $i (zap cdr $i) + let ,var car.$i + ,@body) + +mac on(var expr . body) + `(for ($i index) (list ,expr 0) $i (do (zap cdr $i) ++.index) + let ,var car.$i + ,@body) + +mac forlen(var expr . body) + `(for ,var 0 (< ,var len.,expr) ++.,var + ,@body) + +mac repeat(n . body) + `(for $i 0 (< $i ,n) ++.$i + ,@body) + +mac repeat(n . body) :case (iso n :forever) + `(while 1 ,@body) + + + +def andf fs + (fn args + (let sub (afn(fs) + (if + !fs + 1 + ~cdr.fs + (car.fs @args) + :else + (and (car.fs @args) (self cdr.fs)))) + (sub fs))) diff --git a/037assign.wart b/037assign.wart new file mode 100644 index 00000000..ecbd9bdb --- /dev/null +++ b/037assign.wart @@ -0,0 +1,32 @@ +; basic type-based dispatch +mac =(lhs rhs) :case list?.lhs + ; multiple-eval in case car.lhs needs assigning to + `((table_get (table_get coercions* 'function=) (type ,car.lhs)) ,lhs ,rhs) + +; support new types in = +; body must return a form that will be macro-eval'd +mac defset(type params . body) + `(defcoerce ,type function= + (fn ',params + eval (do ,@body))) + + + +; keyword-based dispatch +mac =(lhs rhs) :case (and list?.lhs (table_get coercions* car.lhs)) + `((table_get coercions* ',car.lhs) ,@cdr.lhs ,rhs) + +; support new keywords in = +mac def=(op params . body) + `(table_set coercions* ',op (fn ,params ,@body)) + + + +; serial assignment +; this should be after clauses inspecting args +let $= = + mac! = args + if args + `(ret $ans ,cadr.args + (,$= ,car.args $ans) + (= ,@cddr.args)) diff --git a/038list.test b/038list.test new file mode 100644 index 00000000..1463613a --- /dev/null +++ b/038list.test @@ -0,0 +1,124 @@ +(test "len works on lists" + :valueof (len '(1 2 3 4 5)) + :should be 5) + +(test "lists coerce to function" + :valueof (type:coerce '(1 2 3) 'function) + :should be 'function) + +(test "lists work in function position" + :valueof ((list 1 2 3) 1) + :should be 2) + +(test "lists work in function position - 2" + :valueof (let l '(list 1 2 3) l.3) + :should be 3) + +(test "compose works with lists" + :valueof (let l '(1 (34 3) 2) (car:l 1)) + :should be 34) + +(test "lists can take negative indices" + :valueof (let l '(1 2 3) l.-1) + :should be 3) + +(test "lists can take slices" + :valueof (let l '(1 2 3 4 5 6) (l 3 5)) + :should be '(4 5)) + +(test "lists can take slices - 2" + :valueof (let l '(1 2 3 4 5 6) (l 3 -1)) + :should be '(4 5)) + +(test "lists can take slices - explicit nil" + :valueof (let l '(1 2 3 4 5 6) (l 3 nil)) + :should be '(4 5 6)) + +(test "lists can be assigned to" + :valueof (ret l '(1 2 3) + (= l.1 4)) + :should be '(1 4 3)) + +(test "list slices can be assigned to" + :valueof (ret l '(1 2 3 4 5 6 7) + (= (l 1 3) '(16 17 18))) + :should be '(1 16 17 18 4 5 6 7)) + +(test "list slices can be assigned to - 2" + :valueof (ret l '(1 2 3 4 5 6 7) + (= (l -4 -1) '(29 37))) + :should be '(1 2 3 29 37 7)) + +(test "list slices can be assigned to - explicit nil" + :valueof (ret l '(1 2 3 4 5 6 7) + (= (l -4 nil) '(29 37))) + :should be '(1 2 3 29 37)) + +(test "list slices can be assigned to - explicit nil var" + :valueof (ret l '(1 2 3 4 5 6 7) + (let x nil + (= (l -4 x) '(29 37)))) + :should be '(1 2 3 29 37)) + +(test "list index can be reset" + :valueof (ret l '(1 2 3) + (= l.1 nil)) + :should be '(1 nil 3)) + +(test "list slices can be deleted" + :valueof (ret l '(1 2 3 4 5 6 7) + (= (l 1 5) nil)) + :should be '(1 6 7)) + +(test "list slices can be deleted - 2" + :valueof (ret l '(1 2 3 4 5 6 7) + (= (l -4 -1) nil)) + :should be '(1 2 3 7)) + +(test "list slice assignment can delete at start of list (by rebinding the var)" + :valueof (ret l '(1 2 3 4) + (= (l 0 2) nil)) + :should be '(3 4)) + +(test "nested lists can be assigned to" + :valueof (ret l '(1 (2 3)) + (= ((l 1) 0) 3)) + :should be '(1 (3 3))) + +(test "elems of other types can be assigned to" + :valueof (let l (tag 'footype '(1 2 3)) + (= rep.l.0 3) + rep.l) + :should be '(3 2 3)) + +(test "join works" + :valueof (join '(1 2 3) nil '(4 5) nil nil '(6 (7 8))) + :should be '(1 2 3 4 5 6 (7 8))) + +(test "rem works" + :valueof (rem no '(1 2 nil 4 nil)) + :should be '(1 2 4)) + +(test "keep works" + :valueof (keep odd? '(11 12 13)) + :should be '(11 13)) + +(test "all works with lists" + :valueof (all cons? '((1) 2)) + :should be nil) + +(test "none works" + :valueof (none odd? '(1 2 3)) + :should be nil) + +(test "none works - 2" + :valueof (none odd? '(2 4 6)) + :should ~be nil) + +(test "flatten works" + :valueof (flatten '(a b (c d e))) + :should be '(a b c d e)) + +(test "flatten works - 2" + :valueof (flatten '(a b (c d e) . f)) + :should be '(a b c d e f)) diff --git a/038list.wart b/038list.wart new file mode 100644 index 00000000..a2267c1c --- /dev/null +++ b/038list.wart @@ -0,0 +1,128 @@ +defcall list(l idx . ends) + withs (idx (range-start l idx) + end (if + !ends + (+ idx 1) + !car.ends + len.l + :else + (range-bounce l car.ends))) + ((if ends list_range car:list_range) l idx end) + +defset list((l idx . ends) val) + `(withs ($idx (range-start ,l ,idx) + $end ,(if !ends + `(+ $idx 1) + `(if !,car.ends + len.,l + (range-bounce ,l ,car.ends))) + $val ,(if ends val `(list ,val))) + (list_splice ,l $idx $end $val)) + +def= car(l x) + (set_car l x) + +def= cdr(l x) + (set_cdr l x) + +def empty?(l) + nil?.l + +def blank?(l) + (or nil?.l empty?.l) + +def copy(x) + if cons?.x + (cons copy:car.x copy:cdr.x) + x + +def single?(x) + (and cons?.x !cdr.x) + +def join args + if args + if car.args + (cons car:car.args + (join cdr:car.args @cdr.args)) + (join @cdr.args) + +def rem(f seq) + if seq + if (f car.seq) + (rem f cdr.seq) + (cons car.seq (rem f cdr.seq)) + +def keep(f seq) + (rem ~f seq) + +def map(f xs) + if xs + (cons (f car.xs) + (map f cdr.xs)) + +def reduce(f xs) + if cddr.xs + (reduce f (cons (f car.xs cadr.xs) + cddr.xs)) + (f @xs) + +def all(f xs) + (if + !xs + 1 + (f car.xs) + (all f cdr.xs)) + +def some(f xs) + if xs + if (f car.xs) + 1 + (some f cdr.xs) + +alias any some +alias none ~some + +def zip(a b) + if (and a b) + (cons (list car.a car.b) + (zip cdr.a cdr.b)) + +def zip-flat(a b) + if (and a b) + `(,car.a ,car.b ,@(zip-flat cdr.a cdr.b)) + +def pairwise(xs) + (zip xs cdr.xs) + +def rev(xs acc) + if !xs + acc + (rev cdr.xs + (cons car.xs acc)) + +def lastcons(l) + aif cdr.l + lastcons.it + l + +def flatten(l acc) + (if + !l + acc + ~cons?.l + (cons l acc) + (flatten car.l (flatten cdr.l acc))) + + + +;; Internals + +def range-bounce(l idx) + (if (< idx 0) + (+ len.l idx) + idx) + +def range-start(l idx) + if !idx + 0 + (range-bounce l idx) diff --git a/039mutate.test b/039mutate.test new file mode 100644 index 00000000..58056c59 --- /dev/null +++ b/039mutate.test @@ -0,0 +1,38 @@ +(test "assignment can process multiple pairs" + :valueof (do + (= x 1 y 2) + (cons x y)) + :should be '(1 . 2)) + +(test "or= works" + :valueof (ret x nil + (or= x 3) + (or= x ++.x)) + :should be 3) + +(test "shift works" + :valueof (with (x 3 y 4) + (shift x y 27) + (list x y)) + :should be '(4 27)) + +(test "rotate works" + :valueof (with (x 3 y 4 z 5) + (rotate x y z) + (list x y z)) + :should be '(4 5 3)) + +(test "swap works" + :valueof (with (x 3 y 4) + (swap x y) + (list x y)) + :should be '(4 3)) + +(test "making works" + :valueof (do + (= x 3) + (let f (fn() x) + (list f. + (let x 4 f.) + (making x 4 f.)))) + :should be '(3 3 4)) diff --git a/039mutate.wart b/039mutate.wart new file mode 100644 index 00000000..6ccc0757 --- /dev/null +++ b/039mutate.wart @@ -0,0 +1,36 @@ +mac zap(f x) + `(= ,x (,f ,x)) + +; infinite nil generator += nils '(nil) cdr.nils nils + +mac wipe places + `(= ,@(zip-flat places nils)) + +mac push(x xs) + `(= ,xs (cons ,x ,xs)) + +mac pop(xs) + `(do1 car.,xs + (zap cdr ,xs)) + +mac or=(var val) + `(unless ,var + (= ,var ,val)) + +mac shift args ; multiple-eval to maintain places + `(= ,@(zip-flat args cdr.args)) + +mac rotate args + `(let $tmp ,car.args + shift ,@args $tmp) + +mac swap(x y) + `(rotate ,x ,y) + +mac making(var val . body) + `(between (dyn_bind ,var ,val) :and (dyn_unbind ,var) + ,@body) + +mac coerce!(var type) + `(= ,var (coerce ,var ',type)) diff --git a/040num.test b/040num.test new file mode 100644 index 00000000..d0cecf28 --- /dev/null +++ b/040num.test @@ -0,0 +1,59 @@ +(test "arithmetic is varargs" + :valueof (+ 1 2 3 (* 1 2 2)) + :should be 10) + +(test "division works" + :valueof (/ 4 2 2) + :should be 1) + +(test "increment works with lexical vars" + :valueof (ret x 3 ++.x) + :should be 4) + +(test "divides works" + :valueof (divides 3 2) + :should be nil) + +(test "divides works - 2" + :valueof (divides 4 2) + :should ~be nil) + +(test "> works" + :valueof (> 3 2 1) + :should ~be nil) + +(test "> works - 2" + :valueof (> 3 1 2) + :should be nil) + +(test "< works" + :valueof (< 3 1 2) + :should be nil) + +(test "< works - 2" + :valueof (< 1 2 3) + :should ~be nil) + +(test "<= works" + :valueof (<= 1 2 3) + :should ~be nil) + +(test "<= works" + :valueof (<= 1 1 3) + :should ~be nil) + +(test "<= works" + :valueof (<= 1 4 3) + :should be nil) + +(test ">= works" + :valueof (>= 3 2 1) + :should ~be nil) + +(test ">= works" + :valueof (>= 3 1 1) + :should ~be nil) + +(test ">= works" + :valueof (>= 3 1 2) + :should be nil) diff --git a/040num.wart b/040num.wart new file mode 100644 index 00000000..22a2c117 --- /dev/null +++ b/040num.wart @@ -0,0 +1,55 @@ +let $+ + + def! + xs + (reduce $+ xs) + +let $- - + def! - xs + (reduce $- xs) + +let $* * + def! * xs + (reduce $* xs) + +let $/ / + def! / xs + (reduce $/ xs) + +let $% % + def! % xs + (reduce $% xs) + +let $< < + def! > xs + (all (fn((x y)) ($< y x)) + pairwise.xs) + + def! < xs + (all (fn((x y)) ($< x y)) + pairwise.xs) + + def >= xs + (none (fn((x y)) ($< x y)) + pairwise.xs) + + def <= xs + (none (fn((x y)) ($< y x)) + pairwise.xs) + +mac ++(n) + `(= ,n (+ ,n 1)) + +mac --(n) + `(= ,n (- ,n 1)) + + + +def zero?(n) + (iso n 0) + +def divides(nr dr) + (zero?:% nr dr) + +def even?(n) + (divides n 2) + += odd? ~even? diff --git a/041string.test b/041string.test new file mode 100644 index 00000000..48b92ebe --- /dev/null +++ b/041string.test @@ -0,0 +1,76 @@ +(test "len works on strings" + :valueof (len "abcdefgh") + :should be 8) + +(test "strings work in function position" + :valueof ("abcd" 2) + :should be "c") + +(test "strings can index final char" + :valueof ("abcd" 3) + :should be "d") + +(test "strings can take negative indices" + :valueof ("abcd" -3) + :should be "b") + +(test "strings can take slices" + :valueof ("abcd" 1 3) + :should be "bc") + +(test "strings can take slices - 2" + :valueof ("abcd" 1 -1) + :should be "bc") + +(test "strings can take slices - explicit nil" + :valueof ("abcd" 1 nil) + :should be "bcd") + +(test "string indices can be assigned to" + :valueof (ret s "abc" + (= s.1 "z")) + :should be "azc") + +(test "string indices can be assigned to - 2" + :valueof (ret s "abc" + (= s.-1 "z")) + :should be "abz") + +(test "string slices can be assigned to" + :valueof (ret s "abcdefgh" + (= (s 1 5) "xy")) + :should be "axyfgh") + +(test "string slices can be assigned to - 2" + :valueof (ret s "abcdefgh" + (= (s -4 -1) "xy")) + :should be "abcdxyh") + +(test "string slices can be assigned to - explicit nil" + :valueof (ret s "abcdefgh" + (= (s -4 nil) "xy")) + :should be "abcdxy") + +(test "string slices can be assigned to - explicit nil var" + :valueof (ret s "abcdefgh" + (let x nil + (= (s -4 x) "xy"))) + :should be "abcdxy") + +(test "string index can be reset" + :valueof (ret l "abc" + (= l.1 nil)) + :should be "ac") + +(test "each works on literal strings" + :valueof (ret ans nil + (each c "abc" + (push c ans))) + :should be '("c" "b" "a")) + +(test "each works on strings" + :valueof (ret ans nil + (let s "abc" + (each c s + (push c ans)))) + :should be '("c" "b" "a")) diff --git a/041string.wart b/041string.wart new file mode 100644 index 00000000..b42c3961 --- /dev/null +++ b/041string.wart @@ -0,0 +1,41 @@ +defcall string(s idx . ends) + withs (idx (range-start s idx) + end (if + !ends + (+ idx 1) + !car.ends + len.s + :else + (range-bounce s car.ends))) + (string_range s idx end) + +defset string((s idx . ends) val) + `(withs ($idx (range-start ,s ,idx) + $end ,(if !ends + `(+ $idx 1) + `(if !,car.ends + len.,s + (range-bounce ,s ,car.ends)))) + (string_splice ,s $idx $end (or ,val ""))) + +defcoerce string symbol + string_to_sym + +def empty?(s) :case string?.s + (iso "" s) + +let $each each + mac! each(var s . body) + `(if string?.,s + forlen $i ,s + let ,var (,s $i) + ,@body + (,$each ,var ,s ,@body)) + +defcoerce string list + (fn(_) + (collect:each c _ + yield.c)) + +def <(a b) :case string?.a + (string< a b) diff --git a/042table.test b/042table.test new file mode 100644 index 00000000..bb499a8e --- /dev/null +++ b/042table.test @@ -0,0 +1,40 @@ +(test "tables work in function position" + :valueof (let h (table) + (table_set h 3 4) + h.3) + :should be 4) + +(test "get on tables takes a default" + :valueof (let h (table) + (h 3 5)) + :should be 5) + +(test "tables can be assigned to" + :valueof (let h (table) + (= h.3 4) + h.3) + :should be 4) + +(test "each works on tables" + :valueof (ret ans 0 + (each (k v) (table 1 2 3 4) + ++.ans)) + :should be 2) + +(test "iso works on tables" + :valueof (iso (table) (table)) + :should ~be nil) + +(test "iso works on tables - 2" + :valueof (iso (table 'a 1 'b 2) (table 'b 2 'a 1)) + :should ~be nil) + +(test "lists coerce to tables" + :valueof (as table '((1 2) (3 4))) + :should be (ret x (table) + (= x.1 2) + (= x.3 4))) + +(test "tables coerce to lists" + :valueof (as table (as list (table 1 2 3 4))) + :should be (table 1 2 3 4)) diff --git a/042table.wart b/042table.wart new file mode 100644 index 00000000..5bb40143 --- /dev/null +++ b/042table.wart @@ -0,0 +1,37 @@ +defcall table(h k default) + (or (table_get h k) default) + +defset table((h k) v) + `(table_set ,h ,k ,v) + +defcoerce table list + table_to_list + +let $table table ; ignore later refinements + defcoerce nil table + $table + + defcoerce list table + (fn(_) + ret h ($table) + each (k v) _ + (= h.k v)) + +def! table args + (as table pair.args) + +def copy(x) :case (isa x 'table) + (as table (as list x)) + +def keys(t) + map car (as list t) + +def vals(t) + map cadr (as list t) + +def iso(x y) :case (isa x 'table) + (and (isa y 'table) + (iso len:keys.x len:keys.y) + (all (fn((k v)) + (iso y.k v)) + (as list x))) diff --git a/043queue.test b/043queue.test new file mode 100644 index 00000000..631e3749 --- /dev/null +++ b/043queue.test @@ -0,0 +1,22 @@ +(test "enq returns the elem being enqueued" + :valueof (enq 3 queue.) + :should be 3) + +(test "len works on queues" + :valueof (len:queue '(1 2 3 4)) + :should be 4) + +(test "deq works" + :valueof (let q (queue '(1 2 3)) + (enq 4 q) + (enq 5 q) + deq.q) + :should be 1) + +(test "queue maintains length" + :valueof (let q (queue '(1 2 3)) + (enq 4 q) + (enq 5 q) + (deq q) + len.q) + :should be 4) diff --git a/043queue.wart b/043queue.wart new file mode 100644 index 00000000..d8a053ad --- /dev/null +++ b/043queue.wart @@ -0,0 +1,20 @@ +def queue(l) + (tag 'queue (list l lastcons.l len.l)) + +def enq(x q) + do1 x + let (l last len) rep.q + (= rep.q.2 (+ len 1)) + if !l + (= rep.q.1 (= rep.q.0 list.x)) + (= rep.q.1 (= cdr.last list.x)) + +def deq(q) + let (l last len) rep.q + ret ans car.l + unless zero?.len + (= rep.q.2 (- len 1)) + (= rep.q.0 cdr.l) + +def len(x) :case (isa x 'queue) + rep.x.2 diff --git a/044collect.test b/044collect.test new file mode 100644 index 00000000..90a3c8f5 --- /dev/null +++ b/044collect.test @@ -0,0 +1,3 @@ +(test "collect/yield works" + :valueof (collect:for i 1 (< i 4) ++.i yield.i) + :should be '(1 2 3)) diff --git a/044collect.wart b/044collect.wart new file mode 100644 index 00000000..9fdd1438 --- /dev/null +++ b/044collect.wart @@ -0,0 +1,6 @@ +mac collect body + `(withs ($acc (queue) + yield (fn(_) + (enq _ $acc))) + ,@body + (car rep.$acc)) diff --git a/045stream.test b/045stream.test new file mode 100644 index 00000000..5a95e897 --- /dev/null +++ b/045stream.test @@ -0,0 +1,24 @@ +(test "read works" + :valueof (making stdin (instring "34 35") + read.) + :should be '(34 35)) + +system "echo abc > _x" +(test "read works on fd" + :valueof (making stdin (infd:input_fd "_x") + read.) + :should be 'abc) +system "rm _x" + +(test "multiple reads work" + :valueof (making stdin (instring "34 +35") + read. + read.) + :should be 35) + +(test "read-byte works" + :valueof (w/instring "ab" + read-byte. + read-byte.) + :should be 98) diff --git a/045stream.wart b/045stream.wart new file mode 100644 index 00000000..841ff820 --- /dev/null +++ b/045stream.wart @@ -0,0 +1,24 @@ +mac w/infile(name . body) + `(between (dyn_bind stdin (infile ,name)) :and (do close_infile.stdin dyn_unbind.stdin) + ,@body) + +mac w/outfile(name . body) + `(between (dyn_bind stdout (outfile ,name)) :and (do close_infile.stdout dyn_unbind.stdout) + ,@body) + +mac w/instring(s . body) + `(between (dyn_bind stdin (instring ,s)) :and (do close_infile.stdin dyn_unbind.stdin) + ,@body) + +mac w/outstring body + `(between (dyn_bind stdout outstring.) :and (do close_outfile.stdout dyn_unbind.stdout) + ,@body + outstring_buffer.stdout) + +mac w/stdin(fd . body) + `(between (dyn_bind stdin infd.,fd) :and (do dyn_unbind.stdin close.,fd) + ,@body) + +mac w/stdout(fd . body) + `(between (dyn_bind stdout outfd.,fd) :and (do dyn_unbind.stdout close.,fd) + ,@body) diff --git a/046sym.test b/046sym.test new file mode 100644 index 00000000..355945aa --- /dev/null +++ b/046sym.test @@ -0,0 +1,23 @@ +(test "str works with multiple args" + :valueof (str 'a 43) + :should be "a43") + +(test "sym works with one arg" + :valueof (sym "abc") + :should be 'abc) + +(test "sym works with multiple args" + :valueof (str:sym "abc" 42 :def) ; keyword retains colon + :should be "abc42:def") + +(test "keyword? works" + :valueof (keyword? 'abc) + :should be nil) + +(test "keyword? works - 2" + :valueof (keyword? :abc) + :should ~be nil) + +(test "sym converts keywords" + :valueof (sym :abc) + :should be 'abc) ; keyword loses colon diff --git a/046sym.wart b/046sym.wart new file mode 100644 index 00000000..848e627f --- /dev/null +++ b/046sym.wart @@ -0,0 +1,15 @@ +def str args + (w/outstring + (each arg args pr.arg)) +defcoerce symbol string + str + +def sym args + (as symbol (str @args)) + +def keyword?(s) + (and sym?.s + (iso ":" str.s.0)) + +def sym(s . rest) :case (and !rest keyword?.s) + as symbol (str.s 1 nil) diff --git a/047fork.wart b/047fork.wart new file mode 100644 index 00000000..b2211da9 --- /dev/null +++ b/047fork.wart @@ -0,0 +1,14 @@ +let $fork fork + mac! fork body + `(when (zero? ,$fork.) + ,@body + quit.) + +mac preforking(n . body) + `(do + repeat ,n + (fork ,@body) + repeat :forever + (wait_for_child) + (prn "restart") + (fork ,@body)) diff --git a/048patmatch.test b/048patmatch.test new file mode 100644 index 00000000..82401307 --- /dev/null +++ b/048patmatch.test @@ -0,0 +1,19 @@ +(test "matching works" + :valueof (matching (_x) (list 3) + x) + :should be 3) + +(test "matching checks for match" + :valueof (matching (bar _x) (list 3) + x) + :should be nil) + +(test "matching checks for match - 2" + :valueof (matching (a (_x _y)) (list 'a 3) + x) + :should be nil) + +(test "matching checks for match - 3" + :valueof (matching (a (_x _y)) (list 'a '(3 4)) + (list x y)) + :should be '(3 4)) diff --git a/048patmatch.wart b/048patmatch.wart new file mode 100644 index 00000000..6bbba851 --- /dev/null +++ b/048patmatch.wart @@ -0,0 +1,17 @@ +mac matching(vars vals . body) + `(if (match ',vars ,vals) + let ,strip_underscores.vars ,vals + ,@body) + + + +;; Internals + +def strip_underscores(vars) + (if + cons?.vars + (cons strip_underscores:car.vars strip_underscores:cdr.vars) + (iso str.vars.0 "_") + (sym (str.vars 1 nil)) + :else + vars) diff --git a/050http-server.wart b/050http-server.wart new file mode 100644 index 00000000..e071df1d --- /dev/null +++ b/050http-server.wart @@ -0,0 +1,26 @@ +mac w/server-socket(socket port . body) + `(let ,socket make-server-socket.,port + before close_socket.,socket + ,@body) + +mac accepting(client-socket socket/from . body) + `(repeat :forever + let ,client-socket socket-accept.,socket + before close_socket.,client-socket + ,@body) ; body must close client-socket + +def parse-request(client-socket) + making stdin infd:socket_fd.client-socket + let (verb url) read. + url + +def http-server(port) + w/server-socket socket (or port 4040) + preforking 6 ; handler threads + accepting client-socket :from socket + let url parse-request.client-socket + making stdout infd:socket_fd.client-socket + prn "HTTP/1.0 200 OK" + prn "Content-type: text/plain" + prn. + prn url diff --git a/ugliness b/ugliness index 60e4931e..2f26b497 100644 --- a/ugliness +++ b/ugliness @@ -1,5 +1,4 @@ concepts I'd like to do without in eval: - mfn already-eval ('') can't use coerce in eval