application/octet-stream
•
84.76 KB
•
1 line
[do [def lognand [λ* lognand l "Returns the Nand of its arguments" [lognot [apply logand l]]]] [def bit-set?! [λ* bit-set?! [i] "" [do [def mask [ash 1 i]] [λ* #nil [α] "" [not [zero? [logand α mask]]]]]]] [def bit-clear?! [λ* bit-clear?! [i] "" [do [def mask [ash 1 i]] [λ* #nil [α] "" [zero? [logand α mask]]]]]]][do [def array/2d/allocate [λ* array/2d/allocate [width height] "" [tree/new :data [array/fill! [array/allocate [* width height]] 0] :width width :height height]]] [def array/2d/fill! [λ* array/2d/fill! [data v] "" [do [array/fill! [tree/ref data :data] v] data]]] [def array/2d/ref [λ* array/2d/ref [data x y oob-val] "" [if [or [>= x [tree/ref data :width]] [>= y [tree/ref data :height]] [< x 0] [< y 0]] oob-val [array/ref [tree/ref data :data] [add x [mul y [tree/ref data :width]]]]]]] [def array/2d/set! [λ* array/2d/set! [data x y val] "" [do [if [or [>= x [tree/ref data :width]] [>= y [tree/ref data :height]] [< x 0] [< y 0]] [throw [list :out-of-bounds "Trying to set an array out of bounds" data [current-lambda]]] [array/set! [tree/ref data :data] [add x [mul y [tree/ref data :width]]] val]] data]]] [def array/2d/print [λ* array/2d/print [data] "" [do [let* [do [def y 0] [def ΓεnΣym-117 [tree/ref data :height]] [while [< y ΓεnΣym-117] [do [let* [do [def x 0] [def ΓεnΣym-118 [tree/ref data :width]] [while [< x ΓεnΣym-118] [do [display [cat [array/2d/ref data x y] " "]] [set! x [add 1 x]]]]]] [newline] [set! y [add 1 y]]]]]] data]]]][do [def array/+= [λ* array/+= [a i v] "Add V to the value in A at position I and store the result in A returning A" [array/set! a i [+ v [array/ref a i]]]]] [def array/++ [λ* array/++ [a i] "Increment position I in A and return A" [array/+= a i 1]]] [def array/fill! [λ* array/fill! [a v i] "Fills array a with value v" [do [def len [array/length a]] [let* [do [def i 0] [def ΓεnΣym-108 len] [while [< i ΓεnΣym-108] [do [array/set! a i v] [set! i [add 1 i]]]]]] a]]] [def array/append [λ* array/append [a b] "Append array A to array B" [do [if [and [array? a] [array? b]] #nil [throw [list :type-error "array/append expects two arrays as its arguments" #nil [current-lambda]]]] [def ret [array/allocate [+ [array/length a] [array/length b]]]] [let* [do [def i 0] [def ΓεnΣym-109 [array/length a]] [while [< i ΓεnΣym-109] [do [array/set! ret i [array/ref a i]] [set! i [add 1 i]]]]]] [let* [do [def i [array/length a]] [def ΓεnΣym-110 [array/length ret]] [while [< i ΓεnΣym-110] [do [array/set! ret i [array/ref b [- i [array/length a]]]] [set! i [add 1 i]]]]]] ret]]] [def array/dup [λ* array/dup [a] "Duplicate Array A" [array/append a [array/new #nil]]]] [def array/reduce [λ* array/reduce [arr fun α] "Reduce an array, [reduce] should be preferred" [do [def len [array/length arr]] [let* [do [def i 0] [def ΓεnΣym-111 len] [while [< i ΓεnΣym-111] [do [set! α [fun α [array/ref arr i]]] [set! i [add 1 i]]]]]] α]]] [def array/map [λ* array/map [arr fun] "Map an array, [map] should be preferred" [do [def len [array/length arr]] [let* [do [def i 0] [def ΓεnΣym-112 len] [while [< i ΓεnΣym-112] [do [array/set! arr i [fun [array/ref arr i]]] [set! i [add 1 i]]]]]] arr]]] [def array/filter [λ* array/filter [arr pred] "Filter an array, [filter] should be preferred" [do [def ri 0] [def len [array/length arr]] [def ret [array/allocate len]] [let* [do [def ai 0] [def ΓεnΣym-113 len] [while [< ai ΓεnΣym-113] [do [if [pred [array/ref arr ai]] [do [array/set! ret ri [array/ref arr ai]] [set! ri [+ 1 ri]]] #nil] [set! ai [add 1 ai]]]]]] [array/length! ret ri]]]] [def array/equal? [λ* array/equal? [a b] "" [if [or [not [array? a]] [not [array? b]] [!= [array/length a] [array/length b]]] #f [let* [do [def ret #t] [let* [do [def i 0] [def ΓεnΣym-114 [array/length a]] [while [< i ΓεnΣym-114] [do [if [equal? [array/ref a i] [array/ref b i]] #nil [do [set! ret #f] [set! i [array/length a]]]] [set! i [add 1 i]]]]]] ret]]]]] [def array/push [λ* array/push [arr . val] "Append all arguments following ARR to ARR" [do [let* [do [def ΓεnΣym-115 val] [if ΓεnΣym-115 [while ΓεnΣym-115 [do [def v [car ΓεnΣym-115]] [array/length! arr [+ 1 [array/length arr]]] [array/set! arr [- [array/length arr] 1] v] [set! ΓεnΣym-115 [cdr ΓεnΣym-115]]]] #nil]]] arr]]] [def array/swap [λ* array/swap [arr i j] "" [do [def tmp [array/ref arr i]] [array/set! arr i [array/ref arr j]] [array/set! arr j tmp]]]] [def array/heapify [λ* array/heapify [arr n at] "bubble up the element from index AT to until the max-heap property is satisfied" [do [def top at] [def looping #t] [while looping [do [def l [+ [<< at 1] 1]] [def r [+ [<< at 1] 2]] [if [and [< l n] [> [array/ref arr l] [array/ref arr top]]] [set! top l] #nil] [if [and [< r n] [> [array/ref arr r] [array/ref arr top]]] [set! top r] #nil] [if [== top at] [set! looping #f] [do [array/swap arr at top] [set! at top]]]]] arr]]] [def array/make-heap [λ* array/make-heap [arr] "" [do [def l [array/length arr]] [def l2 [/ l 2]] [while [>= l2 0] [do [array/heapify arr l l2] [set! l2 [+ -1 l2]]]] arr]]] [def array/heap-sort [λ* array/heap-sort [arr] "" [do [array/make-heap arr] [def l [array/length arr]] [while [> l 0] [do [set! l [+ -1 l]] [array/swap arr 0 l] [array/heapify arr l 0]]] arr]]] [def array/sort array/heap-sort] [def array/cut [λ* array/cut [arr start end] "Return a newly allocated array with the values of ARR from START to END" [do [set! start [max 0 start]] [set! end [min [array/length arr] end]] [def ret [array/allocate [max 0 [- end start]]]] [let* [do [def i start] [def ΓεnΣym-116 end] [while [< i ΓεnΣym-116] [do [array/set! ret [- i start] [array/ref arr i]] [set! i [add 1 i]]]]]] ret]]]][do [def sum [λ* sum [c] "Return the sum of every value in collection C" [reduce c + 0]]] [def join [λ* join [l glue] "Join every element of α together into a string with GLUE inbetween" [do [if glue #nil [set! glue ""]] [if l [reduce l [λ* #nil [a b] "" [if a [cat a glue b] b]] #nil] ""]]]] [def for-each [λ* for-each [l f] "Runs F over every item in collection L" [reduce l [λ* #nil [a b] "" [f b]] #nil]]] [def count [λ* count [l p] "Count the number of items in L where P is true" [if p [reduce l [λ* #nil [a b] "" [+ a [if [p b] 1 0]]] 0] [reduce l [λ* #nil [a b] "" [+ a 1]] 0]]]] [def min/λ [λ* min/λ [a b] "" [if [< a b] a b]]] [def min [λ* min l "Returns the minimum value of its arguments, or collection" [reduce [if [cdr l] l [car l]] min/λ #nil]]] [def max/λ [λ* max/λ [a b] "" [if [> a b] a b]]] [def max [λ* max l "Returns the minimum value of its arguments, or collection" [reduce [if [cdr l] l [car l]] max/λ #nil]]] [def delete [λ* delete [l e] "Returns a filtered list l with all elements equal to e omitted" [filter l [λ* #nil [a] "" [not [== a e]]]]]] [def remove [λ* remove [l p] "Returns a filtered list l with all elements where P equal true removed" [filter l [λ* #nil [a] "" [not [p a]]]]]] [def flatten/λ [λ* flatten/λ [a b] "" [if [collection? b] [append [reduce b flatten/λ #nil] a] [if #t [cons b a] #nil]]]] [def flatten [λ* flatten [l] "Flatten a collection of collections into a simple list" [if [collection? l] [nreverse [reduce l flatten/λ #nil]] l]]]][do [def ref [λ* ref [l i] "Return whatver is at position I in L" [let* [do [def ΓεnΣym-32 [type-of l]] [if [or [== ΓεnΣym-32 :nil]] #nil [if [or [== ΓεnΣym-32 :tree]] [tree/ref l i] [if [or [== ΓεnΣym-32 :string]] [char-at l i] [if [or [== ΓεnΣym-32 :array]] [array/ref l i] [if [or [== ΓεnΣym-32 :pair]] [list/ref l i] [throw [list :type-error "You can only use ref with a collection" l [current-lambda]]]]]]]]]]]] [def filter [λ* filter [l p] "Runs predicate p over every item in collection l and returns a list consiting solely of items where p is true" [let* [do [def ΓεnΣym-119 [type-of l]] [if [or [== ΓεnΣym-119 :nil]] #nil [if [or [== ΓεnΣym-119 :tree]] [tree/filter l p] [if [or [== ΓεnΣym-119 :pair]] [list/filter l p] [if [or [== ΓεnΣym-119 :array]] [array/filter l p] [throw [list :type-error "You can only use filter with a collection" l [current-lambda]]]]]]]]]]] [def reduce [λ* reduce [l f α] "Combine all elements in collection l using operation F and starting value α" [let* [do [def ΓεnΣym-120 [type-of l]] [if [or [== ΓεnΣym-120 :nil]] α [if [or [== ΓεnΣym-120 :tree]] [tree/reduce l f α] [if [or [== ΓεnΣym-120 :pair]] [list/reduce l f α] [if [or [== ΓεnΣym-120 :array]] [array/reduce l f α] [f α l]]]]]]]]] [def length [λ* length [α] "Returns the length of collection α" [let* [do [def ΓεnΣym-121 [type-of α]] [if [or [== ΓεnΣym-121 :nil]] 0 [if [or [== ΓεnΣym-121 :array]] [array/length α] [if [or [== ΓεnΣym-121 :pair]] [list/length α] [if [or [== ΓεnΣym-121 :string]] [string/length α] [if [or [== ΓεnΣym-121 :tree]] [tree/size α] [throw [list :type-error "You can only use length with a collection" α [current-lambda]]]]]]]]]]]] [def map [λ* map [l f] "Runs f over every item in collection l and returns the resulting list" [let* [do [def ΓεnΣym-122 [type-of l]] [if [or [== ΓεnΣym-122 :nil]] #nil [if [or [== ΓεnΣym-122 :pair]] [list/map l f] [if [or [== ΓεnΣym-122 :array]] [array/map l f] [throw [list :type-error "You can only use map with a collection" l [current-lambda]]]]]]]]]] [def sort [λ* sort [l] "Sorts the collection L" [let* [do [def ΓεnΣym-123 [type-of l]] [if [== ΓεnΣym-123 :pair] [list/sort l] [if [== ΓεnΣym-123 :array] [array/sort l] [throw [list :type-error "You can only use sort with a collection" l [current-lambda]]]]]]]]] [def member [λ* member [l m] "Returns the first pair/item of collection l whose car is equal to m" [let* [do [def ΓεnΣym-124 [type-of l]] [if [== ΓεnΣym-124 :pair] [list/member l m] [if [== ΓεnΣym-124 :tree] [tree/get l m] [throw [list :type-error "You can only use member with a collection" l [current-lambda]]]]]]]]] [def cut [λ* cut [l start end] "Return a subcollection of L from START to END" [let* [do [def ΓεnΣym-125 [type-of l]] [if [== ΓεnΣym-125 :array] [array/cut l start end] [if [== ΓεnΣym-125 :pair] [list/cut l start end] [if [== ΓεnΣym-125 :string] [string/cut l start end] [throw [list :type-error "You can only use member with a collection" l [current-lambda]]]]]]]]]] [def collection? [λ* collection? [l] "" [let* [do [def ΓεnΣym-126 [type-of l]] [if [or [== ΓεnΣym-126 :pair] [== ΓεnΣym-126 :array] [== ΓεnΣym-126 :tree]] #t #f]]]]]][do [def except-last-pair/iter [λ* except-last-pair/iter [list rest] "Iterator for except-last-pair" [if [nil? [cdr list]] [reverse rest] [except-last-pair/iter [cdr list] [cons [car list] rest]]]]] [def except-last-pair [λ* except-last-pair [list] "Return a copy of LIST without the last pair" [except-last-pair/iter list #nil]]] [def last-pair [λ* last-pair [list] "Return the last pair of LIST" [do [while [cdr list] [set! list [cdr list]]] list]]] [def make-list [λ* make-list [number value] "Return a list of NUMBER elements containing VALUE in every car" [do [def list #nil] [while [>= [set! number [+ -1 number]] 0] [set! list [cons value list]]] list]]] [def range [λ* range [end start step] "Return a list containing values from START (inclusive) to END (exclusive) by STEP" [do [if end #nil [throw [list :arity-error "[range] needs at least a specific end"]]] [if start #nil [set! start 0]] [if step #nil [set! step 1]] [def pred [if [pos? step] < >]] [def ret #nil] [while [pred start end] [do [set! ret [cons start ret]] [set! start [+ start step]]]] [nreverse ret]]]] [def list/reduce [λ* list/reduce [l o s] "Combine all elements in l using operation o and starting value s" [do [let* [do [def ΓεnΣym-127 l] [if ΓεnΣym-127 [while ΓεnΣym-127 [do [def e [car ΓεnΣym-127]] [set! s [o s e]] [set! ΓεnΣym-127 [cdr ΓεnΣym-127]]]] #nil]]] s]]] [def list/ref [λ* list/ref [l i] "Returns the the element of list l at location i" [do [while [and l [> i 0]] [do [set! i [+ -1 i]] [set! l [cdr l]]]] [car l]]]] [def reverse [λ* reverse [l] "Return the list l in reverse order" [do [def ret #nil] [let* [do [def ΓεnΣym-128 l] [if ΓεnΣym-128 [while ΓεnΣym-128 [do [def e [car ΓεnΣym-128]] [set! ret [cons e ret]] [set! ΓεnΣym-128 [cdr ΓεnΣym-128]]]] #nil]]] ret]]] [def list/length [λ* list/length [l] "Returns the length of list l" [do [def ret 0] [let* [do [def ΓεnΣym-129 l] [if ΓεnΣym-129 [while ΓεnΣym-129 [do [def e [car ΓεnΣym-129]] [set! ret [+ 1 ret]] [set! ΓεnΣym-129 [cdr ΓεnΣym-129]]]] #nil]]] ret]]] [def list/filter [λ* list/filter [l p] "Runs predicate p over every item in list l and returns a list consiting solely of items where p is true" [do [def ret #nil] [let* [do [def ΓεnΣym-130 l] [if ΓεnΣym-130 [while ΓεnΣym-130 [do [def e [car ΓεnΣym-130]] [if [p e] [set! ret [cons e ret]] #nil] [set! ΓεnΣym-130 [cdr ΓεnΣym-130]]]] #nil]]] [nreverse ret]]]] [def list/map [λ* list/map [l f] "Runs f over every item in list l and returns the resulting list" [do [def ret #nil] [let* [do [def ΓεnΣym-131 l] [if ΓεnΣym-131 [while ΓεnΣym-131 [do [def e [car ΓεnΣym-131]] [set! ret [cons [f e] ret]] [set! ΓεnΣym-131 [cdr ΓεnΣym-131]]]] #nil]]] [nreverse ret]]]] [def append/iter [λ* append/iter [a b] "Iterator for append" [if [nil? a] b [append/iter [cdr a] [cons [car a] b]]]]] [def append [λ* append [a . b] "Appends two lists A and B together" [do [while b [do [set! a [append/iter [reverse a] [car b]]] [set! b [cdr b]]]] a]]] [def sublist [λ* sublist [l start end ret] "Returns a new list containing all elements of l from start to end" [if [nil? l] [reverse ret] [if [neg? end] [sublist l start [+ [length l] end]] [if [zero? end] [reverse ret] [if [> start 0] [sublist [cdr l] [+ -1 start] [+ -1 end] #nil] [if [> end 0] [sublist [cdr l] 0 [+ -1 end] [cons [car l] ret]] #nil]]]]]]] [def list-head [λ* list-head [l k] "Returns the first k elemnts of list l" [sublist l 0 k]]] [def list-tail [λ* list-tail [l k] "Returns the sublist of l obtained by omitting the first l elements" [sublist l k [length l]]]] [def list/member [λ* list/member [l m] "Returns the first pair of list l whose car is equal to m" [if [nil? l] #f [if [== [car l] m] l [if #t [member [cdr l] m] #nil]]]]] [def getf [λ* getf [l key] "Return the value in LIST following KEY" [if [nil? l] #nil [if [== key [car l]] [cadr l] [if #t [getf [cdr l] key] #nil]]]]] [def list/sort/bubble [λ* list/sort/bubble [l] "Terribly slow way to sort a list, though it was simple to write" [if l [do [def top [car l]] [def next #nil] [set! l [cdr l]] [while l [do [if [<= [car l] top] [do [set! next [cons top next]] [set! top [car l]]] [set! next [cons [car l] next]]] [set! l [cdr l]]]] [cons top [list/sort/bubble next]]] #nil]]] [def list/merge-sorted-lists [λ* list/merge-sorted-lists [l1 l2] "" [if [nil? l1] l2 [if [nil? l2] l1 [if #t [if [< [car l1] [car l2]] [cons [car l1] [list/merge-sorted-lists [cdr l1] l2]] [cons [car l2] [list/merge-sorted-lists l1 [cdr l2]]]] #nil]]]]] [def list/split-half-rec [λ* list/split-half-rec [l acc1 acc2] "" [if [nil? l] [cons acc1 acc2] [if [nil? [cdr l]] [cons [cons [car l] acc1] acc2] [if #t [list/split-half-rec [cddr l] [cons [car l] acc1] [cons [cadr l] acc2]] #nil]]]]] [def list/split-half [λ* list/split-half [l] "" [list/split-half-rec l #nil #nil]]] [def list/sort/merge [λ* list/sort/merge [l] "Sorts a list" [if [nil? [cdr l]] l [do [def parts [list/split-half l]] [list/merge-sorted-lists [list/sort/merge [car parts]] [list/sort/merge [cdr parts]]]]]]] [def list/sort list/sort/merge] [def list/equal? [λ* list/equal? [a b] "#t if A and B are equal" [if [pair? a] [and [list/equal? [car a] [car b]] [list/equal? [cdr a] [cdr b]]] [equal? a b]]]] [def list/take [λ* list/take [l count] "Take the first COUNT elements from list L" [if [<= count 0] #nil [cons [car l] [list/take [cdr l] [- count 1]]]]]] [def list/drop [λ* list/drop [l count] "Drop the final COUNT elements from list L" [if [<= count 0] l [list/drop [cdr l] [- count 1]]]]] [def list/cut [λ* list/cut [l start end] "Return a subsequence of L from START to END" [list/take [list/drop l [max 0 start]] [- end [max 0 start]]]]]][do [def tree/zip [λ* tree/zip [keys values] "Return a tree where KEYS point to VALUES" [do [def ret [tree/new #nil]] [let* [do [def ΓεnΣym-41 keys] [if ΓεnΣym-41 [while ΓεnΣym-41 [do [def key [car ΓεnΣym-41]] [tree/set! ret key [car values]] [set! values [cdr values]] [set! ΓεnΣym-41 [cdr ΓεnΣym-41]]]] #nil]]] ret]]] [def tree/+= [λ* tree/+= [t k v] "Increment value at K in T by V" [tree/set! t k [+ v [int [tree/ref t k]]]]]] [def tree/-= [μ* tree/-= [t k v] "Decrement value at K in T by V" [cons 'tree/+= [cons t [cons k [cons [cons '- [cons v #nil]] #nil]]]]]] [def tree/++ [μ* tree/++ [t k] "Increment value at K in T by 1" [cons 'tree/+= [cons t [cons k [cons 1 #nil]]]]]] [def tree/-- [μ* tree/-- [t k] "Increment value at K in T by 1" [cons 'tree/-= [cons t [cons k [cons 1 #nil]]]]]] [def tree/equal? [λ* tree/equal? [a b] "Compares two trees for equality" [if [and [tree? a] [tree? b]] [and [== [tree/key* a] [tree/key* b]] [equal? [tree/value* a] [tree/value* b]] [tree/equal? [tree/left* a] [tree/left* b]] [tree/equal? [tree/right* a] [tree/right* b]]] [equal? a b]]]] [def tree/reduce [λ* tree/reduce [l o s] "Combine all elements in l using operation o and starting value s" [do [let* [do [def ΓεnΣym-132 [tree/keys l]] [if ΓεnΣym-132 [while ΓεnΣym-132 [do [def e [car ΓεnΣym-132]] [set! s [o [tree/ref l e] s e]] [set! ΓεnΣym-132 [cdr ΓεnΣym-132]]]] #nil]]] s]]] [def tree/filter [λ* tree/filter [l f] "Return a new tree with all elements from L where F retunrs true" [do [def ret [tree/new #nil]] [let* [do [def ΓεnΣym-133 [tree/keys l]] [if ΓεnΣym-133 [while ΓεnΣym-133 [do [def e [car ΓεnΣym-133]] [def t [tree/ref l e]] [if [f t] [tree/set! ret e t] #nil] [set! ΓεnΣym-133 [cdr ΓεnΣym-133]]]] #nil]]] ret]]]][do [def val->bytecode-op [λ* val->bytecode-op [v] "" [do [def i [val->index v]] [list [int->bytecode-op [logand [>> i 16] 255]] [int->bytecode-op [logand [>> i 8] 255]] [int->bytecode-op [logand i 255]]]]]] [def sym->bytecode-op [λ* sym->bytecode-op [v] "" [do [def i [sym->index v]] [list [int->bytecode-op [logand [>> i 16] 255]] [int->bytecode-op [logand [>> i 8] 255]] [int->bytecode-op [logand i 255]]]]]] [def int-fit-in-byte? [λ* int-fit-in-byte? [a] "" [and [<= a 127] [>= a -128]]]] [def $nop [λ* $nop [] "- | Do nothing" '[#$0]]] [def $ret [λ* $ret [] "a - | Return top of value stack" '[#$1]]] [def $push/int/byte [λ* $push/int/byte [a] "- a | Return top of value stack" [do [if [int-fit-in-byte? a] #nil [throw [list :invalid-bc-op "$push/int/byte can only push a signed 8-bit value" a [current-lambda]]]] [list #$2 [int->bytecode-op a]]]]] [def $push/int [λ* $push/int [a] "- a | Return top of value stack" [if [int-fit-in-byte? a] [$push/int/byte a] [$push/lval a]]]] [def $add/int [λ* $add/int [] "a b - c | Adds the two topmost values and pushes the result" '[#$3]]] [def $debug/print-stack [λ* $debug/print-stack [] "- | Print out the stack for the current closure" '[#$4]]] [def $push/lval [λ* $push/lval [v] "- v | Pushes v onto the stack" [list #$5 [val->bytecode-op v]]]] [def $make-list [λ* $make-list [item-count] "items ... - list | Makes a list of item-count items from the stack and pushes the resulting list" [list #$6 [int->bytecode-op item-count]]]] [def $eval [λ* $eval [a] "form - | Evaluates the form from the top of the stack" '[#$7]]] [def $apply [λ* $apply [arg-count fun] "arguments ... - result | Read arg-count arguments from the stack, apply the to fun and push the result on the stack" [let* [do [def ΓεnΣym-134 arg-count] [if [== ΓεnΣym-134 #nil] do [if [== ΓεnΣym-134 2] [let* [do [def ΓεnΣym-135 fun] [if [== ΓεnΣym-135 <] [$<] [if [== ΓεnΣym-135 <=] [$<=] [if [== ΓεnΣym-135 ==] [$==] [if [== ΓεnΣym-135 >=] [$>=] [if [== ΓεnΣym-135 >] [$>] [list #$8 [int->bytecode-op arg-count] [val->bytecode-op fun]]]]]]]]] [list #$8 [int->bytecode-op arg-count] [val->bytecode-op fun]]]]]]]] [def $apply/dynamic [λ* $apply/dynamic [arg-count fun] "" [list #$1A [int->bytecode-op arg-count]]]] [def $call [λ* $call [target] " - | Call a bytecode subroutine" [list #$17 [list :relocate target 8 0 [int->bytecode-op 0]] [list :relocate target 0 1 [int->bytecode-op 0]]]]] [def $try [λ* $try [target] " - | Try something, jumping to target if an exception occurs" [list #$18 [list :relocate target 8 0 [int->bytecode-op 0]] [list :relocate target 0 1 [int->bytecode-op 0]]]]] [def $throw [λ* $throw [] " - | Return to the closest exception handler" [list #$19]]] [def $jmp [λ* $jmp [target] "" [list #$9 [list :relocate target 8 0 [int->bytecode-op 0]] [list :relocate target 0 1 [int->bytecode-op 0]]]]] [def $jt [λ* $jt [target] "" [list #$A [list :relocate target 8 0 [int->bytecode-op 0]] [list :relocate target 0 1 [int->bytecode-op 0]]]]] [def $jf [λ* $jf [target] "" [list #$B [list :relocate target 8 0 [int->bytecode-op 0]] [list :relocate target 0 1 [int->bytecode-op 0]]]]] [def $dup [λ* $dup [] "" '[#$C]]] [def $drop [λ* $drop [] "" '[#$D]]] [def $def [λ* $def [v] "" [list #$E [sym->bytecode-op v]]]] [def $set [λ* $set [v] "" [list #$F [sym->bytecode-op v]]]] [def $get [λ* $get [v] "" [list #$10 [sym->bytecode-op v]]]] [def $lambda [λ* $lambda [name args docs body] "" [list #$11 [val->bytecode-op name] [val->bytecode-op args] [val->bytecode-op docs] [val->bytecode-op body]]]] [def $macro [λ* $macro [name args docs body] "" [list #$12 [val->bytecode-op name] [val->bytecode-op args] [val->bytecode-op docs] [val->bytecode-op body]]]] [def $closure/push [λ* $closure/push [] "" '[#$13]]] [def $closure/enter [λ* $closure/enter [] "" '[#$14]]] [def $let [λ* $let [] "" '[#$15]]] [def $closure/pop [λ* $closure/pop [] "" '[#$16]]] [def $roots/push [λ* $roots/push [] "" '[#$1B]]] [def $roots/pop [λ* $roots/pop [] "" '[#$1C]]] [def $roots/peek [λ* $roots/peek [] "" '[#$1D]]] [def $< [λ* $< [] "" '[#$1E]]] [def $<= [λ* $<= [] "" '[#$1F]]] [def $== [λ* $== [] "" '[#$20]]] [def $>= [λ* $>= [] "" '[#$21]]] [def $> [λ* $> [] "" '[#$22]]] [def assemble/build-sym-map [λ* assemble/build-sym-map [code sym-map pos] "" [do [while code [do [let* [do [def ΓεnΣym-136 [type-of [car code]]] [if [== ΓεnΣym-136 :bytecode-op] [tree/set! sym-map :last-op [set! pos [+ 1 pos]]] [if [or [== ΓεnΣym-136 :symbol] [== ΓεnΣym-136 :keyword]] [and [== [car code] :label] [tree/set! sym-map [cadr code] pos]] [if [== ΓεnΣym-136 :pair] [set! pos [assemble/build-sym-map [car code] sym-map pos]] #nil]]]]] [set! code [cdr code]]]] pos]]] [def assemble/relocate-op [λ* assemble/relocate-op [code sym-map pos out] "" [do [def target [tree/ref sym-map [cadr code]]] [def off [- [+ target [cadddr code]] pos]] [array/set! out [set! pos [+ 1 pos]] [int->bytecode-op [logand [>> off [caddr code]] 255]]] pos]]] [def assemble/emit-relocated-ops [λ* assemble/emit-relocated-ops [code sym-map pos out] "" [do [if [== [car code] :relocate] [set! pos [assemble/relocate-op code sym-map pos out]] [let* [do [def ΓεnΣym-137 code] [if ΓεnΣym-137 [while ΓεnΣym-137 [do [def op [car ΓεnΣym-137]] [let* [do [def ΓεnΣym-138 [type-of op]] [if [== ΓεnΣym-138 :bytecode-op] [array/set! out [set! pos [+ 1 pos]] op] [if [== ΓεnΣym-138 :pair] [set! pos [assemble/emit-relocated-ops op sym-map pos out]] #nil]]]] [set! ΓεnΣym-137 [cdr ΓεnΣym-137]]]] #nil]]]] pos]]] [def assemble/verbose #f] [def assemble* [λ* assemble* [code] "Assemble all arguments into a single :bytecode-array" [do [def sym-map [tree/new #nil]] [and assemble/verbose [println [cat [ansi-blue "Input:\n" [str/write code]]]]] [assemble/build-sym-map code sym-map 0] [and assemble/verbose [println [cat [ansi-yellow "Symbol Map:\n" [str/write sym-map]]]]] [def out [array/allocate [tree/ref sym-map :last-op]]] [assemble/emit-relocated-ops code sym-map -1 out] [and assemble/verbose [println [cat [ansi-green "Output:\n" [str/write out]]]]] [arr->bytecode-arr out]]]] [def assemble [λ* assemble l "Assemble all arguments into a single :bytecode-array" [assemble* l]]] [def asmrun [μ* asmrun ops "Assemble and evaluate all bytecode arguments" [cons 'bytecode-eval [cons [cons 'assemble [append ops #nil]] #nil]]]]][do [def bytecompile/gen-label/counter 0] [def bytecompile/gen-label [λ* bytecompile/gen-label [prefix] "" [do [set! bytecompile/gen-label/counter [+ 1 bytecompile/gen-label/counter]] [str->sym [cat prefix "label-" bytecompile/gen-label/counter]]]]] [def bytecompile/literal [λ* bytecompile/literal [source] "" [let* [do [def ΓεnΣym-139 [type-of source]] [if [or [== ΓεnΣym-139 :symbol] [== ΓεnΣym-139 :keyword]] [if [keyword? source] [$push/lval source] [$get source]] [if [== ΓεnΣym-139 :int] [$push/int source] [$push/lval source]]]]]]] [def bytecompile/quote [λ* bytecompile/quote [source] "" [let* [do [def ΓεnΣym-140 [type-of source]] [if [== ΓεnΣym-140 :int] [$push/int source] [$push/lval source]]]]]] [def bytecompile/do/form [λ* bytecompile/do/form [source env] "" [if source [cons [cons [bytecompile* [car source] env] [if [last? source] #nil [cons [$drop] #nil]]] [bytecompile/do/form [cdr source] env]] #nil]]] [def bytecompile/do [λ* bytecompile/do [source env] "" [list [bytecompile/do/form [cdr source] env]]]] [def bytecompile/procedure [λ* bytecompile/procedure [op source env] "" [do [def args [map [cdr source] bytecompile*]] [list args [$apply [length args] op]]]]] [def bytecompile/def [λ* bytecompile/def [source env] "" [do [if [or [not [symbol? [cadr source]]] [not [cddr source]]] [throw [list :type-error "[def] needs a symbol name and a value as arguments" #nil env]] #nil] [list [bytecompile* [caddr source] env] [$def [cadr source]]]]]] [def bytecompile/set! [λ* bytecompile/set! [source env] "" [do [if [or [not [symbol? [cadr source]]] [not [cddr source]]] [throw [list :type-error "[set!] needs a symbol name and a value as arguments" #nil env]] #nil] [list [bytecompile* [caddr source] env] [$set [cadr source]]]]]] [def bytecompile/if [λ* bytecompile/if [source env] "" [let* [do [def sym-else [bytecompile/gen-label]] [def sym-after [bytecompile/gen-label]] [list [bytecompile* [cadr source] env] [$jf sym-else] [bytecompile* [caddr source] env] [$jmp sym-after] [list :label sym-else] [bytecompile* [cadddr source] env] [list :label sym-after]]]]]] [def bytecompile/while [λ* bytecompile/while [source env] "" [do [def sym-start [bytecompile/gen-label]] [def sym-end [bytecompile/gen-label]] [list [$push/int 0] [$roots/push] [list :label sym-start] [$roots/peek] [bytecompile* [cadr source] env] [$jf sym-end] [$drop] [bytecompile/do/form [cddr source] env] [$jmp sym-start] [list :label sym-end] [$roots/pop]]]]] [def bytecompile/procedure/arg [λ* bytecompile/procedure/arg [source env] "" [if [last? source] [bytecompile* [car source] env] [cons [bytecompile* [car source] env] [bytecompile/procedure/arg [cdr source] env]]]]] [def bytecompile/procedure [λ* bytecompile/procedure [op args env] "" [do [def arg-count [length args]] [if args [list [bytecompile/procedure/arg args] [$apply arg-count op]] [$apply 0 op]]]]] [def bytecompile/procedure/dynamic [λ* bytecompile/procedure/dynamic [op args env] "" [do [def arg-count [length args]] [list [bytecompile* op env] [if args [bytecompile/procedure/arg args] #nil] [$apply/dynamic arg-count]]]]] [def bytecompile/and/rec [λ* bytecompile/and/rec [source env label-end] "" [list [bytecompile* [car source] env] [if [cdr source] [list [$dup] [$jf label-end] [$drop] [bytecompile/and/rec [cdr source] env label-end]] #nil]]]] [def bytecompile/and [λ* bytecompile/and [source env] "" [do [def label-end [bytecompile/gen-label]] [list [bytecompile/and/rec [cdr source] env label-end] [list :label label-end]]]]] [def bytecompile/or/rec [λ* bytecompile/or/rec [source env label-end] "" [if source [list [bytecompile* [car source] env] [$dup] [$jt label-end] [$drop] [bytecompile/or/rec [cdr source] env label-end]] #nil]]] [def bytecompile/or [λ* bytecompile/or [source env] "" [do [def label-end [bytecompile/gen-label]] [list [bytecompile/or/rec [cdr source] env label-end] [$push/lval #f] [list :label label-end]]]]] [def bytecompile/string [λ* bytecompile/string [source env] "" [bytecompile/procedure cat source env]]] [def bytecompile/array [λ* bytecompile/array [source env] "" [bytecompile/procedure array/ref source env]]] [def bytecompile/tree [λ* bytecompile/tree [source env] "" [bytecompile/procedure tree/ref source env]]] [def bytecompile/λ* [λ* bytecompile/λ* [source env] "" [apply $lambda [cdr source]]]] [def bytecompile/μ* [λ* bytecompile/μ* [source env] "" [apply $macro [cdr source]]]] [def bytecompile/ω* [λ* bytecompile/ω* [source env] "" [list [$let] [bytecompile/do [cdr source] env] [$closure/push] [$closure/pop]]]] [def bytecompile/let* [λ* bytecompile/let* [source env] "" [list [$let] [bytecompile/do [cadr source] env] [$closure/pop]]]] [def bytecompile/try [λ* bytecompile/try [source env] "" [do [def handler-sym [bytecompile/gen-label]] [def end-sym [bytecompile/gen-label]] [list [bytecompile* [cadr source] env] [$try handler-sym] [bytecompile/do/form [cddr source] env] [$jmp end-sym] [list :label handler-sym] [$apply/dynamic 1] [list :label end-sym]]]]] [def bytecompile* [λ* bytecompile* [source env] "Compile the forms in source" [do [def op [if [resolves? [car source] env] [resolve [car source] env] [car source]]] [let* [do [def ΓεnΣym-141 [type-of op]] [if [== ΓεnΣym-141 :special-form] [let* [do [def ΓεnΣym-142 op] [if [== ΓεnΣym-142 do] [bytecompile/do source env] [if [== ΓεnΣym-142 let*] [bytecompile/let* source env] [if [== ΓεnΣym-142 def] [bytecompile/def source env] [if [== ΓεnΣym-142 set!] [bytecompile/set! source env] [if [== ΓεnΣym-142 if] [bytecompile/if source env] [if [== ΓεnΣym-142 while] [bytecompile/while source env] [if [== ΓεnΣym-142 and] [bytecompile/and source env] [if [== ΓεnΣym-142 or] [bytecompile/or source env] [if [== ΓεnΣym-142 λ*] [bytecompile/λ* source env] [if [== ΓεnΣym-142 μ*] [bytecompile/μ* source env] [if [== ΓεnΣym-142 ω*] [bytecompile/ω* source env] [if [== ΓεnΣym-142 try] [bytecompile/try source env] [if [== ΓεnΣym-142 quote] [bytecompile/quote [cadr source]] [throw [list :unknown-special-form "The compiler does not know the current special form, please fix the compiler!" [car source]]]]]]]]]]]]]]]]]] [if [or [== ΓεnΣym-141 :lambda] [== ΓεnΣym-141 :native-function]] [bytecompile/procedure op [cdr source] env] [if [or [== ΓεnΣym-141 :pair] [== ΓεnΣym-141 :symbol]] [bytecompile/procedure/dynamic op [cdr source] env] [if [== ΓεnΣym-141 :string] [bytecompile/string source env] [if [== ΓεnΣym-141 :array] [bytecompile/array source env] [if [== ΓεnΣym-141 :tree] [bytecompile/tree source env] [bytecompile/literal source]]]]]]]]]]]] [def bytecompile [λ* bytecompile [form environment] "" [list [bytecompile* form environment] [$ret]]]] [def byterun [μ* byterun [form] "" [cons '-> [cons [cons 'compile [cons form #nil]] [cons 'bytecompile [cons 'assemble* [cons 'bytecode-eval #nil]]]]]]]][do [def compile/environment [current-closure]] [def compile/verbose #f] [def compile/do/args [λ* compile/do/args [args] "" [if [last? args] [cons [compile* [car args]] #nil] [if [pair? [car args]] [let* [do [def ocar [compile* [car args]]] [if [pair? ocar] [cons ocar [compile/do/args [cdr args]]] [compile/do/args [cdr args]]]]] [compile/do/args [cdr args]]]]]] [def compile/do [λ* compile/do [source] "" [let* [do [def args [compile/do/args source]] [if [last? args] [car args] [cons 'do args]]]]]] [def compile/def [λ* compile/def [source] "" [list 'def [cadr source] [compile* [caddr source]]]]] [def compile/set! [λ* compile/set! [source] "" [list 'set! [cadr source] [compile* [caddr source]]]]] [def compile/λ* [λ* compile/λ* [source] "" [list 'λ* [cadr source] [caddr source] [cadddr source] [compile [caddddr source]]]]] [def compile/λδ* [λ* compile/λδ* [source] "" [list 'λδ* [cadr source] [caddr source] [cadddr source] [compile [caddddr source]]]]] [def compile/μ* [λ* compile/μ* [source] "" [list 'μ* [cadr source] [caddr source] [cadddr source] [compile [caddddr source]]]]] [def compile/ω* [λ* compile/ω* [source] "" [list 'ω* [compile/do [cdr source]]]]] [def compile/try [λ* compile/try [source] "" [list 'try [compile* [cadr source]] [compile/do [cddr source]]]]] [def compile/if [λ* compile/if [source] "" [list 'if [compile* [cadr source]] [compile* [caddr source]] [compile* [cadddr source]]]]] [def compile/let* [λ* compile/let* [source] "" [list 'let* [compile/do [cdr source]]]]] [def compile/and [λ* compile/and [source] "" [compile/procedure/arg source]]] [def compile/or [λ* compile/or [source] "" [compile/procedure/arg source]]] [def compile/while [λ* compile/while [source] "" [list 'while [compile* [cadr source]] [compile/do [cddr source]]]]] [def compile/macro [λ* compile/macro [macro source] "" [compile* [macro-apply macro [cdr source]]]]] [def compile/procedure/arg [λ* compile/procedure/arg [source] "" [if [pair? source] [cons [compile* [car source]] [compile/procedure/arg [cdr source]]] #nil]]] [def compile/procedure [λ* compile/procedure [proc source] "" [compile/procedure/arg source]]] [def compile* [λ* compile* [source] "Compile the forms in source" [let* [do [def op [if [apply compile/environment [cons 'do [cons [cons 'resolves? [cons [list 'quote [car source]] #nil]] #nil]]] [apply compile/environment [cons 'do [cons [cons 'resolve [cons [list 'quote [car source]] #nil]] #nil]]] [car source]]] [let* [do [def ΓεnΣym-143 [type-of op]] [if [== ΓεnΣym-143 :special-form] [let* [do [def ΓεnΣym-144 op] [if [== ΓεnΣym-144 do] [compile/do source] [if [== ΓεnΣym-144 def] [compile/def source] [if [== ΓεnΣym-144 set!] [compile/set! source] [if [== ΓεnΣym-144 let*] [compile/let* source] [if [== ΓεnΣym-144 λ*] [compile/λ* source] [if [== ΓεnΣym-144 λδ*] [compile/λδ* source] [if [== ΓεnΣym-144 μ*] [compile/μ* source] [if [== ΓεnΣym-144 ω*] [compile/ω* source] [if [== ΓεnΣym-144 if] [compile/if source] [if [== ΓεnΣym-144 try] [compile/try source] [if [== ΓεnΣym-144 and] [compile/and source] [if [== ΓεnΣym-144 or] [compile/or source] [if [== ΓεnΣym-144 while] [compile/while source] [if [== ΓεnΣym-144 quote] source [throw [list :unknown-special-form "The compiler does not know the current special form, please fix the compiler!" [car source]]]]]]]]]]]]]]]]]]] [if [== ΓεnΣym-143 :macro] [compile/macro op source] [if [or [== ΓεnΣym-143 :lambda] [== ΓεnΣym-143 :native-function]] [compile/procedure op source] [if [== ΓεnΣym-143 :object] [compile/procedure/arg source] [if [== ΓεnΣym-143 :pair] [compile/procedure/arg source] [if [or [== ΓεnΣym-143 :int] [== ΓεnΣym-143 :float] [== ΓεnΣym-143 :vec]] [compile/procedure/arg source] [if [== ΓεnΣym-143 :array] [compile/procedure/arg source] [if [== ΓεnΣym-143 :string] [compile/procedure/arg source] [if [== ΓεnΣym-143 :tree] [compile/procedure/arg source] [if [last? source] source [compile/procedure/arg source]]]]]]]]]]]]]]]]] [def compile [λ* compile [source new-environment new-verbose] "Compile the forms in source" [do [if new-environment #nil [set! new-environment [current-closure]]] [if new-verbose #nil [set! new-verbose #f]] [set! compile/environment new-environment] [set! compile/verbose new-verbose] [compile* source]]]] [def load/forms [λ* load/forms [source-raw environment] "Load multiple forms, evaluating the results in environment, so we can make use of macros we just defined" [do [def source #nil] [def source-next source-raw] [def forms-compiled 0] [def try-again [λ* try-again [source] "" [set! source-next [cons source source-next]]]] [while source-next [do [def forms-compiled-last forms-compiled] [set! source source-next] [set! source-next #nil] [def errors #nil] [let* [do [def ΓεnΣym-145 source] [if ΓεnΣym-145 [while ΓεnΣym-145 [do [def form [car ΓεnΣym-145]] [try [λ* #nil [err] "" [do [set! errors [cons err errors]] [let* [do [def ΓεnΣym-146 [car err]] [if [== ΓεnΣym-146 :unresolved-procedure] [try-again [car source]] [if [== ΓεnΣym-146 :runtime-macro] [try-again [car source]] [throw err]]]]]]] [do [def compiled-form [compile form environment #t]] [if compiled-form [do [apply environment [cons 'eval* [cons compiled-form #nil]]] [set! forms-compiled [+ 1 forms-compiled]]] #nil]]] [set! ΓεnΣym-145 [cdr ΓεnΣym-145]]]] #nil]]] [set! source-next [nreverse source-next]] [if [<= forms-compiled forms-compiled-last] [do [for-each errors display/error] [throw [list :you-can-not-advance "The compiler got stuck trying to compile various forms, the final pass did not have a single form that compiled without errors"]]] #nil]]]]]] [def compile/forms [λ* compile/forms [source-raw environment] "Compile multiple forms, evaluation the results in a temporary environment, so we can make use of macros we just defined" [do [if environment #nil [set! environment [ω* #nil]]] [load/forms source-raw environment] [compile source-raw environment]]]] [def defmacro [μ* defmacro [name args . body] "Define a new macro" [do [def doc-string [if [string? [car body]] [car body] ""]] [list 'def name [compile [list 'μ* name args doc-string [cons 'do body]] [current-closure]]]]]] [def defun [μ* defun [name args . body] "Define a new function" [do [def doc-string [if [string? [car body]] [car body] ""]] [list 'def name [compile [list 'λ* name args doc-string [cons 'do body]] [current-closure]]]]]] [def μ [μ* μ [args . body] "Define a λ with the self-hosting Nujel compiler" [do [def doc-string [if [string? [car body]] [car body] ""]] [compile [list 'μ* #nil args doc-string [cons 'do body]] [current-closure]]]]] [def \ [μ* \ [args . body] "Define a λ with the self-hosting Nujel compiler" [do [def doc-string [if [string? [car body]] [car body] ""]] [compile [list 'λ* #nil args doc-string [cons 'do body]] [current-closure]]]]] [def λ \] [def λδ [μ* λδ [args . body] "Define a λδ with the self-hosting Nujel compiler" [do [def doc-string [if [string? [car body]] [car body] ""]] [cons 'λδ* [cons #nil [cons args [cons doc-string [cons [assemble* [bytecompile [compile [cons 'do body] [current-closure]]]] #nil]]]]]]]] [def defnd [μ* defnd [name args . body] "Define a new bytecoded function" [do [def doc-string [if [string? [car body]] [car body] ""]] [list 'def name [cons 'λδ* [cons name [cons args [cons doc-string [cons [assemble* [bytecompile [compile [cons 'do body] [current-closure]]]] #nil]]]]]]]]] [def ω [μ* ω body "Defines and returns new object after evaluating body within" [compile [cons 'ω* body]]]] [def defobj ω] [def eval [μ* eval [expr] "Compile, Evaluate and then return the result of EXPR" [cons 'eval* [cons [cons 'compile [cons expr [cons [cons 'current-closure #nil] #nil]]] #nil]]]] [def eval-compile [λ* eval-compile [expr closure] "Compile and the immediatly evaluate the result, mostly used by lRun()" [try display/error [eval* [compile expr closure]]]]] [def read-eval-compile [λ* read-eval-compile [expr closure] "Compile and the immediatly evaluate the result, mostly used by lRun()" [try display/error [eval* [compile [read expr] closure]]]]] [def eval-load [λ* eval-load [expr closure] "Compile and the immediatly evaluate the result, mostly used by lRun()" [try display/error [load/forms expr closure]]]] [def read-eval-load [λ* read-eval-load [expr closure] "Compile and the immediatly evaluate the result, mostly used by lRun()" [try display/error [load/forms [read expr] closure]]]] [def optimize/code/rest [λ* optimize/code/rest [code] "" [if [pair? code] [cons [optimize/code [car code]] [optimize/code/rest [cdr code]]] code]]] [def optimize/code [λ* optimize/code [code] "" [if [pair? code] [if [and [symbol? [car code]] [resolves? [car code]]] [cons [resolve [car code]] [optimize/code/rest [cdr code]]] [cons [optimize/code [car code]] [optimize/code/rest [cdr code]]]] code]]] [def optimize! [λ* optimize! [fun] "Optimize FUN via mutation" [if [lambda? fun] [closure! fun [tree/new :code [optimize/code [tree/ref [closure fun] :code]]]] #f]]] [def optimize-all! [λ* optimize-all! [] "Return a list of all lambdas in CTX" [for-each [filter [map [symbol-table] resolve] lambda?] optimize!]]]][do [def disassemble/length [λ* disassemble/length [op] "Return the length in bytes of a bytecode operation and all its arguments" [let* [do [def ΓεnΣym-57 op] [if [or [== ΓεnΣym-57 #$0] [== ΓεnΣym-57 #$1] [== ΓεnΣym-57 #$3] [== ΓεnΣym-57 #$4] [== ΓεnΣym-57 #$7] [== ΓεnΣym-57 #$C] [== ΓεnΣym-57 #$D] [== ΓεnΣym-57 #$13] [== ΓεnΣym-57 #$14] [== ΓεnΣym-57 #$15] [== ΓεnΣym-57 #$16] [== ΓεnΣym-57 #$19] [== ΓεnΣym-57 #$1B] [== ΓεnΣym-57 #$1C] [== ΓεnΣym-57 #$1D] [== ΓεnΣym-57 #$1E] [== ΓεnΣym-57 #$1F] [== ΓεnΣym-57 #$20] [== ΓεnΣym-57 #$21] [== ΓεnΣym-57 #$22]] 1 [if [or [== ΓεnΣym-57 #$2] [== ΓεnΣym-57 #$6] [== ΓεnΣym-57 #$1A]] 2 [if [or [== ΓεnΣym-57 #$9] [== ΓεnΣym-57 #$A] [== ΓεnΣym-57 #$B] [== ΓεnΣym-57 #$17] [== ΓεnΣym-57 #$18]] 3 [if [or [== ΓεnΣym-57 #$5] [== ΓεnΣym-57 #$E] [== ΓεnΣym-57 #$F] [== ΓεnΣym-57 #$10]] 4 [if [or [== ΓεnΣym-57 #$8]] 5 [if [or [== ΓεnΣym-57 #$11] [== ΓεnΣym-57 #$12]] 13 [throw [list :unknown-op "This op needs its length specified for disassembly to work" op [current-lambda]]]]]]]]]]]]] [def bytecode/nil-catcher [λ* bytecode/nil-catcher [error] "" [if [== [car error] :argument-mismatch] #nil [throw error]]]] [def bytecode-op->val [λ* bytecode-op->val [a b c] "Turn three bytecode ops representing an encoded value into an actual value" [index->val [logior [<< [bytecode-op->int a] 16] [<< [bytecode-op->int b] 8] [bytecode-op->int c]]]]] [def bytecode-arr->val [λ* bytecode-arr->val [a i] "Read a bytecode encoded value in A at I and return it" [try bytecode/nil-catcher [bytecode-op->val [ref a i] [ref a [+ 1 i]] [ref a [+ 2 i]]]]]] [def bytecode-op->sym [λ* bytecode-op->sym [a b c] "Turn three bytecode ops representing an encoded symbol into an actual symbol" [index->sym [logior [<< [bytecode-op->int a] 16] [<< [bytecode-op->int b] 8] [bytecode-op->int c]]]]] [def bytecode-arr->sym [λ* bytecode-arr->sym [a i] "Read a bytecode encoded symbol in A at I and return it" [try bytecode/nil-catcher [bytecode-op->sym [ref a i] [ref a [+ 1 i]] [ref a [+ 2 i]]]]]] [def bytecode-op->offset [λ* bytecode-op->offset [a b] "Turn two bytecode ops encoding an offset into the integer representation" [do [def t [logior [<< [bytecode-op->int a] 8] [bytecode-op->int b]]] [if [> t 32768] [- [- 65536 t]] t]]]] [def bytecode-arr->offset [λ* bytecode-arr->offset [a i] "Read a bytecode encoded offset in A at I and return it as a signed integer" [bytecode-op->offset [ref a i] [ref a [+ 1 i]]]]] [def disassemble/op [λ* disassemble/op [a i] "Disassemble a single bytecode op in A at I and return it as an s-expression, that could be applied to eval" [let* [do [def ΓεnΣym-147 [ref a i]] [if [== ΓεnΣym-147 #$0] '[$nop] [if [== ΓεnΣym-147 #$1] '[$ret] [if [== ΓεnΣym-147 #$2] [cons '$push/int/byte [cons [bytecode-op->int [ref a [+ i 1]]] #nil]] [if [== ΓεnΣym-147 #$3] '[$add/int] [if [== ΓεnΣym-147 #$4] '[$debug/print-stack] [if [== ΓεnΣym-147 #$5] [cons '$push/lval [cons [bytecode-arr->val a [+ i 1]] #nil]] [if [== ΓεnΣym-147 #$6] [cons '$make-list [cons [bytecode-op->int [ref a [+ i 1]]] #nil]] [if [== ΓεnΣym-147 #$7] '[$eval] [if [== ΓεnΣym-147 #$8] [cons '$apply [cons [bytecode-op->int [ref a [+ i 1]]] [cons [bytecode-arr->val a [+ i 2]] #nil]]] [if [== ΓεnΣym-147 #$9] [cons '$jmp* [cons [bytecode-arr->offset a [+ i 1]] #nil]] [if [== ΓεnΣym-147 #$A] [cons '$jt* [cons [bytecode-arr->offset a [+ i 1]] #nil]] [if [== ΓεnΣym-147 #$B] [cons '$jf* [cons [bytecode-arr->offset a [+ i 1]] #nil]] [if [== ΓεnΣym-147 #$C] '[$dup] [if [== ΓεnΣym-147 #$D] '[$drop] [if [== ΓεnΣym-147 #$E] [cons '$def [cons [bytecode-arr->sym a [+ i 1]] #nil]] [if [== ΓεnΣym-147 #$F] [cons '$set [cons [bytecode-arr->sym a [+ i 1]] #nil]] [if [== ΓεnΣym-147 #$10] [cons '$get [cons [bytecode-arr->sym a [+ i 1]] #nil]] [if [== ΓεnΣym-147 #$11] [cons '$lambda [cons [bytecode-arr->val a [+ i 1]] [cons [bytecode-arr->val a [+ i 4]] [cons [bytecode-arr->val a [+ i 7]] [cons [bytecode-arr->val a [+ i 10]] #nil]]]]] [if [== ΓεnΣym-147 #$12] [cons '$macro [cons [bytecode-arr->val a [+ i 1]] [cons [bytecode-arr->val a [+ i 4]] [cons [bytecode-arr->val a [+ i 7]] [cons [bytecode-arr->val a [+ i 10]] #nil]]]]] [if [== ΓεnΣym-147 #$13] '[$closure/push] [if [== ΓεnΣym-147 #$14] '[$closure/enter] [if [== ΓεnΣym-147 #$15] '[$let] [if [== ΓεnΣym-147 #$16] '[$closure/pop] [if [== ΓεnΣym-147 #$17] [cons '$call [cons [bytecode-arr->offset a [+ i 1]] #nil]] [if [== ΓεnΣym-147 #$18] [cons '$try [cons [bytecode-arr->offset a [+ i 1]] #nil]] [if [== ΓεnΣym-147 #$19] '[$throw] [if [== ΓεnΣym-147 #$1A] [cons '$apply/dynamic [cons [bytecode-op->int [ref a [+ i 1]]] #nil]] [if [== ΓεnΣym-147 #$1B] [cons '$roots/push #nil] [if [== ΓεnΣym-147 #$1C] [cons '$roots/pop #nil] [if [== ΓεnΣym-147 #$1D] [cons '$roots/peek #nil] [if [== ΓεnΣym-147 #$1E] [cons '$< #nil] [if [== ΓεnΣym-147 #$1F] [cons '$<= #nil] [if [== ΓεnΣym-147 #$20] [cons '$== #nil] [if [== ΓεnΣym-147 #$21] [cons '$>= #nil] [if [== ΓεnΣym-147 #$22] [cons '$> #nil] :unknown-op]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]] [def disassemble/array [λ* disassemble/array [a i] "Disassemble all bytecode operations in the plain array A starting at I, turning it into an assembler S-Expression and return it as a dotted pair, with the car containing the offset and the cdr containing the S-Expression" [do [def ret #nil] [while [< i [array/length a]] [do [set! ret [cons [cons i [disassemble/op a i]] ret]] [set! i [+ i [disassemble/length [ref a i]]]]]] [nreverse ret]]]] [def disassemble [λ* disassemble [code] "Disassemble the bytecode array CODE, turning it into a list of dotted pairs, with the car containing the offset and the cdr containing assembler S-Expressions," [disassemble/array [bytecode-arr->arr code] 0]]] [def disassemble/raw [λ* disassemble/raw [bc] "Disassemble the bytecode array CODE, turning it into a list of dotted pairs, with the car containing the offset and the cdr containing assembler S-Expressions," [for-each [disassemble bc] [λ* #nil [a] "" [println [cat [ansi-blue [string/pad-start [string [car a]] 6]] " - " [cdr a]]]]]]] [def disassemble/test [λ* disassemble/test [asm] "Verbose way of testing the disassembler" [do [println [ansi-blue "--------- Assembly -----------"]] [def cur-line 0] [for-each asm [λ* #nil [a] "" [println [cat [ansi-yellow [string/pad-start [set! cur-line [+ 1 cur-line]] 6]] " - " a]]]] [println [ansi-yellow "--------- Raw Bytecode -----------"]] [def bc [apply assemble asm]] [println [str/write bc]] [println [ansi-green "--------- Now for the disassembly -----------"]] [for-each [disassemble bc] [λ* #nil [a] "" [println [cat [ansi-blue [string/pad-start [string [car a]] 6]] " - " [cdr a]]]]] [println [ansi-red "--------- Fin -----------\n"]] [try display/error [println [str/write [bytecode-eval bc]]]]]]]][do [def yield-queue #nil] [def yield [λ* yield [pred fun] "Evaluates FUN once PRED is true" [do [set! yield-queue [cons [cons pred fun] yield-queue]] #t]]] [def yield-run [λ* yield-run [] "Executes pending coroutines if their predicate evaluates to #t" [do [def new #nil] [let* [do [def ΓεnΣym-148 yield-queue] [if ΓεnΣym-148 [while ΓεnΣym-148 [do [def cur [car ΓεnΣym-148]] [if [[car cur]] [[cdr cur]] [set! new [cons cur new]]] [set! ΓεnΣym-148 [cdr ΓεnΣym-148]]]] #nil]]] [set! yield-queue new]]]] [def timeout [λ* timeout [milliseconds] "Returns a function that evaluates to true once MILLISECONDS have passed" [do [def goal [+ [time/milliseconds] milliseconds]] [λ* #nil [] "" [> [time/milliseconds] goal]]]]] [def event-bind [λ* event-bind [event id handler] "Bind handler to be evaluated when event-name fires, overwriting whichever handler has been associated with id before." [tree/set! event id handler]]] [def event-clear [μ* event-clear [event] "Clears all event handlers for event-name" [cons 'set! [cons event [cons [cons 'tree/new [cons #nil #nil]] #nil]]]]] [def event-fire [λ* event-fire [event . val] "Applies ...val to all event handlers associated with event-name" [let* [do [def ΓεnΣym-149 [tree/values event]] [if ΓεnΣym-149 [while ΓεnΣym-149 [do [def h [car ΓεnΣym-149]] [h val] [set! ΓεnΣym-149 [cdr ΓεnΣym-149]]]] #nil]]]]]][do [def let/arg [λ* let/arg [arg] "" [if arg [do [if [pair? arg] #nil [throw [cons :invalid-let-form [cons "Please fix the structure of the let form" [cons arg #nil]]]]] [if [symbol? [car arg]] #nil [throw [cons :invalid-let-form [cons "Please fix the structure of the let form" [cons arg #nil]]]]] [cons 'def [cons [car arg] [cons [cadr arg] #nil]]]] #nil]]] [def let/args [λ* let/args [args] "" [if args [cons [let/arg [car args]] [let/args [cdr args]]] #nil]]] [def let [μ* let [bindings . body] "Evalutes to BODY if PRED is true" [cons 'let* [cons [cons 'do [append [let/args bindings] [append body #nil]]] #nil]]]] [def if-let [μ* if-let [binding then else] "" [cons 'let* [cons [cons 'def [cons [car binding] [cons [cadr binding] #nil]]] [cons [cons 'if [cons [car binding] [cons then [cons else #nil]]]] #nil]]]]] [def when-let [μ* when-let [binding . body] "" [cons 'if-let [cons binding [cons [cons 'do body] [cons #nil #nil]]]]]]][do [def comment [μ* comment body "Does nothing" #nil]] [def += [μ* += [val inc] "" [cons 'set! [cons val [cons [cons '+ [cons val [cons inc #nil]]] #nil]]]]] [def cdr! [μ* cdr! [l] "[set! l [cdr l]]" [cons 'set! [cons l [cons [cons 'cdr [cons l #nil]] #nil]]]]] [def not [λ* not [v] "Return true if V is false" [if v #f #t]]] [def identity [λ* identity [α] "Returns its argument" α]] [def list [λ* list arguments "Return ARGUMENTS as a list" arguments]] [def default [λ* default [arg default-value] "Returns ARG or DEFAULT-VALUE if ARG is #nil" [if arg arg default-value]]] [def caar [λ* caar [p] "[car [car p]]" [car [car p]]]] [def cadr [λ* cadr [p] "[car [cdr p]]" [car [cdr p]]]] [def cdar [λ* cdar [p] "[cdr [car p]]" [cdr [car p]]]] [def cddr [λ* cddr [p] "[cdr [cdr p]]" [cdr [cdr p]]]] [def cadar [λ* cadar [p] "[cdr [car p]]" [car [cdr [car p]]]]] [def caddr [λ* caddr [p] "[car [cdr [cdr p]]]" [car [cdr [cdr p]]]]] [def cdddr [λ* cdddr [p] "[cdr [cdr [cdr p]]]" [cdr [cdr [cdr p]]]]] [def cadddr [λ* cadddr [p] "[car [cdr [cdr [cdr p]]]]" [car [cdr [cdr [cdr p]]]]]] [def caddddr [λ* caddddr [p] "[car [cdr [cdr [cdr p]]]]" [car [cdr [cdr [cdr [cdr p]]]]]]]][do [def if-not [μ* if-not [pred then else] "" [cons 'if [cons pred [cons else [cons then #nil]]]]]] [def when-not [μ* when-not [pred . body] "Evalutes to BODY if PRED is false" [cons 'if [cons pred [cons #nil [cons [cons 'do [append body #nil]] #nil]]]]]] [def when [μ* when [pred . body] "Evalutes to BODY if PRED is true" [cons 'if [cons pred [cons [cons 'do [append body #nil]] [cons #nil #nil]]]]]] [def case/clauses/multiple [λ* case/clauses/multiple [key-sym cases] "" [if cases [cons [list '== key-sym [car cases]] [case/clauses/multiple key-sym [cdr cases]]] #nil]]] [def case/clauses [λ* case/clauses [key-sym clauses] "" [if clauses [if [== [caar clauses] 'otherwise] [cons 'do [cdar clauses]] [list 'if [if [pair? [caar clauses]] [if [and [== [car [caar clauses]] 'quote] [last? [cdr [caar clauses]]] [symbol? [cadr [caar clauses]]]] [list '== key-sym [caar clauses]] [cons 'or [case/clauses/multiple key-sym [caar clauses]]]] [list '== key-sym [caar clauses]]] [cons 'do [cdar clauses]] [case/clauses key-sym [cdr clauses]]]] #nil]]] [def case [μ* case [key-form . clauses] "" [do [def key-sym [gensym]] [list 'let* [list 'def key-sym key-form] [case/clauses key-sym clauses]]]]] [def cond [μ* cond body "Contains multiple cond clauses" [if [and body [caar body]] [list 'if [caar body] [cons 'do [cdar body]] [macro-apply cond [cdr body]]] #nil]]] [def for [μ* for [for-loop . body] "For loops, [for [name start stop] body]" [do [def symbol-name [car for-loop]] [def loop-start [cadr for-loop]] [def loop-stop [caddr for-loop]] [def stop-var [gensym]] [def dir 1] [if [cadddr for-loop] [set! dir [cadddr for-loop]] #nil] [if [symbol? symbol-name] #nil [throw [list :invalid-for "Expected a symbol name within the for loop" symbol-name]]] [if loop-start #nil [throw [list :invalid-for "Expected a start value at the second position" for-loop]]] [if loop-stop #nil [throw [list :invalid-for "Expected a stop value at the third position" for-loop]]] [def pred [if [> dir 0] < >]] [cons 'let [cons [cons [cons symbol-name [cons loop-start #nil]] [cons [cons stop-var [cons loop-stop #nil]] #nil]] [cons [cons 'while [cons [cons pred [cons symbol-name [cons stop-var #nil]]] [append body [cons [cons 'set! [cons symbol-name [cons [cons 'add [cons dir [cons symbol-name #nil]]] #nil]]] #nil]]]] #nil]]]]]] [def for-in [μ* for-in [for-loop . body] "[for-in [l [list 1 2 3 4]] [println l]]" [do [def symbol-name [gensym]] [cons 'let [cons [cons [cons symbol-name [cons [cadr for-loop] #nil]] #nil] [cons [cons 'when [cons symbol-name [cons [cons 'while [cons symbol-name [cons [cons 'def [cons [car for-loop] [cons [cons 'car [cons symbol-name #nil]] #nil]]] [append body [cons [cons 'cdr! [cons symbol-name #nil]] #nil]]]]] #nil]]] #nil]]]]]] [def thread/-> [λ* thread/-> [init fun] "" [if fun [if [pair? [car fun]] [cons [caar fun] [cons [thread/-> init [cdr fun]] [append [cdar fun] #nil]]] [list [car fun] [thread/-> init [cdr fun]]]] init]]] [def -> [μ* -> [init . fun] "Thread init as the first argument through every function in fun" [thread/-> init [reverse fun]]]] [def thread/->> [λ* thread/->> [init fun] "" [if fun [append [car fun] [cons [thread/->> init [cdr fun]] #nil]] init]]] [def ->> [μ* ->> [init . fun] "Thread init as the last argument through every function in fun" [thread/->> init [reverse fun]]]] [def returnable/λ [λ* returnable/λ [e] "" [if [== [car e] :return] [cdr e] [throw e]]]] [def returnable [μ* returnable body "" [cons 'try [cons 'returnable/λ [append body #nil]]]]] [def return [μ* return [v] "" [cons 'throw [cons [cons 'cons [cons :return [cons v #nil]]] #nil]]]]][do [def numeric? [λ* numeric? [a] "Return #t if a is a number" [or [int? a] [float? a] [vec? a]]]] [def last? [λ* last? [a] "Return #t if a is the last pair in a list" [nil? [cdr a]]]] [def pos? [λ* pos? [a] "Return #t if a is positive" [and [numeric? a] [>= [float a] 0.0]]]] [def zero-neg? [λ* zero-neg? [a] "Return #t if a is zero or negative" [and [numeric? a] [<= [float a] 0.0]]]] [def neg? [λ* neg? [a] "Returns #t if a is negative" [and [numeric? a] [< [float a] 0.0]]]] [def odd? [λ* odd? [a] "Predicate that returns #t if a is odd" [== [% [int a] 2] 1]]] [def even? [λ* even? [a] "Predicate that returns #t if a is even" [== [mod [int a] 2] 0]]] [def zero? [λ* zero? [val] "#t if VAL is zero" [== 0 val]]] [def not-zero? [λ* not-zero? [val] "#t if VAL is not zero" [!= 0 val]]] [def equal? [λ* equal? [a b] "High level equality comparator, can also recursively test lists/arrays for equivalence, can be slow." [do [def cur-type [type-of a]] [if [!= cur-type [type-of b]] #f [let* [do [def ΓεnΣym-150 cur-type] [if [== ΓεnΣym-150 :array] [array/equal? a b] [if [== ΓεnΣym-150 :tree] [tree/equal? a b] [if [== ΓεnΣym-150 :pair] [list/equal? a b] [== a b]]]]]]]]]] [def inequal? [λ* inequal? [a b] "High level inequality comparator" [not [equal? a b]]]] [def int? [λ* int? [val] "#t if VAL is a integer" [== :int [type-of val]]]] [def float? [λ* float? [val] "#t if VAL is a floating-point number" [== :float [type-of val]]]] [def vec? [λ* vec? [val] "#t if VAL is a vector" [== :vec [type-of val]]]] [def bool? [λ* bool? [val] "#t if VAL is a boolean" [== :bool [type-of val]]]] [def pair? [λ* pair? [val] "#t if VAL is a pair" [== :pair [type-of val]]]] [def array? [λ* array? [val] "#t if VAL is an array" [== :array [type-of val]]]] [def string? [λ* string? [val] "#t if VAL is a string" [== :string [type-of val]]]] [def symbol? [λ* symbol? [val] "#t if VAL is a symbol" [== :symbol [type-of val]]]] [def object? [λ* object? [val] "#t if VAL is an object" [== :object [type-of val]]]] [def tree? [λ* tree? [val] "#t if VAL is an object" [== :tree [type-of val]]]] [def macro? [λ* macro? [val] "#t if VAL is an object" [== :macro [type-of val]]]] [def lambda? [λ* lambda? [val] "#t if VAL is a lambda" [or [== :lambda [type-of val]]]]] [def native? [λ* native? [val] "#t if VAL is a native function" [== :native-function [type-of val]]]] [def special-form? [λ* special-form? [val] "#t if VAL is a native function" [== :special-form [type-of val]]]] [def procedure? [λ* procedure? [val] "#t if VAL is a native or lisp function" [or [lambda? val] [native? val] [special-form? val]]]] [def bytecode-array? [λ* bytecode-array? [v] "" [== :bytecode-array [type-of v]]]] [def bytecode-op? [λ* bytecode-op? [v] "" [== :bytecode-op [type-of v]]]] [def in-range? [λ* in-range? [v min max] "" [and [>= v min] [<= v max]]]]][do [def quasiquote-real [λ* quasiquote-real [l depth] "" [if [nil? l] #nil [if [pair? l] [if [== [caar l] 'unquote-splicing] [if [zero? depth] [list 'append [cadr [car l]] [quasiquote-real [cdr l] depth]] [list 'unquote-splicing [quasiquote-real [cadr l] [+ -1 depth]]]] [if [== [car l] 'unquote] [if [zero? depth] [cadr l] [list 'unquote [quasiquote-real [cadr l] [+ -1 depth]]]] [if [== [car l] 'quasiquote] [quasiquote-real [quasiquote-real [cadr l] [+ 1 depth]] depth] [if [zero? depth] [list 'cons [quasiquote-real [car l] depth] [quasiquote-real [cdr l] depth]] [cons [quasiquote-real [car l] depth] [quasiquote-real [cdr l] depth]]]]]] [if [and [zero? depth] [symbol? l]] [cons 'quote [cons l]] l]]]]] [def quasiquote [μ* quasiquote [l] "" [quasiquote-real l 0]]] [def unquote [λ* unquote [expr] "" [throw [list :unquote-without-quasiquote "unquote should only occur inside a quasiquote, never evaluated directly"]]]] [def unquote-splicing [λ* unquote-splicing [expr] "" [throw [list :unquote-splicing-without-quasiq "unquote-splicing should only occur inside a quasiquote, never evaluated directly"]]]]][do [def describe/closure [λ* describe/closure [c i] "" [if c [do [def info [closure c]] [if [and info [ref info :call]] [cat [ansi-blue [cat [int i] "# " [str/write c]]] " - " [str/write [ref info :data]] "\r\n" [describe/closure [closure-caller c] [+ [int i] 1]]] #nil]] #nil]]] [def stacktrace [λ* stacktrace [] "" [display [describe/closure [closure-caller [current-lambda]]]]]]][do [def time/seconds [λ* time/seconds [timestamp] "Return the seconds part of TIMESTAMP, defaults to current time" [% [default timestamp [time]] 60]]] [def time/minutes [λ* time/minutes [timestamp] "Return the minutes part of TIMESTAMP, defaults to current time" [% [/ [default timestamp [time]] 60] 60]]] [def time/hours [λ* time/hours [timestamp] "Return the hours part of TIMESTAMP, defaults to current time" [% [/ [default timestamp [time]] 3600] 24]]] [def profile-form [λ* profile-form [raw] "" [do [def start-time [time/milliseconds]] [def val [eval* [compile raw [current-closure]]]] [def end-time [time/milliseconds]] [display [cat "Evaluating " [ansi-yellow [str/write raw]] " to " [ansi-green [str/write val]] " took " [ansi-red [cat [- end-time start-time] "ms"] "\n"]]]]]] [def profile [μ* profile body "Measure and display how much time and ressources it takes for BODY to be evaluated" [cons 'profile-form [cons [cons 'quote [cons [if [last? body] [car body] [cons 'do body]] #nil]] #nil]]]]][def hash/adler32 [λ* hash/adler32 [data] "" [do [def a 1] [def b 0] [let* [do [def i 0] [def ΓεnΣym-62 [string/length data]] [while [< i ΓεnΣym-62] [do [set! a [mod [add a [char-at data i]] 65521]] [set! b [mod [add a b] 65521]] [set! i [add 1 i]]]]]] [logior a [ash b 16]]]]][do [def PI 3.14159] [def π 3.14159] [def ++ [μ* ++ [i] "Increment I by 1 and store the result in I" [cons 'set! [cons i [cons [cons '+ [cons 1 [cons i #nil]]] #nil]]]]] [def -- [μ* -- [i] "Decrement I by 1 and store the result in I" [cons 'set! [cons i [cons [cons '+ [cons -1 [cons i #nil]]] #nil]]]]] [def +x [λ* +x [α] "Return a function that adds α to it\'s argument, useful for mapping" [λ* #nil [β] "" [+ α β]]]] [def >> [λ* >> [val amount] "Shifts VAL by AMOUNT bits to the right" [ash val [- amount]]]] [def fib [λ* fib [i] "Terribly inefficient, but, useful for testing the GC" [if [< i 2] i [+ [fib [- i 2]] [fib [- i 1]]]]]] [def wrap-value [λ* wrap-value [val min max] "Constrains VAL to be within MIN and MAX, wrapping it around" [+ min [% [- val min] [- max min]]]]] [def +1 [μ* +1 [v] "" [cons '+ [cons 1 [cons v #nil]]]]] [def radians [λ* radians [degrees] "Convert a quantity in degrees to radians" [/ [* π degrees] 180.0]]]][do [def display/error/wrap [λ* display/error/wrap [i text] "" [if [== i 0] [ansi-red text] [if [== i 1] [string text] [if [== i 2] [ansi-yellow [str/write text]] [if [== i 3] [describe/closure text] [if #t text #nil]]]]]]] [def display/error/iter [λ* display/error/iter [error i] "" [if error [cons [display/error/wrap i [car error]] [display/error/iter [cdr error] [+ 1 i]]] [cons "" #nil]]]] [def display/error [λ* display/error [error] "Display ERROR in a nice, human readable way" [display [join [display/error/iter error 0] "\r\n"]]]] [def describe/thing [λ* describe/thing [o] "Describe a specific value O" [do [def doc [closure o]] [cat [str/write [ref doc :arguments]] " - " [ref doc :documentation]]]]] [def describe/string [λ* describe/string [a] "Descibe whatever value string A resolves to" [describe/thing [resolve [str->sym a]]]]] [def describe [λ* describe [fun] "Describe FUN, if there is documentation available" [if [string? fun] [describe/string fun] [describe/thing fun]]]] [def mem [λ* mem [] "Return some pretty printed memory usage information" [do [def info [memory-info]] [cat [ansi-white "Memory Info"] "\n" [ansi-green "Values: "] [getf info :value] "\n" [ansi-blue "Closures: "] [getf info :closure] "\n" [ansi-red "Arrays: "] [getf info :array] "\n" [ansi-yellow "STrings: "] [getf info :string] "\n" [ansi-pink "Symbols: "] [getf info :symbol] "\n" ansi-reset]]]] [def symbol-table [λ* symbol-table [off len environment] "Return a list of LEN symbols defined in ENVIRONMENT starting at OFF" [do [if environment #nil [set! environment root-closure]] [if off #nil [set! off 0]] [if len #nil [set! len 9999999]] [sublist [environment [symbol-table*]] off [+ off len] #nil]]]] [def arg-list [λ* arg-list [f] "Return the Argument list of f which can be a Native Function or a Lambda" [throw [list :gotta-implement-it]]]] [def gensym/counter 0] [def gensym [λ* gensym [prefix] "" [do [set! gensym/counter [+ 1 gensym/counter]] [str->sym [cat prefix "ΓεnΣym-" gensym/counter]]]]] [def root-closure [current-closure]]][do [def random/seed 0] [def random/seed-initialize! [λ* random/seed-initialize! [] "" [set! random/seed [logxor [time] [time/milliseconds]]]]] [def random/rng! [λ* random/rng! [] "" [do [set! random/seed [+ 12345 [* random/seed 1103515245]]] [logior [ash [logand random/seed 65535] 16] [logand [ash random/seed -16] 65535]]]]] [def random/seed! [λ* random/seed! [new-seed] "Set a new seed value for the RNG" [set! seed new-seed]]] [def random/seed [λ* random/seed [] "Return the current RNG seed value" seed]] [def random [λ* random [max] "Return a value from 0 to MAX, or, if left out, a random int" [if [numeric? max] [mod [abs [random/rng!]] max] [random/rng!]]]] [random/seed-initialize!]][do [def ansi/disabled #f] [def ansi-reset "\e[0m"] [def ansi-fg-reset "\e[0;39m"] [def ansi-bg-reset "\e[49m"] [def ansi-fg [array/new "\e[0;30m" "\e[0;31m" "\e[0;32m" "\e[0;33m" "\e[0;34m" "\e[0;35m" "\e[0;36m" "\e[0;37m" "\e[1;30m" "\e[1;31m" "\e[1;32m" "\e[1;33m" "\e[1;34m" "\e[1;35m" "\e[1;36m" "\e[1;37m"]] [def ansi-reset "\e[0m"] [def ansi-bg [array/new "\e[40m" "\e[41m" "\e[42m" "\e[43m" "\e[44m" "\e[45m" "\e[46m" "\e[47m"]] [def ansi-wrap [λ* ansi-wrap [code string] "Wrap STRING in the ansi color CODE" [cat [or ansi/disabled [array/ref ansi-fg code]] string [or ansi/disabled ansi-reset]]]] [def ansi-black [λ* ansi-black args "Wrap ARGS in black" [ansi-wrap 0 [apply cat args]]]] [def ansi-dark-red [λ* ansi-dark-red args "Wrap ARGS in dark red" [ansi-wrap 1 [apply cat args]]]] [def ansi-dark-green [λ* ansi-dark-green args "Wrap ARGS in dark green" [ansi-wrap 2 [apply cat args]]]] [def ansi-brown [λ* ansi-brown args "Wrap ARGS in brown" [ansi-wrap 3 [apply cat args]]]] [def ansi-dark-blue [λ* ansi-dark-blue args "Wrap ARGS in dark blue" [ansi-wrap 4 [apply cat args]]]] [def ansi-purple [λ* ansi-purple args "Wrap ARGS in purple" [ansi-wrap 5 [apply cat args]]]] [def ansi-teal [λ* ansi-teal args "Wrap ARGS in teal" [ansi-wrap 6 [apply cat args]]]] [def ansi-dark-gray [λ* ansi-dark-gray args "Wrap ARGS in dark gray" [ansi-wrap 7 [apply cat args]]]] [def ansi-gray [λ* ansi-gray args "Wrap ARGS in gray" [ansi-wrap 8 [apply cat args]]]] [def ansi-red [λ* ansi-red args "Wrap ARGS in red" [ansi-wrap 9 [apply cat args]]]] [def ansi-green [λ* ansi-green args "Wrap ARGS in green" [ansi-wrap 10 [apply cat args]]]] [def ansi-yellow [λ* ansi-yellow args "Wrap ARGS in yellow" [ansi-wrap 11 [apply cat args]]]] [def ansi-blue [λ* ansi-blue args "Wrap ARGS in blue" [ansi-wrap 12 [apply cat args]]]] [def ansi-pink [λ* ansi-pink args "Wrap ARGS in pink" [ansi-wrap 13 [apply cat args]]]] [def ansi-cyan [λ* ansi-cyan args "Wrap ARGS in cyan" [ansi-wrap 14 [apply cat args]]]] [def ansi-white [λ* ansi-white args "Wrap ARGS in white" [ansi-wrap 15 [apply cat args]]]] [def ansi-rainbow [λ* ansi-rainbow args "Wrap ARGS in the colors of the rainbow!" [let* [do [def count 0] [cat [join [map [split [apply cat args] ""] [λ* #nil [a] "" [do [set! count [logand [+ 1 count] 7]] [cat [or ansi/disabled [array/ref ansi-fg [if [zero? count] 7 [+ count 8]]]] a]]]] ""] [or ansi/disabled ansi-fg-reset]]]]]] [def ansi-rainbow-bg [λ* ansi-rainbow-bg args "Wrap ARGS in the colors of the rainbow!" [do [def count 0] [def colored-list [map [split [apply cat args] ""] [λ* #nil [a] "" [do [set! count [logand [+ 1 count] 7]] [cat [or ansi/disabled [array/ref ansi-fg [logxor count 7]]] [or ansi/disabled [array/ref ansi-bg count]] a]]]]] [cat [join colored-list ""] [or ansi/disabled ansi-reset]]]]] [def reprint-line [λ* reprint-line [text width] "" [do [if width #nil [set! width 20]] [print "\r"] [let* [do [def i 0] [def ΓεnΣym-151 width] [while [< i ΓεnΣym-151] [do [print " "] [set! i [add 1 i]]]]]] [print "\r"] [print text]]]]][do [def fmt/format-arg/default [tree/new :align :right :debug #f :base #f :width #nil :padding-char " "]] [def fmt/find-non-digit-from-right [λ* fmt/find-non-digit-from-right [s i] "" [if [< i 0] -1 [do [def char [char-at s i]] [if [and [>= char 48] [<= char 57]] [fmt/find-non-digit-from-right s [- i 1]] i]]]]] [def fmt/parse-spec [λ* fmt/parse-spec [opts spec] "" [if [zero? [string/length spec]] opts [let* [do [def ΓεnΣym-152 [char-at spec [- [string/length spec] 1]]] [if [or [== ΓεnΣym-152 48] [== ΓεnΣym-152 49] [== ΓεnΣym-152 50] [== ΓεnΣym-152 51] [== ΓεnΣym-152 52] [== ΓεnΣym-152 53] [== ΓεnΣym-152 54] [== ΓεnΣym-152 55] [== ΓεnΣym-152 56] [== ΓεnΣym-152 57]] [do [def next-non-digit [fmt/find-non-digit-from-right spec [- [string/length spec] 1]]] [def number [string/cut spec [+ 1 next-non-digit] [string/length spec]]] [tree/set! opts :width [read/single number]] [if [== 48 [char-at number 0]] [tree/set! opts :padding-char "0"] #nil] [fmt/parse-spec opts [string/cut spec 0 [+ 1 next-non-digit]]]] [if [== ΓεnΣym-152 63] [fmt/parse-spec [tree/set! opts :debug #t] [string/cut spec 0 [- [string/length spec] 1]]] [if [== ΓεnΣym-152 88] [fmt/parse-spec [tree/set! opts :base :HEXADECIMAL] [string/cut spec 0 [- [string/length spec] 1]]] [if [== ΓεnΣym-152 120] [fmt/parse-spec [tree/set! opts :base :hexadecimal] [string/cut spec 0 [- [string/length spec] 1]]] [if [== ΓεnΣym-152 100] [fmt/parse-spec [tree/set! opts :base :decimal] [string/cut spec 0 [- [string/length spec] 1]]] [if [== ΓεnΣym-152 111] [fmt/parse-spec [tree/set! opts :base :octal] [string/cut spec 0 [- [string/length spec] 1]]] [if [== ΓεnΣym-152 98] [fmt/parse-spec [tree/set! opts :base :binary] [string/cut spec 0 [- [string/length spec] 1]]] [if [== ΓεnΣym-152 60] [fmt/parse-spec [tree/set! opts :align :left] [string/cut spec 0 [- [string/length spec] 1]]] [if [== ΓεnΣym-152 94] [fmt/parse-spec [tree/set! opts :align :center] [string/cut spec 0 [- [string/length spec] 1]]] [if [== ΓεnΣym-152 62] [fmt/parse-spec [tree/set! opts :align :right] [string/cut spec 0 [- [string/length spec] 1]]] [if [== ΓεnΣym-152 46] [fmt/parse-spec [tree/set! opts :precision [tree/ref opts :width]] [string/cut spec 0 [- [string/length spec] 1]]] [throw [list :format-error "Unknown form-spec option" spec [current-closure]]]]]]]]]]]]]]]]]]] [def fmt/debug [λ* fmt/debug [opts] "" [if [tree/ref opts :debug] [tree/set! opts :argument [list str/write [tree/ref opts :argument]]] opts]]] [def fmt/number-format [λ* fmt/number-format [opts] "" [let* [do [def ΓεnΣym-153 [tree/ref opts :base]] [if [== ΓεnΣym-153 :binary] [tree/set! opts :argument [list int->string/binary [tree/ref opts :argument]]] [if [== ΓεnΣym-153 :octal] [tree/set! opts :argument [list int->string/octal [tree/ref opts :argument]]] [if [== ΓεnΣym-153 :decimal] [tree/set! opts :argument [list int->string/decimal [tree/ref opts :argument]]] [if [== ΓεnΣym-153 :hexadecimal] [tree/set! opts :argument [list int->string/hex [tree/ref opts :argument]]] [if [== ΓεnΣym-153 :HEXADECIMAL] [tree/set! opts :argument [list int->string/HEX [tree/ref opts :argument]]] opts]]]]]]]]] [def fmt/number-format-prefixex [tree/new :binary "#b" :octal "#o" :decimal "#d" :hexadecimal "#x" :HEXADECIMAL "#x"]] [def fmt/number-format-prefix [λ* fmt/number-format-prefix [opts] "" [if [or [not [tree/ref opts :debug]] [not [tree/ref opts :base]]] opts [tree/set! [if [member '[:binary :octal :decimal :hexadecimal :HEXADECIMAL] [tree/ref opts :base]] [tree/set! opts :argument [list cat [tree/ref fmt/number-format-prefixex [tree/ref opts :base]] [tree/ref opts :argument]]] opts] :debug #f]]]] [def fmt/add-padding [λ* fmt/add-padding [opts] "" [if [tree/ref opts :width] [tree/set! opts :argument [list [let* [do [def ΓεnΣym-154 [tree/ref opts :align]] [if [== ΓεnΣym-154 :right] string/pad-start [if [== ΓεnΣym-154 :center] string/pad-middle [if [== ΓεnΣym-154 :left] string/pad-end #nil]]]]] [tree/ref opts :argument] [if [and [tree/ref opts :debug] [tree/ref opts :base]] [- [tree/ref opts :width] 2] [tree/ref opts :width]] [tree/ref opts :padding-char]]] opts]]] [def fmt/precision [λ* fmt/precision [opts] "" [if [tree/ref opts :precision] [tree/set! opts :argument [list string/round [tree/ref opts :argument] [tree/ref opts :precision]]] opts]]] [def fmt/truncate [λ* fmt/truncate [opts] "" [if [tree/ref opts :width] [tree/set! opts :argument [list string/cut [tree/ref opts :argument] 0 [+ 1 [tree/ref opts :width]]]] opts]]] [def fmt/output [λ* fmt/output [opts] "" [tree/ref opts :argument]]] [def fmt/format-arg [λ* fmt/format-arg [spec argument] "" [fmt/output [fmt/debug [fmt/number-format-prefix [fmt/truncate [fmt/add-padding [fmt/precision [fmt/number-format [tree/set! [fmt/parse-spec [tree/dup fmt/format-arg/default] spec] :argument argument]]]]]]]]]] [def fmt/valid-argument? [λ* fmt/valid-argument? [argument] "" [or [int? argument] [symbol? argument]]]] [def fmt/expr/count 0] [def fmt/expr [λ* fmt/expr [expr arguments-used] "" [do [if [string? expr] #nil [throw [list :format-error "fmt needs a string literal as a first argument, since it is implemented as a macro" expr [current-lambda]]]] [def split-expr [split expr ":"]] [def argument [car split-expr]] [def format-spec [or [cadr split-expr] ""]] [if [== "" argument] [do [array/set! arguments-used [set! fmt/expr/count [+ -1 fmt/expr/count]] #t] [fmt/format-arg format-spec [str->sym [string fmt/expr/count]]]] [let* [do [def read-vals [read argument]] [if [cdr read-vals] [throw [list :format-error "Format argument specifier contains more than a single atom" argument [current-lambda]]] #nil] [if [fmt/valid-argument? [car read-vals]] #nil [throw [list :format-error "Format argument specifier should be either an integer or a symbol" argument [current-lambda]]]] [if [int? [car read-vals]] [do [if [or [< [car read-vals] 0] [>= [car read-vals] [array/length arguments-used]]] [throw [list :format-error "fmt numbered argument is out of bounds" argument [current-lambda]]] #nil] [array/set! arguments-used [car read-vals] #t]] #nil] [fmt/format-arg format-spec [str->sym [string [car read-vals]]]]]]]]]] [def fmt/args/map-fun/count 0] [def fmt/args/map-fun [λ* fmt/args/map-fun [arg] "" [do [def s [str->sym [string fmt/args/map-fun/count]]] [set! fmt/args/map-fun/count [+ 1 fmt/args/map-fun/count]] [list 'def s arg]]]] [def fmt [μ* fmt [format-string . args] "Return a formatted string" [do [if [string? format-string] #nil [throw [list :type-error "fmt needs a string literal as a first argument, since it is implemented as a macro" format-string [current-lambda]]]] [def cuts #nil] [let* [do [def i 0] [def ΓεnΣym-155 [string/length format-string]] [while [< i ΓεnΣym-155] [do [let* [do [def ΓεnΣym-156 [char-at format-string i]] [if [== ΓεnΣym-156 123] [do [if [int? [car cuts]] [throw [list :format-error "fmt placeholders can\'t be nested" format-string [current-lambda]]] #nil] [set! cuts [cons i cuts]]] [if [== ΓεnΣym-156 125] [do [if [int? [car cuts]] #nil [throw [list :format-error "fmt expects all brackets to be closed" format-string [current-lambda]]]] [set! cuts [cons [cons [car cuts] i] [cdr cuts]]]] #nil]]]] [set! i [add 1 i]]]]]] [if [int? [car cuts]] [throw [list :format-error "fmt placeholders can\'t be nested" format-string [current-lambda]]] #nil] [def expr-list #nil] [def last-pos [string/length format-string]] [def arguments-used [array/fill! [array/allocate [length args]] #f]] [set! fmt/expr/count [array/length arguments-used]] [let* [do [def ΓεnΣym-157 cuts] [if ΓεnΣym-157 [while ΓεnΣym-157 [do [def c [car ΓεnΣym-157]] [def lit [string/cut format-string [+ [cdr c] 1] last-pos]] [if [== "" lit] #nil [set! expr-list [cons lit expr-list]]] [def expr [fmt/expr [string/cut format-string [+ 1 [car c]] [cdr c]] arguments-used]] [set! expr-list [cons expr expr-list]] [set! last-pos [car c]] [set! ΓεnΣym-157 [cdr ΓεnΣym-157]]]] #nil]]] [if [> last-pos 0] [do [def lit [string/cut format-string 0 last-pos]] [set! expr-list [cons lit expr-list]]] #nil] [let* [do [def i 0] [def ΓεnΣym-158 [array/length arguments-used]] [while [< i ΓεnΣym-158] [do [if [array/ref arguments-used i] #nil [throw [list :format-error "fmt expects all arguments to be used" [list format-string [list/ref args i]] [current-lambda]]]] [set! i [add 1 i]]]]]] [def expr [if [cdr expr-list] [cons 'cat expr-list] [if [string? [car expr-list]] [car expr-list] [cons 'string expr-list]]]] [set! fmt/args/map-fun/count 0] [if args [cons 'let* [append [map args fmt/args/map-fun] [cons expr #nil]]] expr]]]] [def pfmt [μ* pfmt [format-string . args] "Print a formatted string" [cons 'print [cons [cons 'fmt [cons format-string [append args #nil]]] #nil]]]] [def efmt [μ* efmt [format-string . args] "Print a formatted string" [cons 'error [cons [cons 'fmt [cons format-string [append args #nil]]] #nil]]]] [def pfmtln [μ* pfmtln [format-string . args] "Print a formatted string" [cons 'println [cons [cons 'fmt [cons format-string [append args #nil]]] #nil]]]] [def efmtln [μ* efmtln [format-string . args] "Print a formatted string" [cons 'errorln [cons [cons 'fmt [cons format-string [append args #nil]]] #nil]]]]][do [def string->keyword [λ* string->keyword [α] "Return string α as a keyword" [symbol->keyword [str->sym α]]]] [def string->byte-array [λ* string->byte-array [a] "Turn a string into an UTF-8 encoded byte array" [do [def ret [array/allocate [string/length a]]] [let* [do [def i 0] [def ΓεnΣym-159 [string/length a]] [while [< i ΓεnΣym-159] [do [array/set! ret i [char-at a i]] [set! i [add 1 i]]]]]] ret]]] [def println [λ* println [str] "Print STR on a single line" [print [cat str "\r\n"]]]] [def errorln [λ* errorln [str] "Print to stderr STR on a single line" [print [cat str "\r\n"]]]] [def display [λ* display [value] "Display VALUE" [print value]]] [def newline [λ* newline [] "Print a single line feed character" [display "\r\n"]]] [def br [λ* br [num] "Return NUM=1 linebreaks" [if [or [nil? num] [<= [int num] 1]] "\n" [cat "\n" [br [+ -1 num]]]]]] [def path/ext?! [λ* path/ext?! [ext] "Return a predicate that checks if a path ends on EXT" [λ* #nil [path] "" [== ext [lowercase [path/extension path]]]]]] [def path/extension [λ* path/extension [path] "Return the extension of PATH" [do [def last-period [last-index-of path "."]] [if [>= last-period 0] [string/cut path [+ 1 last-period] [string/length path]] path]]]] [def path/without-extension [λ* path/without-extension [path] "Return PATH, but without the extension part" [do [def last-period [last-index-of path "."]] [if [>= last-period 0] [string/cut path 0 last-period] path]]]] [def int->string/binary [λ* int->string/binary [α] "Turn α into a its **binary** string representation" [do [def ret ""] [if α #nil [def α 0]] [if [zero? α] [set! ret "0"] #nil] [while [not-zero? α] [do [set! ret [cat [from-char-code [+ 48 [logand α 1]]] ret]] [set! α [ash α -1]]]] ret]]] [def int->string/octal [λ* int->string/octal [α] "Turn α into a its **octal** string representation" [do [def ret ""] [if α #nil [def α 0]] [if [zero? α] [set! ret "0"] #nil] [while [not-zero? α] [do [set! ret [cat [from-char-code [+ 48 [logand α 7]]] ret]] [set! α [ash α -3]]]] ret]]] [def int->string/HEX [let* [do [def conversion-arr [array/new "0" "1" "2" "3" "4" "5" "6" "7" "8" "9" "A" "B" "C" "D" "E" "F"]] [λ* #nil [α] "" [do [def ret ""] [if α #nil [def α 0]] [if [zero? α] [set! ret "0"] #nil] [if [< α 0] [throw [list :type-error "Can\'t print negative numbers in hex for now" α [current-lambda]]] #nil] [while [not-zero? α] [do [set! ret [cat [array/ref conversion-arr [logand α 15]] ret]] [set! α [ash α -4]]]] ret]]]]] [def int->string/hex [λ* int->string/hex [α] "Turn α into a its **hexadecimal** string representation" [lowercase [int->string/HEX α]]]] [def int->string/decimal [λ* int->string/decimal [α] "Turn α into a its **decimal** string representation" [string α]]] [def int->string int->string/decimal] [def string/pad-start [λ* string/pad-start [text goal-length char] "Pad out TEXT with CHAR at the start until it is GOAL-LENGTH chars long, may also truncate the string" [do [if char #nil [set! char " "]] [if [string? text] #nil [set! text [string text]]] [if [string? char] #nil [throw [list :type-error "string/pad-start needs char as a string, so that one can pad with multiple characters" char [current-lambda]]]] [while [< [string/length text] goal-length] [set! text [cat char text]]] [if [> [string/length text] goal-length] [string/cut text [- [string/length text] goal-length] [string/length text]] text]]]] [def string/pad-end [λ* string/pad-end [text goal-length char] "Pad out TEXT with CHAR at the end until it is GOAL-LENGTH chars long, may also truncate the string" [do [if char #nil [set! char " "]] [if [string? text] #nil [set! text [string text]]] [if [string? char] #nil [throw [list :type-error "string/pad-start needs char as a string, so that one can pad with multiple characters" char [current-lambda]]]] [while [< [string/length text] goal-length] [set! text [cat text char]]] [if [> [string/length text] goal-length] [string/cut text 0 goal-length] text]]]] [def string/pad-middle [λ* string/pad-middle [text goal-length char] "Pad out TEXT with CHAR at the end until it is GOAL-LENGTH chars long, may also truncate the string" [do [if char #nil [set! char " "]] [if [string? text] #nil [set! text [string text]]] [if [string? char] #nil [throw [list :type-error "string/pad-middle needs char as a string, so that one can pad with multiple characters" char [current-lambda]]]] [while [< [string/length text] goal-length] [set! text [cat char text char]]] [if [> [string/length text] goal-length] [let* [do [def end-overflow [/ [- [string/length text] goal-length] 2]] [def start-overflow [- [- [string/length text] goal-length] end-overflow]] [string/cut text start-overflow [+ start-overflow goal-length]]]] text]]]] [def string/round [λ* string/round [text decimal-digits] "Round the floating point representation in TEXT to have at most DECIMAL-DIGITS after the period" [do [def pos [last-index-of text "."]] [if [>= pos 0] [string/cut text 0 [+ pos 1 decimal-digits]] text]]]] [def split/empty [λ* split/empty [str separator] "" [do [def slen [string/length str]] [def start 0] [def ret #nil] [while [< start slen] [do [set! ret [cons [string/cut str start [+ 1 start]] ret]] [set! start [+ 1 start]]]] [reverse ret]]]] [def split/string [λ* split/string [str separator start] "" [do [if start #nil [set! start 0]] [def pos-found [index-of str separator start]] [if [>= pos-found 0] [cons [string/cut str start pos-found] [split/string str separator [+ pos-found [string/length separator]]]] [cons [string/cut str start [string/length str]] #nil]]]]] [def split [λ* split [str separator] "" [let* [do [def ΓεnΣym-160 [string/length separator]] [if [or [== ΓεnΣym-160 0]] [split/empty str] [split/string str separator 0]]]]]] [def read/single [λ* read/single [text] "" [car [read text]]]] [def string/length?! [λ* string/length?! [chars] "" [λ* #nil [a] "" [== chars [string/length a]]]]] [def contains-any? [λ* contains-any? [str chars] "" [apply or [map [split chars ""] [λ* #nil [a] "" [>= [index-of str a] 0]]]]]] [def contains-all? [λ* contains-all? [str chars] "" [apply and [map [split chars ""] [λ* #nil [a] "" [>= [index-of str a] 0]]]]]]][do [def test-context "Nujel"] [def test-list #nil] [def test-count 0] [def nujel-start 0] [def success-count 0] [def error-count 0] [def print-errors #t] [def print-passes #f] [def test/add* [λ* test/add* [result expr] "" [do [set! test-list [cons [cons result expr] test-list]] [set! test-count [+ test-count 1]]]]] [def test/add [μ* test/add [result . expr] "Add a test where EXPR must eval to RESULT" [cons 'test/add* [cons result [cons [list 'quote [cons 'do expr]] #nil]]]]] [test/add* 4 '[do [+ 3 1]]] [def display-results [λ* display-results [] "Prints the result Message" [do [random/seed-initialize!] [eval* [compile '[efmtln "{test-context} [{System/OS} {System/Architecture}] - {} - [{} / {}] in {} ms - {}" [if [and [zero? error-count] [> test-count 0]] "Success" "Failed!"] [ansi-green success-count] [ansi-red error-count] [- [time/milliseconds] nujel-start] [if [and [zero? error-count] [> test-count 0]] [ansi-rainbow "Everything is working, very nice!"] [ansi-red "Better fix those!"]]] [current-closure]]]]]] [def test-success [λ* test-success [res-should res-is expr i] "Should be called after a test has finished successfully" [do [if print-passes [eval* [compile '[efmtln "tests/suite/tests.nuj:{i}:1 {} == {}\r\n{}\r\n\r\n" [ansi-green [str/write res-is]] [ansi-green [str/write res-should]] [str/write expr]] [current-closure]]] #nil] [set! success-count [+ 1 success-count]]]]] [def test-failure [λ* test-failure [res-should res-is expr i] "Should be called if EXPR does not equal RES" [do [if print-errors [eval* [compile '[efmtln "tests/suite/tests.nuj:{i}:1 {} != {}\r\n{}\r\n\r\n" [ansi-red [str/write res-is]] [ansi-green [str/write res-should]] [str/write expr]] [current-closure]]] #nil] [set! error-count [+ 1 error-count]]]]] [def test-bytecode [λ* test-bytecode [result rawexpr i] "Tests that RAWEXPR evaluates to RESULT when run through the bytecode interpreter" [try [λ* #nil [err] "" [test-failure result [list :exception-caught err] rawexpr i]] [do [def expr [bytecode-eval [assemble* [bytecompile [compile rawexpr]]]]] [if [equal? result expr] [test-success result expr rawexpr i] [test-failure result expr rawexpr i]]]]]] [def test-default [λ* test-default [result rawexpr i] "Tests that RAWEXPR evaluates to RESULT" [try [λ* #nil [err] "" [test-failure result [list :exception-caught err] rawexpr i]] [do [def expr [eval* [compile rawexpr [current-closure]]]] [if [equal? result expr] [test-success result expr rawexpr i] [test-failure result expr rawexpr i]]]]]] [def test-forked [λ* test-forked [nujel-runtime] "" [λ* #nil [result rawexpr i] "Tests that RAWEXPR evaluates to RESULT in a separate runtime" [do [def eval-result [eval/forked nujel-runtime rawexpr]] [def expr [cdr eval-result]] [if [string? result] #nil [set! expr [car [read expr]]]] [if [and [zero? [car eval-result]] [equal? result expr]] [test-success result expr rawexpr i] [test-failure result expr rawexpr i]]]]]] [def test-run-real [λ* test-run-real [test] "" [do [set! nujel-start [time/milliseconds]] [set! success-count 0] [set! error-count 0] [def i [+ test-count 1]] [let* [do [def ΓεnΣym-161 test-list] [if ΓεnΣym-161 [while ΓεnΣym-161 [do [def cur-test [car ΓεnΣym-161]] [test [car cur-test] [cdr cur-test] [set! i [+ -1 i]]] [set! ΓεnΣym-161 [cdr ΓεnΣym-161]]]] #nil]]] [display-results] error-count]]] [def test-run [λ* test-run [output-passes hide-errors] "Run through all automated Tests" [do [set! print-errors [not [bool hide-errors]]] [set! print-passes [bool output-passes]] [test-run-real test-default]]]] [def test-run-bytecode [λ* test-run-bytecode [output-passes hide-errors] "Run through all automated Tests" [do [set! print-errors [not [bool hide-errors]]] [set! print-passes [bool output-passes]] [test-run-real test-bytecode]]]] [def test-run-forked [λ* test-run-forked [\ [nujel-runtime output-passes hide-errors] "Run through all automated Tests in a separate runtime" [set! print-errors [not [bool hide-errors]]] [set! print-passes [bool output-passes]] [test-run-real [test-forked nujel-runtime]]] "" do]]][optimize-all!]
