Ben/Nujel - bootstrap/stdlib.no

Ben (X220/Parabola) Moved a lot of stdlib functions over to use bytecode 7b75162 3 years ago 533 Commits
Raw
application/octet-stream • 116.64 KB • 6760 lines
[do [def lognand [λδ* lognand l "Returns the Nand of its arguments" #{
10s logand
10s l
08i 2 v apply
08i 1 v lognot
01
}]] [def bit-set?! [λδ* bit-set?! [i] "" #{
02i 1
10s i
08i 2 v ash
0Es mask
0D
11v [:symbol :symbol] v [α] v "" v [not [zero? [logand α mask]]]
01
}]] [def bit-clear?! [λδ* bit-clear?! [i] "" #{
02i 1
10s i
08i 2 v ash
0Es mask
0D
11v [:symbol :symbol] v [α] v "" v [zero? [logand α mask]]
01
}]]][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" #{
10s a
10s i
10s v
10s a
10s i
08i 2 v array/ref
08i 2 v +
08i 3 v array/set!
01
}]] [def array/++ [λδ* array/++ [a i] "Increment position I in A and return A" #{
10s a
10s i
02i 1
08i 3 v array/+=
01
}]] [def array/fill! [λδ* array/fill! [a v] "Fills array a with value v" #{
10s a
08i 1 v array/length
0Es len
0D
15
02i 0
0Es i
0D
10s len
0Es ΓεnΣym-129
0D
02i 0
1B
1C
10s i
10s ΓεnΣym-129
1E
0Bo 36
0D
10s a
10s i
10s v
08i 3 v array/set!
0D
02i 1
10s i
03
0Fs i
09o -43
16
0D
10s a
01
}]] [def array/append [λδ* array/append [a b] "Append array A to array B" #{
10s a
08i 1 v array?
0C
0Bo 13
0D
10s b
08i 1 v array?
0Bo 7
24
09o 27
05v :type-error
05v "array/append expects two arrays as its arguments"
24
08i 0 v current-lambda
08i 4 v list
08i 1 v throw
0D
10s a
08i 1 v array/length
10s b
08i 1 v array/length
08i 2 v +
08i 1 v array/allocate
0Es ret
0D
15
02i 0
0Es i
0D
10s a
08i 1 v array/length
0Es ΓεnΣym-130
0D
02i 0
1B
1C
10s i
10s ΓεnΣym-130
1E
0Bo 45
0D
10s ret
10s i
10s a
10s i
08i 2 v array/ref
08i 3 v array/set!
0D
02i 1
10s i
03
0Fs i
09o -52
16
0D
15
10s a
08i 1 v array/length
0Es i
0D
10s ret
08i 1 v array/length
0Es ΓεnΣym-131
0D
02i 0
1B
1C
10s i
10s ΓεnΣym-131
1E
0Bo 59
0D
10s ret
10s i
10s b
10s i
10s a
08i 1 v array/length
08i 2 v -
08i 2 v array/ref
08i 3 v array/set!
0D
02i 1
10s i
03
0Fs i
09o -66
16
0D
10s ret
01
}]] [def array/dup [λδ* array/dup [a] "Duplicate Array A" #{
10s a
24
08i 1 v array/new
08i 2 v array/append
01
}]] [def array/reduce [λδ* array/reduce [arr fun α] "Reduce an array, [reduce] should be preferred" #{
10s arr
08i 1 v array/length
0Es len
0D
15
02i 0
0Es i
0D
10s len
0Es ΓεnΣym-132
0D
02i 0
1B
1C
10s i
10s ΓεnΣym-132
1E
0Bo 46
0D
10s fun
10s α
10s arr
10s i
08i 2 v array/ref
1A
02i 15
00
00
9E
0D
02i 1
10s i
03
0Fs i
09o -53
16
0D
10s α
01
}]] [def array/map [λδ* array/map [arr fun] "Map an array, [map] should be preferred" #{
10s arr
08i 1 v array/length
0Es len
0D
15
02i 0
0Es i
0D
10s len
0Es ΓεnΣym-133
0D
02i 0
1B
1C
10s i
10s ΓεnΣym-133
1E
0Bo 51
0D
10s arr
10s i
10s fun
10s arr
10s i
08i 2 v array/ref
1A
01
08i 3 v array/set!
0D
02i 1
10s i
03
0Fs i
09o -58
16
0D
10s arr
01
}]] [def array/filter [λδ* array/filter [arr pred] "Filter an array, [filter] should be preferred" #{
02i 0
0Es ri
0D
10s arr
08i 1 v array/length
0Es len
0D
10s len
08i 1 v array/allocate
0Es ret
0D
15
02i 0
0Es ai
0D
10s len
0Es ΓεnΣym-134
0D
02i 0
1B
1C
10s ai
10s ΓεnΣym-134
1E
0Bo 87
0D
10s pred
10s arr
10s ai
08i 2 v array/ref
1A
01
0Bo 48
10s ret
10s ri
10s arr
10s ai
08i 2 v array/ref
08i 3 v array/set!
0D
02i 1
10s ri
08i 2 v +
0Fs ri
09o 4
24
0D
02i 1
10s ai
03
0Fs ai
09o -94
16
0D
10s ret
10s ri
08i 2 v array/length!
01
}]] [def array/equal? [λδ* array/equal? [a b] "" #{
10s a
08i 1 v array?
08i 1 v not
0C
0Ao 55
0D
10s b
08i 1 v array?
08i 1 v not
0C
0Ao 36
0D
10s a
08i 1 v array/length
10s b
08i 1 v array/length
08i 2 v !=
0C
0Ao 8
0D
05v #f
0Bo 10
05v #f
09o 134
15
05v #t
0Es ret
0D
15
02i 0
0Es i
0D
10s a
08i 1 v array/length
0Es ΓεnΣym-135
0D
02i 0
1B
1C
10s i
10s ΓεnΣym-135
1E
0Bo 79
0D
10s a
10s i
08i 2 v array/ref
10s b
10s i
08i 2 v array/ref
08i 2 v equal?
0Bo 7
24
09o 25
05v #f
0Fs ret
0D
10s a
08i 1 v array/length
0Fs i
0D
02i 1
10s i
03
0Fs i
09o -86
16
0D
10s ret
16
01
}]] [def array/push [λδ* array/push [arr . val] "Append all arguments following ARR to ARR" #{
15
10s val
0Es ΓεnΣym-136
0D
10s ΓεnΣym-136
0Bo 104
02i 0
1B
1C
10s ΓεnΣym-136
0Bo 90
0D
10s ΓεnΣym-136
08i 1 v car
0Es v
0D
10s arr
02i 1
10s arr
08i 1 v array/length
08i 2 v +
08i 2 v array/length!
0D
10s arr
10s arr
08i 1 v array/length
02i 1
08i 2 v -
10s v
08i 3 v array/set!
0D
10s ΓεnΣym-136
08i 1 v cdr
0Fs ΓεnΣym-136
09o -92
09o 4
24
16
0D
10s arr
01
}]] [def array/swap [λδ* array/swap [arr i j] "" #{
10s arr
10s i
08i 2 v array/ref
0Es tmp
0D
10s arr
10s i
10s arr
10s j
08i 2 v array/ref
08i 3 v array/set!
0D
10s arr
10s j
10s tmp
08i 3 v array/set!
01
}]] [def array/heapify [λδ* array/heapify [arr n at] "bubble up the element from index AT to until the max-heap property is satisfied" #{
10s at
0Es top
0D
05v #t
0Es looping
0D
02i 0
1B
1C
10s looping
0Bo 216
0D
10s at
02i 1
08i 2 v ash
02i 1
08i 2 v +
0Es l
0D
10s at
02i 1
08i 2 v ash
02i 2
08i 2 v +
0Es r
0D
10s l
10s n
1E
0C
0Bo 31
0D
10s arr
10s l
08i 2 v array/ref
10s arr
10s top
08i 2 v array/ref
22
0Bo 14
10s l
0Fs top
09o 4
24
0D
10s r
10s n
1E
0C
0Bo 31
0D
10s arr
10s r
08i 2 v array/ref
10s arr
10s top
08i 2 v array/ref
22
0Bo 14
10s r
0Fs top
09o 4
24
0D
10s top
10s at
20
0Bo 14
05v #f
0Fs looping
09o 29
10s arr
10s at
10s top
08i 3 v array/swap
0D
10s top
0Fs at
09o -218
0D
10s arr
01
}]] [def array/make-heap [λδ* array/make-heap [arr] "" #{
10s arr
08i 1 v array/length
0Es l
0D
10s l
02i 2
08i 2 v /
0Es l2
0D
02i 0
1B
1C
10s l2
02i 0
21
0Bo 40
0D
10s arr
10s l
10s l2
08i 3 v array/heapify
0D
02i -1
10s l2
08i 2 v +
0Fs l2
09o -45
0D
10s arr
01
}]] [def array/heap-sort [λδ* array/heap-sort [arr] "" #{
10s arr
08i 1 v array/make-heap
0D
10s arr
08i 1 v array/length
0Es l
0D
02i 0
1B
1C
10s l
02i 0
22
0Bo 54
0D
02i -1
10s l
08i 2 v +
0Fs l
0D
10s arr
02i 0
10s l
08i 3 v array/swap
0D
10s arr
10s l
02i 0
08i 3 v array/heapify
09o -59
0D
10s arr
01
}]] [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" #{
02i 0
10s start
08i 2 v max
0Fs start
0D
10s arr
08i 1 v array/length
10s end
08i 2 v min
0Fs end
0D
02i 0
10s end
10s start
08i 2 v -
08i 2 v max
08i 1 v array/allocate
0Es ret
0D
15
10s start
0Es i
0D
10s end
0Es ΓεnΣym-137
0D
02i 0
1B
1C
10s i
10s ΓεnΣym-137
1E
0Bo 54
0D
10s ret
10s i
10s start
08i 2 v -
10s arr
10s i
08i 2 v array/ref
08i 3 v array/set!
0D
02i 1
10s i
03
0Fs i
09o -61
16
0D
10s ret
01
}]]][do [def array/2d/allocate [λδ* array/2d/allocate [width height] "" #{
05v :data
10s width
10s height
08i 2 v *
08i 1 v array/allocate
02i 0
08i 2 v array/fill!
05v :width
10s width
05v :height
10s height
08i 6 v tree/new
01
}]] [def array/2d/fill! [λδ* array/2d/fill! [data v] "" #{
10s data
05v :data
08i 2 v tree/ref
10s v
08i 2 v array/fill!
0D
10s data
01
}]] [def array/2d/ref [λδ* array/2d/ref [data x y oob-val] "" #{
10s x
10s data
05v :width
08i 2 v tree/ref
21
0C
0Ao 55
0D
10s y
10s data
05v :height
08i 2 v tree/ref
21
0C
0Ao 32
0D
10s x
02i 0
1E
0C
0Ao 20
0D
10s y
02i 0
1E
0C
0Ao 8
0D
05v #f
0Bo 10
10s oob-val
09o 52
10s data
05v :data
08i 2 v tree/ref
10s x
10s y
10s data
05v :width
08i 2 v tree/ref
08i 2 v mul
08i 2 v add
08i 2 v array/ref
01
}]] [def array/2d/set! [λδ* array/2d/set! [data x y val] "" #{
10s x
10s data
05v :width
08i 2 v tree/ref
21
0C
0Ao 55
0D
10s y
10s data
05v :height
08i 2 v tree/ref
21
0C
0Ao 32
0D
10s x
02i 0
1E
0C
0Ao 20
0D
10s y
02i 0
1E
0C
0Ao 8
0D
05v #f
0Bo 33
05v :out-of-bounds
05v "Trying to set an array out of bounds"
10s data
08i 0 v current-lambda
08i 4 v list
08i 1 v throw
09o 56
10s data
05v :data
08i 2 v tree/ref
10s x
10s y
10s data
05v :width
08i 2 v tree/ref
08i 2 v mul
08i 2 v add
10s val
08i 3 v array/set!
0D
10s data
01
}]] [def array/2d/print [λδ* array/2d/print [data] "" #{
15
02i 0
0Es y
0D
10s data
05v :height
08i 2 v tree/ref
0Es ΓεnΣym-138
0D
02i 0
1B
1C
10s y
10s ΓεnΣym-138
1E
0Bo 115
0D
15
02i 0
0Es x
0D
10s data
05v :width
08i 2 v tree/ref
0Es ΓεnΣym-139
0D
02i 0
1B
1C
10s x
10s ΓεnΣym-139
1E
0Bo 50
0D
10s data
10s x
10s y
08i 3 v array/2d/ref
05v " "
08i 2 v cat
08i 1 v display
0D
02i 1
10s x
03
0Fs x
09o -57
16
0D
08i 0 v newline
0D
02i 1
10s y
03
0Fs y
09o -122
16
0D
10s data
01
}]]][do [def avl/empty :e] [def avl/empty? [λδ* avl/empty? [n] "" #{
05v :e
10s n
20
01
}]] [def avl/default-cmp [λδ* avl/default-cmp [x y] "" #{
10s x
10s y
1E
0Bo 8
02i -1
09o 22
10s x
10s y
22
0Bo 8
02i 1
09o 5
02i 0
01
}]] [def avl/typecheck [λδ* avl/typecheck [r k] "" #{
10s r
08i 1 v avl/root
08i 1 v avl/empty?
0C
0Ao 74
0D
10s k
08i 1 v type-of
10s r
08i 1 v avl/root
08i 1 v avl/key
08i 1 v type-of
20
0C
0Ao 40
0D
05v :type-error
05v "AVL trees can only contains keys of a single type"
10s k
08i 0 v current-lambda
08i 4 v list
08i 1 v throw
0C
0Ao 8
0D
05v #f
01
}]] [def avl/tree [λδ* avl/tree [cmp] "" #{
10s avl/empty
10s cmp
0C
0Ao 17
0D
10s avl/default-cmp
0C
0Ao 8
0D
05v #f
08i 2 v array/new
01
}]] [def avl/height [λδ* avl/height [n] "" #{
10s n
08i 1 v avl/empty?
0Bo 8
02i 0
09o 14
10s n
02i 0
08i 2 v array/ref
01
}]] [def avl/key [λδ* avl/key [n] "" #{
10s n
02i 1
08i 2 v array/ref
01
}]] [def avl/left [λδ* avl/left [n] "" #{
10s n
02i 2
08i 2 v array/ref
01
}]] [def avl/right [λδ* avl/right [n] "" #{
10s n
02i 3
08i 2 v array/ref
01
}]] [def avl/root [λδ* avl/root [r] "" #{
10s r
02i 0
08i 2 v array/ref
01
}]] [def avl/cmp [λδ* avl/cmp [r] "" #{
10s r
02i 1
08i 2 v array/ref
01
}]] [def avl/min-node [λδ* avl/min-node [n] "" #{
10s n
08i 1 v avl/empty?
0Bo 10
10s avl/empty
09o 48
15
10s n
08i 1 v avl/left
0Es l
0D
10s l
08i 1 v avl/empty?
0Bo 10
10s n
09o 13
10s avl/min-mode
10s l
1A
01
16
01
}]] [def avl/update-left [λδ* avl/update-left [n l] "" #{
10s n
08i 1 v array/dup
02i 2
10s l
08i 3 v array/set!
01
}]] [def avl/update-right [λδ* avl/update-right [n r] "" #{
10s n
08i 1 v array/dup
02i 3
10s r
08i 3 v array/set!
01
}]] [def avl/update-key [λδ* avl/update-key [n k] "" #{
10s n
08i 1 v array/dup
02i 1
10s k
08i 3 v array/set!
01
}]] [def avl/update-root [λδ* avl/update-root [t r] "" #{
10s t
08i 1 v array/dup
02i 0
10s r
08i 3 v array/set!
01
}]] [def avl/update-height [λδ* avl/update-height [n] "" #{
10s n
08i 1 v array/dup
02i 0
02i 1
10s n
08i 1 v avl/left
08i 1 v avl/height
10s n
08i 1 v avl/right
08i 1 v avl/height
08i 2 v max
08i 2 v +
08i 3 v array/set!
01
}]] [def avl/rotate-right [λδ* avl/rotate-right [y] "" #{
15
10s y
08i 1 v avl/left
0Es x
0D
10s x
10s y
10s x
08i 1 v avl/right
08i 2 v avl/update-left
08i 1 v avl/update-height
08i 2 v avl/update-right
08i 1 v avl/update-height
16
01
}]] [def avl/rotate-left [λδ* avl/rotate-left [x] "" #{
15
10s x
08i 1 v avl/right
0Es y
0D
10s y
10s x
10s y
08i 1 v avl/left
08i 2 v avl/update-right
08i 1 v avl/update-height
08i 2 v avl/update-left
08i 1 v avl/update-height
16
01
}]] [def avl/balance [λδ* avl/balance [n] "" #{
10s n
08i 1 v avl/empty?
0Bo 8
02i 0
09o 36
10s n
08i 1 v avl/left
08i 1 v avl/height
10s n
08i 1 v avl/right
08i 1 v avl/height
08i 2 v -
01
}]] [def avl/insert-rebalance [λ* avl/insert-rebalance [n cmp v] "" [let* [do [def b [avl/balance n]] [if [> b 1] [let* [do [def ΓεnΣym-145 [cmp v [avl/key [avl/left n]]]] [if [== ΓεnΣym-145 -1] [avl/rotate-right n] [if [== ΓεnΣym-145 1] [avl/rotate-right [avl/update-left n [avl/rotate-left [avl/left n]]]] [if [== ΓεnΣym-145 0] n #nil]]]]] [if [< b -1] [let* [do [def ΓεnΣym-146 [cmp v [avl/key [avl/right n]]]] [if [== ΓεnΣym-146 1] [avl/rotate-left n] [if [== ΓεnΣym-146 -1] [avl/rotate-left [avl/update-right n [avl/rotate-right [avl/right n]]]] [if [== ΓεnΣym-146 0] n #nil]]]]] [if #t n #nil]]]]]]] [def avl/node-insert [λ* avl/node-insert [n cmp v] "" [if [avl/empty? n] [array/new 1 v avl/empty avl/empty] [let* [do [def ΓεnΣym-147 [cmp v [avl/key n]]] [if [== ΓεnΣym-147 -1] [avl/insert-rebalance [avl/update-height [avl/update-left n [avl/node-insert [avl/left n] cmp v]]] cmp v] [if [== ΓεnΣym-147 1] [avl/insert-rebalance [avl/update-height [avl/update-right n [avl/node-insert [avl/right n] cmp v]]] cmp v] [if [== ΓεnΣym-147 0] [avl/update-key n v] #nil]]]]]]]] [def avl/insert [λδ* avl/insert [t v] "Insert key V into tree T.  If a node with an equivalent key already exists, its key is updated to V" #{
10s t
10s v
08i 2 v avl/typecheck
0D
10s t
10s t
08i 1 v avl/root
10s t
08i 1 v avl/cmp
10s v
08i 3 v avl/node-insert
08i 2 v avl/update-root
01
}]] [def avl/node-get [λ* avl/node-get [n cmp v] "" [if [avl/empty? n] #nil [let* [do [def ΓεnΣym-148 [cmp v [avl/key n]]] [if [== ΓεnΣym-148 0] [avl/key n] [if [== ΓεnΣym-148 -1] [avl/node-get [avl/left n] cmp v] [if [== ΓεnΣym-148 1] [avl/node-get [avl/right n] cmp v] #nil]]]]]]]] [def avl/get [λδ* avl/get [t v] "Retrieve the key V from tree T, or #nil if V is not in it" #{
10s t
08i 1 v avl/root
08i 1 v avl/empty?
0C
0Ao 46
0D
10s v
08i 1 v type-of
10s t
08i 1 v avl/root
08i 1 v avl/key
08i 1 v type-of
08i 2 v !=
0C
0Ao 8
0D
05v #f
0Bo 7
24
09o 30
10s t
08i 1 v avl/root
10s t
08i 1 v avl/cmp
10s v
08i 3 v avl/node-get
01
}]] [def avl/from-list [λδ* avl/from-list [l cmp] "Create a new avl tree using the keys in L and the comparison function CMP" #{
10s l
10s avl/insert
10s cmp
08i 1 v avl/tree
08i 3 v list/reduce
01
}]] [def avl/remove-rebalance [λδ* avl/remove-rebalance [n] "" #{
10s n
08i 1 v avl/empty?
0Bo 10
10s n
09o 188
15
10s n
08i 1 v avl/balance
0Es b
0D
10s n
08i 1 v avl/left
0Es l
0D
10s n
08i 1 v avl/right
0Es r
0D
10s b
02i 1
22
0Bo 56
10s l
08i 1 v avl/balance
02i 0
21
0Bo 15
10s n
08i 1 v avl/rotate-right
09o 26
10s n
10s l
08i 1 v avl/rotate-left
08i 2 v avl/update-left
08i 1 v avl/rotate-right
09o 81
10s b
02i -1
1E
0Bo 56
10s r
08i 1 v avl/balance
02i 0
1F
0Bo 15
10s n
08i 1 v avl/rotate-left
09o 26
10s n
10s r
08i 1 v avl/rotate-right
08i 2 v avl/update-right
08i 1 v avl/rotate-left
09o 18
05v #t
0Bo 10
10s n
09o 4
24
16
01
}]] [def avl/node-remove [λ* avl/node-remove [n cmp v] "" [if [avl/empty? n] n [let* [do [def root [let* [do [def ΓεnΣym-149 [cmp v [avl/key n]]] [if [== ΓεnΣym-149 -1] [avl/update-left n [avl/node-remove [avl/left n] cmp v]] [if [== ΓεnΣym-149 1] [avl/update-right n [avl/node-remove [avl/right n] cmp v]] [if [== ΓεnΣym-149 0] [if [avl/empty? [avl/left n]] [avl/right n] [if [avl/empty? [avl/right n]] [avl/left n] [if #t [let* [do [def k [avl/key [avl/min-node [avl/right n]]]] [avl/update-key [avl/update-right [avl/right n] [avl/node-remove [avl/right n] cmp v]] k]]] #nil]]] #nil]]]]]] [set! root [avl/update-height root]] [avl/remove-rebalance root]]]]]] [def avl/remove [λδ* avl/remove [t v] "Remove the key V from tree T if it is contained within it" #{
10s t
10s t
08i 1 v avl/root
10s t
08i 1 v avl/cmp
10s v
08i 3 v avl/node-remove
08i 2 v avl/update-root
01
}]] [def avl/equal-node? [λδ* avl/equal-node? [a b] "" #{
10s a
08i 1 v avl/empty?
0Bo 15
10s b
08i 1 v avl/empty?
09o 82
10s a
08i 1 v avl/key
10s b
08i 1 v avl/key
08i 2 v equal?
0C
0Bo 55
0D
10s a
08i 1 v avl/left
10s b
08i 1 v avl/left
08i 2 v avl/equal-node?
0C
0Bo 27
0D
10s a
08i 1 v avl/right
10s b
08i 1 v avl/right
08i 2 v avl/equal-node?
01
}]] [def avl/equal? [λδ* avl/equal? [a b] "Test if two avl trees are equal" #{
10s a
08i 1 v avl/root
10s b
08i 1 v avl/root
08i 2 v avl/equal-node?
01
}]] [def avl/reduce-node [λδ* avl/reduce-node [node o s] "" #{
10s node
08i 1 v avl/empty?
0Bo 10
10s s
09o 58
10s o
10s node
08i 1 v avl/key
10s node
08i 1 v avl/right
10s o
10s node
08i 1 v avl/left
10s o
10s s
08i 3 v avl/reduce-node
08i 3 v avl/reduce-node
1A
02i 1 
}]] [def avl/reduce [λδ* avl/reduce [t o s] "Reduce T in-order with a reducer O taking a key and the result of the reductions of one subtree" #{
10s t
08i 1 v avl/root
10s o
10s s
08i 3 v avl/reduce-node
01
}]] [def avl/reduce-node-bin [λδ* avl/reduce-node-bin [n o s] "" #{
10s n
08i 1 v avl/empty?
0Bo 10
10s s
09o 62
10s o
10s n
08i 1 v avl/key
10s n
08i 1 v avl/left
10s o
10s s
08i 3 v avl/reduce-node-bin
10s n
08i 1 v avl/right
10s o
10s s
08i 3 v avl/reduce-node-bin
1A
03
01
}]] [def avl/reduce-bin [λδ* avl/reduce-bin [t o s] "Reduce T with a reducer O taking a key and the result of the reductions of both subtrees" #{
10s t
08i 1 v avl/root
10s o
10s s
08i 3 v avl/reduce-node-bin
01
}]] [def avl/map [λδ* avl/map [t f] "Create a new avl tree by mapping each key in T using F, using the same comparison function as T" #{
10s t
11v [:symbol :symbol] v [x acc] v "" v [avl/insert acc [f x]]
10s t
08i 1 v avl/cmp
08i 1 v avl/tree
08i 3 v avl/reduce
01
}]] [def avl/map-to [λδ* avl/map-to [t f cmp] "Create a new avl tree by mapping each key in in T using F, using the comparison function CMP, which may be different from the comparison used in T" #{
10s t
11v [:symbol :symbol] v [x acc] v "" v [avl/insert acc [f x]]
10s cmp
08i 1 v avl/tree
08i 3 v avl/reduce
01
}]] [def avl/to-list [λδ* avl/to-list [t] "" #{
10s t
10s cons
24
08i 3 v avl/reduce
01
}]]][do [def sum [λδ* sum [c] "Return the sum of every value in collection C" #{
10s c
10s +
02i 0
08i 3 v reduce
01
}]] [def join [λδ* join [l glue] "Join every element of α together into a string with GLUE inbetween" #{
10s glue
0Bo 7
24
09o 11
05v ""
0Fs glue
0D
10s l
0Bo 29
10s l
11v [:symbol :symbol] v [a b] v "" v [if a [cat a glue b] b]
24
08i 3 v reduce
09o 7
05v ""
01
}]] [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] "" #{
10s a
10s b
1E
0Bo 10
10s a
09o 7
10s b
01
}]] [def min [λδ* min l "Returns the minimum value of its arguments, or collection" #{
10s l
08i 1 v cdr
0Bo 10
10s l
09o 12
10s l
08i 1 v car
10s min/λ
24
08i 3 v reduce
01
}]] [def max/λ [λδ* max/λ [a b] "" #{
10s a
10s b
22
0Bo 10
10s a
09o 7
10s b
01
}]] [def max [λδ* max l "Returns the minimum value of its arguments, or collection" #{
10s l
08i 1 v cdr
0Bo 10
10s l
09o 12
10s l
08i 1 v car
10s max/λ
24
08i 3 v reduce
01
}]] [def delete [λδ* delete [l e] "Returns a filtered list l with all elements equal to e omitted" #{
10s l
11v [:symbol :symbol] v [a] v "" v [not [== a e]]
08i 2 v filter
01
}]] [def remove [λδ* remove [l p] "Returns a filtered list l with all elements where P equal true removed" #{
10s l
11v [:symbol :symbol] v [a] v "" v [not [p a]]
08i 2 v filter
01
}]] [def flatten/λ [λδ* flatten/λ [a b] "" #{
10s b
08i 1 v collection?
0Bo 29
10s b
10s flatten/λ
24
08i 3 v reduce
10s a
08i 2 v append
09o 27
05v #t
0Bo 19
10s b
10s a
08i 2 v cons
09o 4
24
01
}]] [def flatten [λδ* flatten [l] "Flatten a collection of collections into a simple list" #{
10s l
08i 1 v collection?
0Bo 25
10s l
10s flatten/λ
24
08i 3 v reduce
08i 1 v nreverse
09o 7
10s l
01
}]]][do [def ref [λδ* ref [l i] "Return whatver is at position I in L" #{
15
10s l
08i 1 v type-of
0Es ΓεnΣym-26
0D
10s ΓεnΣym-26
05v :nil
20
0Bo 7
24
09o 142
10s ΓεnΣym-26
05v :tree
20
0Bo 19
10s l
10s i
08i 2 v tree/ref
09o 114
10s ΓεnΣym-26
05v :string
20
0Bo 19
10s l
10s i
08i 2 v char-at
09o 86
10s ΓεnΣym-26
05v :array
20
0Bo 19
10s l
10s i
08i 2 v array/ref
09o 58
10s ΓεnΣym-26
05v :pair
20
0Bo 19
10s l
10s i
08i 2 v list/ref
09o 30
05v :type-error
05v "You can only use ref with a collection"
10s l
08i 0 v current-lambda
08i 4 v list
08i 1 v throw
16
01
}]] [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" #{
15
10s l
08i 1 v type-of
0Es ΓεnΣym-151
0D
10s ΓεnΣym-151
05v :nil
20
0Bo 7
24
09o 114
10s ΓεnΣym-151
05v :tree
20
0Bo 19
10s l
10s p
08i 2 v tree/filter
09o 86
10s ΓεnΣym-151
05v :pair
20
0Bo 19
10s l
10s p
08i 2 v list/filter
09o 58
10s ΓεnΣym-151
05v :array
20
0Bo 19
10s l
10s p
08i 2 v array/filter
09o 30
05v :type-error
05v "You can only use filter with a collection"
10s l
08i 0 v current-lambda
08i 4 v list
08i 1 v throw
16
01
}]] [def reduce [λδ* reduce [l f α] "Combine all elements in collection l using operation F and starting value α" #{
15
10s l
08i 1 v type-of
0Es ΓεnΣym-152
0D
10s ΓεnΣym-152
05v :nil
20
0Bo 10
10s α
09o 113
10s ΓεnΣym-152
05v :tree
20
0Bo 23
10s l
10s f
10s α
08i 3 v tree/reduce
09o 81
10s ΓεnΣym-152
05v :pair
20
0Bo 23
10s l
10s f
10s α
08i 3 v list/reduce
09o 49
10s ΓεnΣym-152
05v :array
20
0Bo 23
10s l
10s f
10s α
08i 3 v array/reduce
09o 17
10s f
10s α
10s l
1A
02i 22
01
}]] [def length [λδ* length [α] "Returns the length of collection α" #{
15
10s α
08i 1 v type-of
0Es ΓεnΣym-153
0D
10s ΓεnΣym-153
05v :nil
20
0Bo 8
02i 0
09o 126
10s ΓεnΣym-153
05v :array
20
0Bo 15
10s α
08i 1 v array/length
09o 102
10s ΓεnΣym-153
05v :pair
20
0Bo 15
10s α
08i 1 v list/length
09o 78
10s ΓεnΣym-153
05v :string
20
0Bo 15
10s α
08i 1 v string/length
09o 54
10s ΓεnΣym-153
05v :tree
20
0Bo 15
10s α
08i 1 v tree/size
09o 30
05v :type-error
05v "You can only use length with a collection"
10s α
08i 0 v current-lambda
08i 4 v list
08i 1 v throw
16
01
}]] [def map [λ* map [l f] "Runs f over every item in collection l and returns the resulting list" [let* [do [def ΓεnΣym-154 [type-of l]] [if [== ΓεnΣym-154 :nil] #nil [if [== ΓεnΣym-154 :pair] [list/map l f] [if [== ΓεnΣym-154 :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" #{
15
10s l
08i 1 v type-of
0Es ΓεnΣym-155
0D
10s ΓεnΣym-155
05v :nil
20
0Bo 7
24
09o 78
10s ΓεnΣym-155
05v :pair
20
0Bo 15
10s l
08i 1 v list/sort/merge
09o 54
10s ΓεnΣym-155
05v :array
20
0Bo 15
10s l
08i 1 v array/heap-sort
09o 30
05v :type-error
05v "You can only use sort with a collection"
10s l
08i 0 v current-lambda
08i 4 v list
08i 1 v throw
16
01
}]] [def member [λδ* member [l m] "Returns the first pair/item of collection l whose car is equal to m" #{
15
10s l
08i 1 v type-of
0Es ΓεnΣym-156
0D
10s ΓεnΣym-156
05v :pair
20
0Bo 19
10s l
10s m
08i 2 v list/member
09o 30
05v :type-error
05v "You can only use member with a collection"
10s l
08i 0 v current-lambda
08i 4 v list
08i 1 v throw
16
01
}]] [def cut [λδ* cut [l start end] "Return a subcollection of L from START to END" #{
15
10s l
08i 1 v type-of
0Es ΓεnΣym-157
0D
10s ΓεnΣym-157
05v :array
20
0Bo 23
10s l
10s start
10s end
08i 3 v array/cut
09o 94
10s ΓεnΣym-157
05v :pair
20
0Bo 23
10s l
10s start
10s end
08i 3 v list/cut
09o 62
10s ΓεnΣym-157
05v :string
20
0Bo 23
10s l
10s start
10s end
08i 3 v string/cut
09o 30
05v :type-error
05v "You can only use member with a collection"
10s l
08i 0 v current-lambda
08i 4 v list
08i 1 v throw
16
01
}]] [def collection? [λδ* collection? [l] "" #{
15
10s l
08i 1 v type-of
0Es ΓεnΣym-158
0D
10s ΓεnΣym-158
05v :pair
20
0C
0Ao 36
0D
10s ΓεnΣym-158
05v :array
20
0C
0Ao 22
0D
10s ΓεnΣym-158
05v :tree
20
0C
0Ao 8
0D
05v #f
0Bo 10
05v #t
09o 7
05v #f
16
01
}]]][do [def except-last-pair/iter [λδ* except-last-pair/iter [list rest] "Iterator for except-last-pair" #{
10s list
08i 1 v cdr
08i 1 v nil?
0Bo 15
10s rest
08i 1 v reverse
09o 35
10s list
08i 1 v cdr
10s list
08i 1 v car
10s rest
08i 2 v cons
08i 2 v except-last-pair/iter
01
}]] [def except-last-pair [λδ* except-last-pair [list] "Return a copy of LIST without the last pair" #{
10s list
24
08i 2 v except-last-pair/iter
01
}]] [def last-pair [λδ* last-pair [list] "Return the last pair of LIST" #{
02i 0
1B
1C
10s list
08i 1 v cdr
0Bo 20
0D
10s list
08i 1 v cdr
0Fs list
09o -27
0D
10s list
01
}]] [def make-list [λδ* make-list [number value] "Return a list of NUMBER elements containing VALUE in every car" #{
24
0Es list
0D
02i 0
1B
1C
02i -1
10s number
08i 2 v +
0Fs number
02i 0
21
0Bo 24
0D
10s value
10s list
08i 2 v cons
0Fs list
09o -40
0D
10s list
01
}]] [def range [λδ* range [end start step] "Return a list containing values from START (inclusive) to END (exclusive) by STEP" #{
10s end
0Bo 7
24
09o 21
05v :arity-error
05v "[range] needs at least a specific end"
08i 2 v list
08i 1 v throw
0D
10s start
0Bo 7
24
09o 9
02i 0
0Fs start
0D
10s step
0Bo 7
24
09o 9
02i 1
0Fs step
0D
10s step
08i 1 v pos?
0Bo 10
10s <
09o 7
10s >
0Es pred
0D
24
0Es ret
0D
02i 0
1B
1C
10s pred
10s start
10s end
1A
02i 11
00
2A
0D
10s start
10s ret
08i 2 v cons
0Fs ret
0D
10s start
10s step
08i 2 v +
0Fs start
09o -54
0D
10s ret
08i 1 v nreverse
01
}]] [def list/reduce [λδ* list/reduce [l o s] "Combine all elements in l using operation o and starting value s" #{
15
10s l
0Es ΓεnΣym-159
0D
10s ΓεnΣym-159
0Bo 67
02i 0
1B
1C
10s ΓεnΣym-159
0Bo 53
0D
10s ΓεnΣym-159
08i 1 v car
0Es e
0D
10s o
10s s
10s e
1A
02i 15
00
00
8A
0D
10s ΓεnΣym-159
08i 1 v cdr
0Fs ΓεnΣym-159
09o -55
09o 4
24
16
0D
10s s
01
}]] [def list/ref [λδ* list/ref [l i] "Returns the the element of list l at location i" #{
02i 0
1B
1C
10s l
0C
0Bo 11
0D
10s i
02i 0
22
0Bo 36
0D
02i -1
10s i
08i 2 v +
0Fs i
0D
10s l
08i 1 v cdr
0Fs l
09o -50
0D
10s l
08i 1 v car
01
}]] [def reverse [λδ* reverse [l] "Return the list l in reverse order" #{
24
0Es ret
0D
15
10s l
0Es ΓεnΣym-160
0D
10s ΓεnΣym-160
0Bo 66
02i 0
1B
1C
10s ΓεnΣym-160
0Bo 52
0D
10s ΓεnΣym-160
08i 1 v car
0Es e
0D
10s e
10s ret
08i 2 v cons
0Fs ret
0D
10s ΓεnΣym-160
08i 1 v cdr
0Fs ΓεnΣym-160
09o -54
09o 4
24
16
0D
10s ret
01
}]] [def list/length [λδ* list/length [l] "Returns the length of list l" #{
02i 0
0Es ret
0D
15
10s l
0Es ΓεnΣym-161
0D
10s ΓεnΣym-161
0Bo 64
02i 0
1B
1C
10s ΓεnΣym-161
0Bo 50
0D
10s ΓεnΣym-161
08i 1 v car
0Es e
0D
02i 1
10s ret
08i 2 v +
0Fs ret
0D
10s ΓεnΣym-161
08i 1 v cdr
0Fs ΓεnΣym-161
09o -52
09o 4
24
16
0D
10s ret
01
}]] [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" #{
24
0Es ret
0D
15
10s l
0Es ΓεnΣym-162
0D
10s ΓεnΣym-162
0Bo 83
02i 0
1B
1C
10s ΓεnΣym-162
0Bo 69
0D
10s ΓεnΣym-162
08i 1 v car
0Es e
0D
10s p
10s e
1A
01
0Bo 23
10s e
10s ret
08i 2 v cons
0Fs ret
09o 4
24
0D
10s ΓεnΣym-162
08i 1 v cdr
0Fs ΓεnΣym-162
09o -71
09o 4
24
16
0D
10s ret
08i 1 v nreverse
01
}]] [def list/map [λδ* list/map [l f] "Runs f over every item in list l and returns the resulting list" #{
24
0Es ret
0D
15
10s l
0Es ΓεnΣym-163
0D
10s ΓεnΣym-163
0Bo 72
02i 0
1B
1C
10s ΓεnΣym-163
0Bo 58
0D
10s ΓεnΣym-163
08i 1 v car
0Es e
0D
10s f
10s e
1A
01
10s ret
08i 2 v cons
0Fs ret
0D
10s ΓεnΣym-163
08i 1 v cdr
0Fs ΓεnΣym-163
09o -60
09o 4
24
16
0D
10s ret
08i 1 v nreverse
01
}]] [def append/iter [λδ* append/iter [a b] "Iterator for append" #{
10s a
08i 1 v nil?
0Bo 10
10s b
09o 35
10s a
08i 1 v cdr
10s a
08i 1 v car
10s b
08i 2 v cons
08i 2 v append/iter
01
}]] [def append [λδ* append [a . b] "Appends two lists A and B together" #{
02i 0
1B
1C
10s b
0Bo 48
0D
10s a
08i 1 v reverse
10s b
08i 1 v car
08i 2 v append/iter
0Fs a
0D
10s b
08i 1 v cdr
0Fs b
09o -50
0D
10s a
01
}]] [def sublist [λδ* sublist [l start end ret] "Returns a new list containing all elements of l from start to end" #{
10s l
08i 1 v nil?
0Bo 15
10s ret
08i 1 v reverse
09o 182
10s end
08i 1 v neg?
0Bo 37
10s l
10s start
10s l
08i 1 v length
10s end
08i 2 v +
08i 3 v sublist
09o 136
10s end
08i 1 v zero?
0Bo 15
10s ret
08i 1 v reverse
09o 112
10s start
02i 0
22
0Bo 43
10s l
08i 1 v cdr
02i -1
10s start
08i 2 v +
02i -1
10s end
08i 2 v +
24
08i 4 v sublist
09o 62
10s end
02i 0
22
0Bo 51
10s l
08i 1 v cdr
02i 0
02i -1
10s end
08i 2 v +
10s l
08i 1 v car
10s ret
08i 2 v cons
08i 4 v sublist
09o 4
24
01
}]] [def list-head [λδ* list-head [l k] "Returns the first k elements of list l" #{
10s l
02i 0
10s k
08i 3 v sublist
01
}]] [def list-tail [λδ* list-tail [l k] "Returns the sublist of l obtained by omitting the first l elements" #{
10s l
10s k
10s l
08i 1 v length
08i 3 v sublist
01
}]] [def list/member [λδ* list/member [l m] "Returns the first pair of list l whose car is equal to m" #{
10s l
08i 1 v nil?
0Bo 10
05v #f
09o 56
10s l
08i 1 v car
10s m
20
0Bo 10
10s l
09o 32
05v #t
0Bo 24
10s l
08i 1 v cdr
10s m
08i 2 v list/member
09o 4
24
01
}]] [def getf [λδ* getf [l key] "Return the value in LIST following KEY" #{
10s l
08i 1 v nil?
0Bo 7
24
09o 61
10s key
10s l
08i 1 v car
20
0Bo 15
10s l
08i 1 v cadr
09o 32
05v #t
0Bo 24
10s l
08i 1 v cdr
10s key
08i 2 v getf
09o 4
24
01
}]] [def list/sort/bubble [λδ* list/sort/bubble [l] "Terribly slow way to sort a list, though it was simple to write" #{
10s l
0Bo 161
10s l
08i 1 v car
0Es top
0D
24
0Es next
0D
10s l
08i 1 v cdr
0Fs l
0D
02i 0
1B
1C
10s l
0Bo 94
0D
10s l
08i 1 v car
10s top
1F
0Bo 37
10s top
10s next
08i 2 v cons
0Fs next
0D
10s l
08i 1 v car
0Fs top
09o 25
10s l
08i 1 v car
10s next
08i 2 v cons
0Fs next
0D
10s l
08i 1 v cdr
0Fs l
09o -96
0D
10s top
10s next
08i 1 v list/sort/bubble
08i 2 v cons
09o 4
24
01
}]] [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" #{
10s l
08i 1 v cdr
08i 1 v nil?
0Bo 10
10s l
09o 50
10s l
08i 1 v list/split-half
0Es parts
0D
10s parts
08i 1 v car
08i 1 v list/sort/merge
10s parts
08i 1 v cdr
08i 1 v list/sort/merge
08i 2 v list/merge-sorted-lists
01
}]] [def list/sort list/sort/merge] [def list/equal? [λδ* list/equal? [a b] "#t if A and B are equal" #{
10s a
08i 1 v pair?
0Bo 57
10s a
08i 1 v car
10s b
08i 1 v car
08i 2 v list/equal?
0C
0Bo 27
0D
10s a
08i 1 v cdr
10s b
08i 1 v cdr
08i 2 v list/equal?
09o 16
10s a
10s b
08i 2 v equal?
01
}]] [def list/take [λδ* list/take [l count] "Take the first COUNT elements from list L" #{
10s count
02i 0
1F
0Bo 7
24
09o 42
10s l
08i 1 v car
10s l
08i 1 v cdr
10s count
02i 1
08i 2 v -
08i 2 v list/take
08i 2 v cons
01
}]] [def list/drop [λδ* list/drop [l count] "Drop the final COUNT elements from list L" #{
10s count
02i 0
1F
0Bo 10
10s l
09o 28
10s l
08i 1 v cdr
10s count
02i 1
08i 2 v -
08i 2 v list/drop
01
}]] [def list/cut [λδ* list/cut [l start end] "Return a subsequence of L from START to END" #{
10s l
02i 0
10s start
08i 2 v max
08i 2 v list/drop
10s end
02i 0
10s start
08i 2 v max
08i 2 v -
08i 2 v list/take
01
}]]][do [def tree/zip [λδ* tree/zip [keys values] "Return a tree where KEYS point to VALUES" #{
24
08i 1 v tree/new
0Es ret
0D
15
10s keys
0Es ΓεnΣym-35
0D
10s ΓεnΣym-35
0Bo 85
02i 0
1B
1C
10s ΓεnΣym-35
0Bo 71
0D
10s ΓεnΣym-35
08i 1 v car
0Es key
0D
10s ret
10s key
10s values
08i 1 v car
08i 3 v tree/set!
0D
10s values
08i 1 v cdr
0Fs values
0D
10s ΓεnΣym-35
08i 1 v cdr
0Fs ΓεnΣym-35
09o -73
09o 4
24
16
0D
10s ret
01
}]] [def tree/+= [λδ* tree/+= [t k v] "Increment value at K in T by V" #{
10s t
10s k
10s v
10s t
10s k
08i 2 v tree/ref
08i 1 v int
08i 2 v +
08i 3 v tree/set!
01
}]] [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" #{
10s a
08i 1 v tree?
0C
0Bo 13
0D
10s b
08i 1 v tree?
0Bo 109
10s a
08i 1 v tree/key*
10s b
08i 1 v tree/key*
20
0C
0Bo 83
0D
10s a
08i 1 v tree/value*
10s b
08i 1 v tree/value*
08i 2 v equal?
0C
0Bo 55
0D
10s a
08i 1 v tree/left*
10s b
08i 1 v tree/left*
08i 2 v tree/equal?
0C
0Bo 27
0D
10s a
08i 1 v tree/right*
10s b
08i 1 v tree/right*
08i 2 v tree/equal?
09o 16
10s a
10s b
08i 2 v equal?
01
}]] [def tree/reduce [λδ* tree/reduce [l o s] "Combine all elements in l using operation o and starting value s" #{
15
10s l
08i 1 v tree/keys
0Es ΓεnΣym-164
0D
10s ΓεnΣym-164
0Bo 80
02i 0
1B
1C
10s ΓεnΣym-164
0Bo 66
0D
10s ΓεnΣym-164
08i 1 v car
0Es e
0D
10s o
10s l
10s e
08i 2 v tree/ref
10s s
10s e
1A
03
0Fs s
0D
10s ΓεnΣym-164
08i 1 v cdr
0Fs ΓεnΣym-164
09o -68
09o 4
24
16
0D
10s s
01
}]] [def tree/filter [λδ* tree/filter [l f] "Return a new tree with all elements from L where F retunrs true" #{
24
08i 1 v tree/new
0Es ret
0D
15
10s l
08i 1 v tree/keys
0Es ΓεnΣym-165
0D
10s ΓεnΣym-165
0Bo 101
02i 0
1B
1C
10s ΓεnΣym-165
0Bo 87
0D
10s ΓεnΣym-165
08i 1 v car
0Es e
0D
10s l
10s e
08i 2 v tree/ref
0Es t
0D
10s f
10s t
1A
01
0Bo 23
10s ret
10s e
10s t
08i 3 v tree/set!
09o 4
24
0D
10s ΓεnΣym-165
08i 1 v cdr
0Fs ΓεnΣym-165
09o -89
09o 4
24
16
0D
10s ret
01
}]]][do [def val->bytecode-op [λδ* val->bytecode-op [v] "" #{
10s v
08i 1 v val->index
0Es i
0D
10s i
02i 16
08i 2 v >>
05v 255
08i 2 v logand
08i 1 v int->bytecode-op
10s i
02i 8
08i 2 v >>
05v 255
08i 2 v logand
08i 1 v int->bytecode-op
10s i
05v 255
08i 2 v logand
08i 1 v int->bytecode-op
08i 3 v list
01
}]] [def sym->bytecode-op [λδ* sym->bytecode-op [v] "" #{
10s v
08i 1 v sym->index
0Es i
0D
10s i
02i 16
08i 2 v >>
05v 255
08i 2 v logand
08i 1 v int->bytecode-op
10s i
02i 8
08i 2 v >>
05v 255
08i 2 v logand
08i 1 v int->bytecode-op
10s i
05v 255
08i 2 v logand
08i 1 v int->bytecode-op
08i 3 v list
01
}]] [def int-fit-in-byte? [λδ* int-fit-in-byte? [a] "" #{
10s a
02i 127
1F
0C
0Bo 11
0D
10s a
02i -128
21
01
}]] [def $nop [λδ* $nop [] "- | Do nothing" #{
05v [#$0]
01
}]] [def $ret [λδ* $ret [] "a - | Return top of value stack" #{
05v [#$1]
01
}]] [def $push/int/byte [λδ* $push/int/byte [a] "- a | Return top of value stack" #{
10s a
08i 1 v int-fit-in-byte?
0Bo 7
24
09o 30
05v :invalid-bc-op
05v "$push/int/byte can only push a signed 8-bit value"
10s a
08i 0 v current-lambda
08i 4 v list
08i 1 v throw
0D
05v #$2
10s a
08i 1 v int->bytecode-op
08i 2 v list
01
}]] [def $push/int [λδ* $push/int [a] "- a | Return top of value stack" #{
10s a
08i 1 v int-fit-in-byte?
0Bo 15
10s a
08i 1 v $push/int/byte
09o 12
10s a
08i 1 v $push/lval
01
}]] [def $add/int [λδ* $add/int [] "a b - c | Adds the two topmost values and pushes the result" #{
05v [#$3]
01
}]] [def $debug/print-stack [λδ* $debug/print-stack [] "- | Print out the stack for the current closure" #{
05v [#$4]
01
}]] [def $push/lval [λδ* $push/lval [v] "- v | Pushes v onto the stack" #{
10s v
08i 1 v nil?
0Bo 33
05v :invalid-bc-op
05v "Can't push #nil as a normal lVal"
10s v
08i 0 v current-lambda
08i 4 v list
08i 1 v throw
09o 4
24
0D
05v #$5
10s v
08i 1 v val->bytecode-op
08i 2 v list
01
}]] [def $push/symbol [λδ* $push/symbol [v] "- v | Pushes v onto the stack" #{
05v #$23
10s v
08i 1 v sym->bytecode-op
08i 2 v list
01
}]] [def $make-list [λδ* $make-list [item-count] "items ... - list | Makes a list of item-count items from the stack and pushes the resulting list" #{
05v #$6
10s item-count
08i 1 v int->bytecode-op
08i 2 v list
01
}]] [def $eval [λδ* $eval [a] "form - | Evaluates the form from the top of the stack" #{
05v [#$7]
01
}]] [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" #{
15
10s arg-count
0Es ΓεnΣym-166
0D
10s ΓεnΣym-166
24
20
0Bo 10
10s do
09o 201
10s ΓεnΣym-166
02i 2
20
0Bo 164
15
10s fun
0Es ΓεnΣym-167
0D
10s ΓεnΣym-167
10s add/int
20
0Bo 11
08i 0 v $add/int
09o 130
10s ΓεnΣym-167
10s <
20
0Bo 11
08i 0 v $<
09o 110
10s ΓεnΣym-167
10s <=
20
0Bo 11
08i 0 v $<=
09o 90
10s ΓεnΣym-167
10s ==
20
0Bo 11
08i 0 v $==
09o 70
10s ΓεnΣym-167
10s >=
20
0Bo 11
08i 0 v $>=
09o 50
10s ΓεnΣym-167
10s >
20
0Bo 11
08i 0 v $>
09o 30
05v #$8
10s arg-count
08i 1 v int->bytecode-op
10s fun
08i 1 v val->bytecode-op
08i 3 v list
16
09o 30
05v #$8
10s arg-count
08i 1 v int->bytecode-op
10s fun
08i 1 v val->bytecode-op
08i 3 v list
16
01
}]] [def $apply/dynamic [λδ* $apply/dynamic [arg-count fun] "" #{
05v #$1A
10s arg-count
08i 1 v int->bytecode-op
08i 2 v list
01
}]] [def $call [λδ* $call [target] " - | Call a bytecode subroutine" #{
05v #$17
05v :relocate
10s target
02i 8
02i 0
02i 0
08i 1 v int->bytecode-op
08i 5 v list
05v :relocate
10s target
02i 0
02i 1
02i 0
08i 1 v int->bytecode-op
08i 5 v list
08i 3 v list
01
}]] [def $try [λδ* $try [target] " - | Try something, jumping to target if an exception occurs" #{
05v #$18
05v :relocate
10s target
02i 8
02i 0
02i 0
08i 1 v int->bytecode-op
08i 5 v list
05v :relocate
10s target
02i 0
02i 1
02i 0
08i 1 v int->bytecode-op
08i 5 v list
08i 3 v list
01
}]] [def $throw [λδ* $throw [] " - | Return to the closest exception handler" #{
05v #$19
08i 1 v list
01
}]] [def $jmp [λδ* $jmp [target] "" #{
05v #$9
05v :relocate
10s target
02i 8
02i 0
02i 0
08i 1 v int->bytecode-op
08i 5 v list
05v :relocate
10s target
02i 0
02i 1
02i 0
08i 1 v int->bytecode-op
08i 5 v list
08i 3 v list
01
}]] [def $jt [λδ* $jt [target] "" #{
05v #$A
05v :relocate
10s target
02i 8
02i 0
02i 0
08i 1 v int->bytecode-op
08i 5 v list
05v :relocate
10s target
02i 0
02i 1
02i 0
08i 1 v int->bytecode-op
08i 5 v list
08i 3 v list
01
}]] [def $jf [λδ* $jf [target] "" #{
05v #$B
05v :relocate
10s target
02i 8
02i 0
02i 0
08i 1 v int->bytecode-op
08i 5 v list
05v :relocate
10s target
02i 0
02i 1
02i 0
08i 1 v int->bytecode-op
08i 5 v list
08i 3 v list
01
}]] [def $dup [λδ* $dup [] "" #{
05v [#$C]
01
}]] [def $drop [λδ* $drop [] "" #{
05v [#$D]
01
}]] [def $def [λδ* $def [v] "" #{
05v #$E
10s v
08i 1 v sym->bytecode-op
08i 2 v list
01
}]] [def $set [λδ* $set [v] "" #{
05v #$F
10s v
08i 1 v sym->bytecode-op
08i 2 v list
01
}]] [def $get [λδ* $get [v] "" #{
05v #$10
10s v
08i 1 v sym->bytecode-op
08i 2 v list
01
}]] [def $lambda [λδ* $lambda [name args docs body] "" #{
05v #$11
10s name
08i 1 v val->bytecode-op
10s args
08i 1 v val->bytecode-op
10s docs
08i 1 v val->bytecode-op
10s body
08i 1 v val->bytecode-op
08i 5 v list
01
}]] [def $macro [λδ* $macro [name args docs body] "" #{
05v #$12
10s name
08i 1 v val->bytecode-op
10s args
08i 1 v val->bytecode-op
10s docs
08i 1 v val->bytecode-op
10s body
08i 1 v val->bytecode-op
08i 5 v list
01
}]] [def $closure/push [λδ* $closure/push [] "" #{
05v [#$13]
01
}]] [def $closure/enter [λδ* $closure/enter [] "" #{
05v [#$14]
01
}]] [def $let [λδ* $let [] "" #{
05v [#$15]
01
}]] [def $closure/pop [λδ* $closure/pop [] "" #{
05v [#$16]
01
}]] [def $roots/save [λδ* $roots/save [] "" #{
05v [#$1B]
01
}]] [def $roots/restore [λδ* $roots/restore [] "" #{
05v [#$1C]
01
}]] [def $< [λδ* $< [] "" #{
05v [#$1E]
01
}]] [def $<= [λδ* $<= [] "" #{
05v [#$1F]
01
}]] [def $== [λδ* $== [] "" #{
05v [#$20]
01
}]] [def $>= [λδ* $>= [] "" #{
05v [#$21]
01
}]] [def $> [λδ* $> [] "" #{
05v [#$22]
01
}]] [def $push/nil [λδ* $push/nil [] "" #{
05v [#$24]
01
}]] [def assemble/build-sym-map [λδ* assemble/build-sym-map [code sym-map pos] "" #{
02i 0
1B
1C
10s code
0Bo 206
0D
15
10s code
08i 1 v car
08i 1 v type-of
0Es ΓεnΣym-168
0D
10s ΓεnΣym-168
05v :bytecode-op
20
0Bo 34
10s sym-map
05v :last-op
02i 1
10s pos
08i 2 v +
0Fs pos
08i 3 v tree/set!
09o 124
10s ΓεnΣym-168
05v :symbol
20
0C
0Ao 22
0D
10s ΓεnΣym-168
05v :keyword
20
0C
0Ao 8
0D
05v #f
0Bo 47
10s code
08i 1 v car
05v :label
20
0C
0Bo 26
0D
10s sym-map
10s code
08i 1 v cadr
10s pos
08i 3 v tree/set!
09o 45
10s ΓεnΣym-168
05v :pair
20
0Bo 32
10s code
08i 1 v car
10s sym-map
10s pos
08i 3 v assemble/build-sym-map
0Fs pos
09o 4
24
16
0D
10s code
08i 1 v cdr
0Fs code
09o -208
0D
10s pos
01
}]] [def assemble/relocate-op [λδ* assemble/relocate-op [code sym-map pos out] "" #{
10s sym-map
10s code
08i 1 v cadr
08i 2 v tree/ref
0Es target
0D
10s target
10s code
08i 1 v cadddr
08i 2 v +
10s pos
08i 2 v -
0Es off
0D
10s out
02i 1
10s pos
08i 2 v +
0Fs pos
10s off
10s code
08i 1 v caddr
08i 2 v >>
05v 255
08i 2 v logand
08i 1 v int->bytecode-op
08i 3 v array/set!
0D
10s pos
01
}]] [def assemble/emit-relocated-ops [λδ* assemble/emit-relocated-ops [code sym-map pos out] "" #{
10s code
08i 1 v car
05v :relocate
20
0Bo 31
10s code
10s sym-map
10s pos
10s out
08i 4 v assemble/relocate-op
0Fs pos
09o 168
15
10s code
0Es ΓεnΣym-169
0D
10s ΓεnΣym-169
0Bo 149
02i 0
1B
1C
10s ΓεnΣym-169
0Bo 135
0D
10s ΓεnΣym-169
08i 1 v car
0Es op
0D
15
10s op
08i 1 v type-of
0Es ΓεnΣym-170
0D
10s ΓεnΣym-170
05v :bytecode-op
20
0Bo 34
10s out
02i 1
10s pos
08i 2 v +
0Fs pos
10s op
08i 3 v array/set!
09o 44
10s ΓεnΣym-170
05v :pair
20
0Bo 31
10s op
10s sym-map
10s pos
10s out
08i 4 v assemble/emit-relocated-ops
0Fs pos
09o 4
24
16
0D
10s ΓεnΣym-169
08i 1 v cdr
0Fs ΓεnΣym-169
09o -137
09o 4
24
16
0D
10s pos
01
}]] [def assemble/verbose #f] [def assemble* [λδ* assemble* [code] "Assemble all arguments into a single :bytecode-array" #{
24
08i 1 v tree/new
0Es sym-map
0D
10s assemble/verbose
0C
0Bo 32
0D
05v "Input:\n"
10s code
08i 1 v str/write
08i 2 v ansi-blue
08i 1 v cat
08i 1 v println
0D
10s code
10s sym-map
02i 0
08i 3 v assemble/build-sym-map
0D
10s assemble/verbose
0C
0Bo 32
0D
05v "Symbol Map:\n"
10s sym-map
08i 1 v str/write
08i 2 v ansi-yellow
08i 1 v cat
08i 1 v println
0D
10s sym-map
05v :last-op
08i 2 v tree/ref
08i 1 v array/allocate
0Es out
0D
10s code
10s sym-map
02i -1
10s out
08i 4 v assemble/emit-relocated-ops
0D
10s assemble/verbose
0C
0Bo 32
0D
05v "Output:\n"
10s out
08i 1 v str/write
08i 2 v ansi-green
08i 1 v cat
08i 1 v println
0D
10s out
08i 1 v arr->bytecode-arr
01
}]] [def assemble [λδ* assemble l "Assemble all arguments into a single :bytecode-array" #{
10s l
08i 1 v assemble*
01
}]] [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] "" #{
02i 1
10s bytecompile/gen-label/counter
08i 2 v +
0Fs bytecompile/gen-label/counter
0D
10s prefix
05v "label-"
10s bytecompile/gen-label/counter
08i 3 v cat
08i 1 v str->sym
01
}]] [def bytecompile/literal [λδ* bytecompile/literal [source] "" #{
15
10s source
08i 1 v type-of
0Es ΓεnΣym-171
0D
10s ΓεnΣym-171
05v :symbol
20
0C
0Ao 22
0D
10s ΓεnΣym-171
05v :keyword
20
0C
0Ao 8
0D
05v #f
0Bo 39
10s source
08i 1 v keyword?
0Bo 15
10s source
08i 1 v $push/lval
09o 12
10s source
08i 1 v $get
09o 56
10s ΓεnΣym-171
05v :int
20
0Bo 15
10s source
08i 1 v $push/int
09o 32
10s ΓεnΣym-171
05v :nil
20
0Bo 11
08i 0 v $push/nil
09o 12
10s source
08i 1 v $push/lval
16
01
}]] [def bytecompile/quote [λδ* bytecompile/quote [source] "" #{
15
10s source
08i 1 v type-of
0Es ΓεnΣym-172
0D
10s ΓεnΣym-172
05v :int
20
0Bo 15
10s source
08i 1 v $push/int
09o 36
10s ΓεnΣym-172
05v :symbol
20
0Bo 15
10s source
08i 1 v $push/symbol
09o 12
10s source
08i 1 v $push/lval
16
01
}]] [def bytecompile/do/form [λδ* bytecompile/do/form [source env] "" #{
10s source
0Bo 79
10s source
08i 1 v car
10s env
08i 2 v bytecompile*
10s source
08i 1 v last?
0Bo 7
24
09o 14
08i 0 v $drop
24
08i 2 v cons
08i 2 v cons
10s source
08i 1 v cdr
10s env
08i 2 v bytecompile/do/form
08i 2 v cons
09o 4
24
01
}]] [def bytecompile/do [λδ* bytecompile/do [source env] "" #{
10s source
08i 1 v cdr
10s env
08i 2 v bytecompile/do/form
08i 1 v list
01
}]] [def bytecompile/procedure [λδ* bytecompile/procedure [op source env] "" #{
10s source
08i 1 v cdr
10s bytecompile*
08i 2 v map
0Es args
0D
10s args
10s args
08i 1 v length
10s op
08i 2 v $apply
08i 2 v list
01
}]] [def bytecompile/def [λδ* bytecompile/def [source env] "" #{
10s source
08i 1 v cadr
08i 1 v symbol?
08i 1 v not
0C
0Ao 27
0D
10s source
08i 1 v cddr
08i 1 v not
0C
0Ao 8
0D
05v #f
0Bo 29
05v :type-error
05v "[def] needs a symbol name and a value as arguments"
24
10s env
08i 4 v list
08i 1 v throw
09o 4
24
0D
10s source
08i 1 v caddr
10s env
08i 2 v bytecompile*
10s source
08i 1 v cadr
08i 1 v $def
08i 2 v list
01
}]] [def bytecompile/set! [λδ* bytecompile/set! [source env] "" #{
10s source
08i 1 v cadr
08i 1 v symbol?
08i 1 v not
0C
0Ao 27
0D
10s source
08i 1 v cddr
08i 1 v not
0C
0Ao 8
0D
05v #f
0Bo 29
05v :type-error
05v "[set!] needs a symbol name and a value as arguments"
24
10s env
08i 4 v list
08i 1 v throw
09o 4
24
0D
10s source
08i 1 v caddr
10s env
08i 2 v bytecompile*
10s source
08i 1 v cadr
08i 1 v $set
08i 2 v list
01
}]] [def bytecompile/if [λδ* bytecompile/if [source env] "" #{
15
08i 0 v bytecompile/gen-label
0Es sym-else
0D
08i 0 v bytecompile/gen-label
0Es sym-after
0D
10s source
08i 1 v cadr
10s env
08i 2 v bytecompile*
10s sym-else
08i 1 v $jf
10s source
08i 1 v caddr
10s env
08i 2 v bytecompile*
10s sym-after
08i 1 v $jmp
05v :label
10s sym-else
08i 2 v list
10s source
08i 1 v cadddr
10s env
08i 2 v bytecompile*
05v :label
10s sym-after
08i 2 v list
08i 7 v list
16
01
}]] [def bytecompile/while [λδ* bytecompile/while [source env] "" #{
08i 0 v bytecompile/gen-label
0Es sym-start
0D
08i 0 v bytecompile/gen-label
0Es sym-end
0D
02i 0
08i 1 v $push/int
08i 0 v $roots/save
05v :label
10s sym-start
08i 2 v list
08i 0 v $roots/restore
10s source
08i 1 v cadr
10s env
08i 2 v bytecompile*
10s sym-end
08i 1 v $jf
08i 0 v $drop
10s source
08i 1 v cddr
10s env
08i 2 v bytecompile/do/form
10s sym-start
08i 1 v $jmp
05v :label
10s sym-end
08i 2 v list
08i 10 v list
01
}]] [def bytecompile/procedure/arg [λδ* bytecompile/procedure/arg [source env] "" #{
10s source
08i 1 v last?
0Bo 24
10s source
08i 1 v car
10s env
08i 2 v bytecompile*
09o 44
10s source
08i 1 v car
10s env
08i 2 v bytecompile*
10s source
08i 1 v cdr
10s env
08i 2 v bytecompile/procedure/arg
08i 2 v cons
01
}]] [def bytecompile/procedure [λδ* bytecompile/procedure [op args env] "" #{
10s args
08i 1 v length
0Es arg-count
0D
10s args
0Bo 33
10s args
08i 1 v bytecompile/procedure/arg
10s arg-count
10s op
08i 2 v $apply
08i 2 v list
09o 14
02i 0
10s op
08i 2 v $apply
01
}]] [def bytecompile/procedure/dynamic [λδ* bytecompile/procedure/dynamic [op args env] "" #{
10s args
08i 1 v length
0Es arg-count
0D
10s op
10s env
08i 2 v bytecompile*
10s args
0Bo 15
10s args
08i 1 v bytecompile/procedure/arg
09o 4
24
10s arg-count
08i 1 v $apply/dynamic
08i 3 v list
01
}]] [def bytecompile/and/rec [λδ* bytecompile/and/rec [source env label-end] "" #{
10s source
08i 1 v car
10s env
08i 2 v bytecompile*
10s source
08i 1 v cdr
0Bo 52
08i 0 v $dup
10s label-end
08i 1 v $jf
08i 0 v $drop
10s source
08i 1 v cdr
10s env
10s label-end
08i 3 v bytecompile/and/rec
08i 4 v list
09o 4
24
08i 2 v list
01
}]] [def bytecompile/and [λδ* bytecompile/and [source env] "" #{
08i 0 v bytecompile/gen-label
0Es label-end
0D
10s source
08i 1 v cdr
10s env
10s label-end
08i 3 v bytecompile/and/rec
05v :label
10s label-end
08i 2 v list
08i 2 v list
01
}]] [def bytecompile/or/rec [λδ* bytecompile/or/rec [source env label-end] "" #{
10s source
0Bo 70
10s source
08i 1 v car
10s env
08i 2 v bytecompile*
08i 0 v $dup
10s label-end
08i 1 v $jt
08i 0 v $drop
10s source
08i 1 v cdr
10s env
10s label-end
08i 3 v bytecompile/or/rec
08i 5 v list
09o 4
24
01
}]] [def bytecompile/or [λδ* bytecompile/or [source env] "" #{
08i 0 v bytecompile/gen-label
0Es label-end
0D
10s source
08i 1 v cdr
10s env
10s label-end
08i 3 v bytecompile/or/rec
05v #f
08i 1 v $push/lval
05v :label
10s label-end
08i 2 v list
08i 3 v list
01
}]] [def bytecompile/string [λδ* bytecompile/string [source env] "" #{
10s cat
10s source
10s env
08i 3 v bytecompile/procedure
01
}]] [def bytecompile/array [λδ* bytecompile/array [source env] "" #{
10s array/ref
10s source
10s env
08i 3 v bytecompile/procedure
01
}]] [def bytecompile/tree [λδ* bytecompile/tree [source env] "" #{
10s tree/ref
10s source
10s env
08i 3 v bytecompile/procedure
01
}]] [def bytecompile/λ* [λδ* bytecompile/λ* [source env] "" #{
10s $lambda
10s source
08i 1 v cdr
08i 2 v apply
01
}]] [def bytecompile/μ* [λδ* bytecompile/μ* [source env] "" #{
10s $macro
10s source
08i 1 v cdr
08i 2 v apply
01
}]] [def bytecompile/ω* [λδ* bytecompile/ω* [source env] "" #{
08i 0 v $let
10s source
08i 1 v cdr
10s env
08i 2 v bytecompile/do
08i 0 v $closure/push
08i 0 v $closure/pop
08i 4 v list
01
}]] [def bytecompile/let* [λδ* bytecompile/let* [source env] "" #{
08i 0 v $let
10s source
08i 1 v cadr
10s env
08i 2 v bytecompile/do
08i 0 v $closure/pop
08i 3 v list
01
}]] [def bytecompile/try [λδ* bytecompile/try [source env] "" #{
08i 0 v bytecompile/gen-label
0Es handler-sym
0D
08i 0 v bytecompile/gen-label
0Es end-sym
0D
10s source
08i 1 v cadr
10s env
08i 2 v bytecompile*
10s handler-sym
08i 1 v $try
10s source
08i 1 v cddr
10s env
08i 2 v bytecompile/do/form
10s end-sym
08i 1 v $jmp
05v :label
10s handler-sym
08i 2 v list
02i 1
08i 1 v $apply/dynamic
05v :label
10s end-sym
08i 2 v list
08i 7 v list
01
}]] [def bytecompile* [λδ* bytecompile* [source env] "Compile the forms in source" #{
10s source
08i 1 v car
10s env
08i 2 v resolves?
0Bo 24
10s source
08i 1 v car
10s env
08i 2 v resolve
09o 12
10s source
08i 1 v car
0Es op
0D
15
10s op
08i 1 v type-of
0Es ΓεnΣym-173
0D
10s ΓεnΣym-173
05v :special-form
20
0Bo 409
15
10s op
0Es ΓεnΣym-174
0D
10s ΓεnΣym-174
10s do
20
0Bo 19
10s source
10s env
08i 2 v bytecompile/do
09o 367
10s ΓεnΣym-174
10s let*
20
0Bo 19
10s source
10s env
08i 2 v bytecompile/let*
09o 339
10s ΓεnΣym-174
10s def
20
0Bo 19
10s source
10s env
08i 2 v bytecompile/def
09o 311
10s ΓεnΣym-174
10s set!
20
0Bo 19
10s source
10s env
08i 2 v bytecompile/set!
09o 283
10s ΓεnΣym-174
10s if
20
0Bo 19
10s source
10s env
08i 2 v bytecompile/if
09o 255
10s ΓεnΣym-174
10s while
20
0Bo 19
10s source
10s env
08i 2 v bytecompile/while
09o 227
10s ΓεnΣym-174
10s and
20
0Bo 19
10s source
10s env
08i 2 v bytecompile/and
09o 199
10s ΓεnΣym-174
10s or
20
0Bo 19
10s source
10s env
08i 2 v bytecompile/or
09o 171
10s ΓεnΣym-174
10s λ*
20
0Bo 19
10s source
10s env
08i 2 v bytecompile/λ*
09o 143
10s ΓεnΣym-174
10s μ*
20
0Bo 19
10s source
10s env
08i 2 v bytecompile/μ*
09o 115
10s ΓεnΣym-174
10s ω*
20
0Bo 19
10s source
10s env
08i 2 v bytecompile/ω*
09o 87
10s ΓεnΣym-174
10s try
20
0Bo 19
10s source
10s env
08i 2 v bytecompile/try
09o 59
10s ΓεnΣym-174
10s quote
20
0Bo 20
10s source
08i 1 v cadr
08i 1 v bytecompile/quote
09o 30
05v :unknown-special-form
05v "The compiler does not know the current special form, please fix the compiler!"
10s source
08i 1 v car
08i 3 v list
08i 1 v throw
16
09o 216
10s ΓεnΣym-173
05v :lambda
20
0C
0Ao 22
0D
10s ΓεnΣym-173
05v :native-function
20
0C
0Ao 8
0D
05v #f
0Bo 28
10s op
10s source
08i 1 v cdr
10s env
08i 3 v bytecompile/procedure
09o 156
10s ΓεnΣym-173
05v :pair
20
0C
0Ao 22
0D
10s ΓεnΣym-173
05v :symbol
20
0C
0Ao 8
0D
05v #f
0Bo 28
10s op
10s source
08i 1 v cdr
10s env
08i 3 v bytecompile/procedure/dynamic
09o 96
10s ΓεnΣym-173
05v :string
20
0Bo 19
10s source
10s env
08i 2 v bytecompile/string
09o 68
10s ΓεnΣym-173
05v :array
20
0Bo 19
10s source
10s env
08i 2 v bytecompile/array
09o 40
10s ΓεnΣym-173
05v :tree
20
0Bo 19
10s source
10s env
08i 2 v bytecompile/tree
09o 12
10s source
08i 1 v bytecompile/literal
16
01
}]] [def bytecompile [λδ* bytecompile [form environment] "" #{
10s form
10s environment
08i 2 v bytecompile*
08i 0 v $ret
08i 2 v list
01
}]] [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] "" #{
10s args
08i 1 v last?
0Bo 26
10s args
08i 1 v car
08i 1 v compile*
24
08i 2 v cons
09o 110
10s args
08i 1 v car
08i 1 v pair?
0Bo 79
15
10s args
08i 1 v car
08i 1 v compile*
0Es ocar
0D
10s ocar
08i 1 v pair?
0Bo 29
10s ocar
10s args
08i 1 v cdr
08i 1 v compile/do/args
08i 2 v cons
09o 17
10s args
08i 1 v cdr
08i 1 v compile/do/args
16
09o 17
10s args
08i 1 v cdr
08i 1 v compile/do/args
01
}]] [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/fn* [λ* compile/fn* [source] "" [list 'fn* [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] "" #{
10s source
08i 1 v compile/procedure/arg
01
}]] [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-179 [type-of op]] [if [== ΓεnΣym-179 :special-form] [let* [do [def ΓεnΣym-180 op] [if [== ΓεnΣym-180 do] [compile/do source] [if [== ΓεnΣym-180 def] [compile/def source] [if [== ΓεnΣym-180 set!] [compile/set! source] [if [== ΓεnΣym-180 let*] [compile/let* source] [if [== ΓεnΣym-180 λ*] [compile/λ* source] [if [== ΓεnΣym-180 fn*] [compile/fn* source] [if [== ΓεnΣym-180 μ*] [compile/μ* source] [if [== ΓεnΣym-180 ω*] [compile/ω* source] [if [== ΓεnΣym-180 if] [compile/if source] [if [== ΓεnΣym-180 try] [compile/try source] [if [== ΓεnΣym-180 and] [compile/and source] [if [== ΓεnΣym-180 or] [compile/or source] [if [== ΓεnΣym-180 while] [compile/while source] [if [== ΓεnΣym-180 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-179 :macro] [compile/macro op source] [if [or [== ΓεnΣym-179 :lambda] [== ΓεnΣym-179 :native-function]] [compile/procedure op source] [if [== ΓεnΣym-179 :object] [compile/procedure/arg source] [if [== ΓεnΣym-179 :pair] [compile/procedure/arg source] [if [or [== ΓεnΣym-179 :int] [== ΓεnΣym-179 :float] [== ΓεnΣym-179 :vec]] [compile/procedure/arg source] [if [== ΓεnΣym-179 :array] [compile/procedure/arg source] [if [== ΓεnΣym-179 :string] [compile/procedure/arg source] [if [== ΓεnΣym-179 :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" #{
10s new-environment
0Bo 7
24
09o 12
08i 0 v current-closure
0Fs new-environment
0D
10s new-verbose
0Bo 7
24
09o 11
05v #f
0Fs new-verbose
0D
10s new-environment
0Fs compile/environment
0D
10s new-verbose
0Fs compile/verbose
0D
10s source
08i 1 v compile*
01
}]] [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-181 source] [if ΓεnΣym-181 [while ΓεnΣym-181 [do [def form [car ΓεnΣym-181]] [try [λ* #nil [err] "" [do [set! errors [cons err errors]] [let* [do [def ΓεnΣym-182 [car err]] [if [== ΓεnΣym-182 :unresolved-procedure] [try-again [car source]] [if [== ΓεnΣym-182 :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-181 [cdr ΓεnΣym-181]]]] #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 fn [μ* fn [args . body] "Define a λδ with the self-hosting Nujel compiler" [do [def doc-string [if [string? [car body]] [car body] ""]] [cons 'fn* [cons #nil [cons args [cons doc-string [cons [assemble* [bytecompile [compile [cons 'do body] [current-closure]]]] #nil]]]]]]]] [def defn [μ* defn [name args . body] "Define a new bytecoded function" [do [def doc-string [if [string? [car body]] [car body] ""]] [list 'def name [cons 'fn* [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()" #{
10s display/error
18
00
1D
10s expr
08i 1 v read
10s closure
08i 2 v compile
08i 1 v eval*
09o 5
1A
01
01
}]] [def eval-load [λδ* eval-load [expr closure] "Compile and the immediatly evaluate the result, mostly used by lRun()" #{
10s display/error
18
00
13
10s expr
10s closure
08i 2 v load/forms
09o 5
1A
01
01
}]] [def read-eval-load [λδ* read-eval-load [expr closure] "Compile and the immediatly evaluate the result, mostly used by lRun()" #{
10s display/error
18
00
18
10s expr
08i 1 v read
10s closure
08i 2 v load/forms
09o 5
1A
01
01
}]]][do [def disassemble/length [λδ* disassemble/length [op] "Return the length in bytes of a bytecode operation and all its arguments" #{
15
10s op
0Es ΓεnΣym-47
0D
10s ΓεnΣym-47
05v #$0
20
0C
0Ao 274
0D
10s ΓεnΣym-47
05v #$1
20
0C
0Ao 260
0D
10s ΓεnΣym-47
05v #$3
20
0C
0Ao 246
0D
10s ΓεnΣym-47
05v #$4
20
0C
0Ao 232
0D
10s ΓεnΣym-47
05v #$7
20
0C
0Ao 218
0D
10s ΓεnΣym-47
05v #$C
20
0C
0Ao 204
0D
10s ΓεnΣym-47
05v #$D
20
0C
0Ao 190
0D
10s ΓεnΣym-47
05v #$13
20
0C
0Ao 176
0D
10s ΓεnΣym-47
05v #$14
20
0C
0Ao 162
0D
10s ΓεnΣym-47
05v #$15
20
0C
0Ao 148
0D
10s ΓεnΣym-47
05v #$16
20
0C
0Ao 134
0D
10s ΓεnΣym-47
05v #$19
20
0C
0Ao 120
0D
10s ΓεnΣym-47
05v #$1B
20
0C
0Ao 106
0D
10s ΓεnΣym-47
05v #$1C
20
0C
0Ao 92
0D
10s ΓεnΣym-47
05v #$1E
20
0C
0Ao 78
0D
10s ΓεnΣym-47
05v #$1F
20
0C
0Ao 64
0D
10s ΓεnΣym-47
05v #$20
20
0C
0Ao 50
0D
10s ΓεnΣym-47
05v #$21
20
0C
0Ao 36
0D
10s ΓεnΣym-47
05v #$22
20
0C
0Ao 22
0D
10s ΓεnΣym-47
05v #$24
20
0C
0Ao 8
0D
05v #f
0Bo 8
02i 1
09o 314
10s ΓεnΣym-47
05v #$2
20
0C
0Ao 36
0D
10s ΓεnΣym-47
05v #$6
20
0C
0Ao 22
0D
10s ΓεnΣym-47
05v #$1A
20
0C
0Ao 8
0D
05v #f
0Bo 8
02i 2
09o 260
10s ΓεnΣym-47
05v #$9
20
0C
0Ao 64
0D
10s ΓεnΣym-47
05v #$A
20
0C
0Ao 50
0D
10s ΓεnΣym-47
05v #$B
20
0C
0Ao 36
0D
10s ΓεnΣym-47
05v #$17
20
0C
0Ao 22
0D
10s ΓεnΣym-47
05v #$18
20
0C
0Ao 8
0D
05v #f
0Bo 8
02i 3
09o 178
10s ΓεnΣym-47
05v #$5
20
0C
0Ao 64
0D
10s ΓεnΣym-47
05v #$E
20
0C
0Ao 50
0D
10s ΓεnΣym-47
05v #$F
20
0C
0Ao 36
0D
10s ΓεnΣym-47
05v #$10
20
0C
0Ao 22
0D
10s ΓεnΣym-47
05v #$23
20
0C
0Ao 8
0D
05v #f
0Bo 8
02i 4
09o 96
10s ΓεnΣym-47
05v #$8
20
0C
0Ao 8
0D
05v #f
0Bo 8
02i 5
09o 70
10s ΓεnΣym-47
05v #$11
20
0C
0Ao 22
0D
10s ΓεnΣym-47
05v #$12
20
0C
0Ao 8
0D
05v #f
0Bo 8
02i 13
09o 30
05v :unknown-op
05v "This op needs its length specified for disassembly to work"
10s op
08i 0 v current-lambda
08i 4 v list
08i 1 v throw
16
01
}]] [def bytecode/nil-catcher [λδ* bytecode/nil-catcher [error] "" #{
10s error
08i 1 v car
05v :argument-mismatch
20
0Bo 7
24
09o 12
10s error
08i 1 v throw
01
}]] [def bytecode-op->val [λδ* bytecode-op->val [a b c] "Turn three bytecode ops representing an encoded value into an actual value" #{
10s a
08i 1 v bytecode-op->int
02i 16
08i 2 v ash
10s b
08i 1 v bytecode-op->int
02i 8
08i 2 v ash
10s c
08i 1 v bytecode-op->int
08i 3 v logior
08i 1 v index->val
01
}]] [def bytecode-arr->val [λδ* bytecode-arr->val [a i] "Read a bytecode encoded value in A at I and return it" #{
10s bytecode/nil-catcher
18
00
40
10s a
10s i
08i 2 v ref
10s a
02i 1
10s i
08i 2 v +
08i 2 v ref
10s a
02i 2
10s i
08i 2 v +
08i 2 v ref
08i 3 v bytecode-op->val
09o 5
1A
01
01
}]] [def bytecode-op->sym [λδ* bytecode-op->sym [a b c] "Turn three bytecode ops representing an encoded symbol into an actual symbol" #{
10s a
08i 1 v bytecode-op->int
02i 16
08i 2 v ash
10s b
08i 1 v bytecode-op->int
02i 8
08i 2 v ash
10s c
08i 1 v bytecode-op->int
08i 3 v logior
08i 1 v index->sym
01
}]] [def bytecode-arr->sym [λδ* bytecode-arr->sym [a i] "Read a bytecode encoded symbol in A at I and return it" #{
10s bytecode/nil-catcher
18
00
40
10s a
10s i
08i 2 v ref
10s a
02i 1
10s i
08i 2 v +
08i 2 v ref
10s a
02i 2
10s i
08i 2 v +
08i 2 v ref
08i 3 v bytecode-op->sym
09o 5
1A
01
01
}]] [def bytecode-op->offset [λδ* bytecode-op->offset [a b] "Turn two bytecode ops encoding an offset into the integer representation" #{
10s a
08i 1 v bytecode-op->int
02i 8
08i 2 v ash
10s b
08i 1 v bytecode-op->int
08i 2 v logior
0Es t
0D
10s t
05v 32768
22
0Bo 24
05v 65536
10s t
08i 2 v -
08i 1 v -
09o 7
10s t
01
}]] [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" #{
10s a
10s i
08i 2 v ref
10s a
02i 1
10s i
08i 2 v +
08i 2 v ref
08i 2 v bytecode-op->offset
01
}]] [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" #{
15
10s a
10s i
08i 2 v ref
0Es ΓεnΣym-183
0D
10s ΓεnΣym-183
05v #$0
20
0Bo 10
05v [$nop]
09o 1436
10s ΓεnΣym-183
05v #$1
20
0Bo 10
05v [$ret]
09o 1417
10s ΓεnΣym-183
05v #$2
20
0Bo 46
23
00
01
C1
10s a
10s i
02i 1
08i 2 v +
08i 2 v ref
08i 1 v bytecode-op->int
24
08i 2 v cons
08i 2 v cons
09o 1362
10s ΓεnΣym-183
05v #$3
20
0Bo 10
05v [$add/int]
09o 1343
10s ΓεnΣym-183
05v #$4
20
0Bo 10
05v [$debug/print-stack]
09o 1324
10s ΓεnΣym-183
05v #$5
20
0Bo 41
23
00
01
C4
10s a
10s i
02i 1
08i 2 v +
08i 2 v bytecode-arr->val
24
08i 2 v cons
08i 2 v cons
09o 1274
10s ΓεnΣym-183
05v #$6
20
0Bo 46
23
00
01
C8
10s a
10s i
02i 1
08i 2 v +
08i 2 v ref
08i 1 v bytecode-op->int
24
08i 2 v cons
08i 2 v cons
09o 1219
10s ΓεnΣym-183
05v #$7
20
0Bo 10
05v [$eval]
09o 1200
10s ΓεnΣym-183
05v #$8
20
0Bo 71
23
00
01
CB
10s a
10s i
02i 1
08i 2 v +
08i 2 v ref
08i 1 v bytecode-op->int
10s a
10s i
02i 2
08i 2 v +
08i 2 v bytecode-arr->val
24
08i 2 v cons
08i 2 v cons
08i 2 v cons
09o 1120
10s ΓεnΣym-183
05v #$9
20
0Bo 41
23
00
02i -127
10s a
10s i
02i 1
08i 2 v +
08i 2 v bytecode-arr->offset
24
08i 2 v cons
08i 2 v cons
09o 1070
10s ΓεnΣym-183
05v #$A
20
0Bo 41
23
00
02i -126
10s a
10s i
02i 1
08i 2 v +
08i 2 v bytecode-arr->offset
24
08i 2 v cons
08i 2 v cons
09o 1020
10s ΓεnΣym-183
05v #$B
20
0Bo 41
23
00
02i -125
10s a
10s i
02i 1
08i 2 v +
08i 2 v bytecode-arr->offset
24
08i 2 v cons
08i 2 v cons
09o 970
10s ΓεnΣym-183
05v #$C
20
0Bo 10
05v [$dup]
09o 951
10s ΓεnΣym-183
05v #$D
20
0Bo 10
05v [$drop]
09o 932
10s ΓεnΣym-183
05v #$E
20
0Bo 41
23
00
01
DF
10s a
10s i
02i 1
08i 2 v +
08i 2 v bytecode-arr->sym
24
08i 2 v cons
08i 2 v cons
09o 882
10s ΓεnΣym-183
05v #$F
20
0Bo 41
23
00
01
E0
10s a
10s i
02i 1
08i 2 v +
08i 2 v bytecode-arr->sym
24
08i 2 v cons
08i 2 v cons
09o 832
10s ΓεnΣym-183
05v #$10
20
0Bo 41
23
00
01
E1
10s a
10s i
02i 1
08i 2 v +
08i 2 v bytecode-arr->sym
24
08i 2 v cons
08i 2 v cons
09o 782
10s ΓεnΣym-183
05v #$11
20
0Bo 116
23
00
01
E2
10s a
10s i
02i 1
08i 2 v +
08i 2 v bytecode-arr->val
10s a
10s i
02i 4
08i 2 v +
08i 2 v bytecode-arr->val
10s a
10s i
02i 7
08i 2 v +
08i 2 v bytecode-arr->val
10s a
10s i
02i 10
08i 2 v +
08i 2 v bytecode-arr->val
24
08i 2 v cons
08i 2 v cons
08i 2 v cons
08i 2 v cons
08i 2 v cons
09o 657
10s ΓεnΣym-183
05v #$12
20
0Bo 116
23
00
01
E4
10s a
10s i
02i 1
08i 2 v +
08i 2 v bytecode-arr->val
10s a
10s i
02i 4
08i 2 v +
08i 2 v bytecode-arr->val
10s a
10s i
02i 7
08i 2 v +
08i 2 v bytecode-arr->val
10s a
10s i
02i 10
08i 2 v +
08i 2 v bytecode-arr->val
24
08i 2 v cons
08i 2 v cons
08i 2 v cons
08i 2 v cons
08i 2 v cons
09o 532
10s ΓεnΣym-183
05v #$13
20
0Bo 10
05v [$closure/push]
09o 513
10s ΓεnΣym-183
05v #$14
20
0Bo 10
05v [$closure/enter]
09o 494
10s ΓεnΣym-183
05v #$15
20
0Bo 10
05v [$let]
09o 475
10s ΓεnΣym-183
05v #$16
20
0Bo 10
05v [$closure/pop]
09o 456
10s ΓεnΣym-183
05v #$17
20
0Bo 41
23
00
01
D5
10s a
10s i
02i 1
08i 2 v +
08i 2 v bytecode-arr->offset
24
08i 2 v cons
08i 2 v cons
09o 406
10s ΓεnΣym-183
05v #$18
20
0Bo 41
23
00
01
D8
10s a
10s i
02i 1
08i 2 v +
08i 2 v bytecode-arr->offset
24
08i 2 v cons
08i 2 v cons
09o 356
10s ΓεnΣym-183
05v #$19
20
0Bo 10
05v [$throw]
09o 337
10s ΓεnΣym-183
05v #$1A
20
0Bo 46
23
00
01
D4
10s a
10s i
02i 1
08i 2 v +
08i 2 v ref
08i 1 v bytecode-op->int
24
08i 2 v cons
08i 2 v cons
09o 282
10s ΓεnΣym-183
05v #$1B
20
0Bo 16
23
00
02i -124
24
08i 2 v cons
09o 257
10s ΓεnΣym-183
05v #$1C
20
0Bo 16
23
00
02i -123
24
08i 2 v cons
09o 232
10s ΓεnΣym-183
05v #$1D
20
0Bo 16
23
00
02i -122
24
08i 2 v cons
09o 207
10s ΓεnΣym-183
05v #$1E
20
0Bo 16
23
00
01
CF
24
08i 2 v cons
09o 182
10s ΓεnΣym-183
05v #$1F
20
0Bo 16
23
00
01
D0
24
08i 2 v cons
09o 157
10s ΓεnΣym-183
05v #$20
20
0Bo 16
23
00
01
D1
24
08i 2 v cons
09o 132
10s ΓεnΣym-183
05v #$21
20
0Bo 16
23
00
01
D2
24
08i 2 v cons
09o 107
10s ΓεnΣym-183
05v #$22
20
0Bo 16
23
00
01
D3
24
08i 2 v cons
09o 82
10s ΓεnΣym-183
05v #$23
20
0Bo 41
23
00
01
C7
10s a
10s i
02i 1
08i 2 v +
08i 2 v bytecode-arr->sym
24
08i 2 v cons
08i 2 v cons
09o 32
10s ΓεnΣym-183
05v #$24
20
0Bo 16
23
00
01
EB
24
08i 2 v cons
09o 7
05v :unknown-op
16
01
}]] [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" #{
24
0Es ret
0D
02i 0
1B
1C
10s i
10s a
08i 1 v array/length
1E
0Bo 74
0D
10s i
10s a
10s i
08i 2 v disassemble/op
08i 2 v cons
10s ret
08i 2 v cons
0Fs ret
0D
10s i
10s a
10s i
08i 2 v ref
08i 1 v disassemble/length
08i 2 v +
0Fs i
09o -86
0D
10s ret
08i 1 v nreverse
01
}]] [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," #{
10s code
08i 1 v bytecode-arr->arr
02i 0
08i 2 v disassemble/array
01
}]] [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," #{
10s bc
08i 1 v disassemble
11v [:symbol :symbol] v [a] v "" v [println [cat [ansi-blue [string/pad-start [string [car a]] 6]] " - " [cdr a]]]
08i 2 v for-each
01
}]] [def disassemble/test [λδ* disassemble/test [asm] "Verbose way of testing the disassembler" #{
05v "--------- Assembly -----------"
08i 1 v ansi-blue
08i 1 v println
0D
02i 0
0Es cur-line
0D
10s asm
11v [:symbol :symbol] v [a] v "" v [println [cat [ansi-yellow [string/pad-start [set! cur-line [+ 1 cur-line]] 6]] " - " a]]
08i 2 v for-each
0D
05v "--------- Raw Bytecode -----------"
08i 1 v ansi-yellow
08i 1 v println
0D
10s assemble
10s asm
08i 2 v apply
0Es bc
0D
10s bc
08i 1 v str/write
08i 1 v println
0D
05v "--------- Now for the disassembly -----------"
08i 1 v ansi-green
08i 1 v println
0D
10s bc
08i 1 v disassemble
11v [:symbol :symbol] v [a] v "" v [println [cat [ansi-blue [string/pad-start [string [car a]] 6]] " - " [cdr a]]]
08i 2 v for-each
0D
05v "--------- Fin -----------\n"
08i 1 v ansi-red
08i 1 v println
0D
10s display/error
18
00
19
10s bc
08i 1 v bytecode-eval
08i 1 v str/write
08i 1 v println
09o 5
1A
01
01
}]]][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-186 yield-queue] [if ΓεnΣym-186 [while ΓεnΣym-186 [do [def cur [car ΓεnΣym-186]] [if [[car cur]] [[cdr cur]] [set! new [cons cur new]]] [set! ΓεnΣym-186 [cdr ΓεnΣym-186]]]] #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-187 [tree/values event]] [if ΓεnΣym-187 [while ΓεnΣym-187 [do [def h [car ΓεnΣym-187]] [h val] [set! ΓεnΣym-187 [cdr ΓεnΣym-187]]]] #nil]]]]]][do [def let/arg [λδ* let/arg [arg] "" #{
10s arg
0Bo 121
10s arg
08i 1 v pair?
08i 1 v not
0C
0Ao 32
0D
10s arg
08i 1 v car
08i 1 v symbol?
08i 1 v not
0C
0Ao 8
0D
05v #f
0Bo 28
05v :invalid-let-form
05v "Please fix the structure of the let form"
10s arg
08i 3 v list
08i 1 v throw
09o 4
24
0D
23
00
00
89
10s arg
08i 1 v car
10s arg
08i 1 v cadr
24
08i 2 v cons
08i 2 v cons
08i 2 v cons
09o 4
24
01
}]] [def let/args [λδ* let/args [args] "" #{
10s args
0Bo 39
10s args
08i 1 v car
08i 1 v let/arg
10s args
08i 1 v cdr
08i 1 v let/args
08i 2 v cons
09o 4
24
01
}]] [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" #{
10s v
0Bo 10
05v #f
09o 7
05v #t
01
}]] [def identity [λδ* identity [α] "Returns its argument" #{
10s α
01
}]] [def list [λδ* list arguments "Return ARGUMENTS as a list" #{
10s arguments
01
}]] [def default [λδ* default [arg default-value] "Returns ARG or DEFAULT-VALUE if ARG is #nil" #{
10s arg
0Bo 10
10s arg
09o 7
10s default-value
01
}]] [def caar [λδ* caar [p] "[car [car p]]" #{
10s p
08i 1 v car
08i 1 v car
01
}]] [def cadr [λδ* cadr [p] "[car [cdr p]]" #{
10s p
08i 1 v cdr
08i 1 v car
01
}]] [def cdar [λδ* cdar [p] "[cdr [car p]]" #{
10s p
08i 1 v car
08i 1 v cdr
01
}]] [def cddr [λδ* cddr [p] "[cdr [cdr p]]" #{
10s p
08i 1 v cdr
08i 1 v cdr
01
}]] [def cadar [λδ* cadar [p] "[cdr [car p]]" #{
10s p
08i 1 v car
08i 1 v cdr
08i 1 v car
01
}]] [def caddr [λδ* caddr [p] "[car [cdr [cdr p]]]" #{
10s p
08i 1 v cdr
08i 1 v cdr
08i 1 v car
01
}]] [def cdddr [λδ* cdddr [p] "[cdr [cdr [cdr p]]]" #{
10s p
08i 1 v cdr
08i 1 v cdr
08i 1 v cdr
01
}]] [def cadddr [λδ* cadddr [p] "[car [cdr [cdr [cdr p]]]]" #{
10s p
08i 1 v cdr
08i 1 v cdr
08i 1 v cdr
08i 1 v car
01
}]] [def caddddr [λδ* caddddr [p] "[car [cdr [cdr [cdr p]]]]" #{
10s p
08i 1 v cdr
08i 1 v cdr
08i 1 v cdr
08i 1 v cdr
08i 1 v car
01
}]] [def keyword->string [λδ* keyword->string [α] "" #{
10s α
08i 1 v keyword?
0Bo 7
24
09o 30
05v :type-error
05v "[keyword->string] can only be called on keywords"
10s α
08i 0 v current-lambda
08i 4 v list
08i 1 v throw
0D
10s α
08i 1 v keyword->symbol
08i 1 v sym->str
01
}]] [def string->keyword [λδ* string->keyword [α] "" #{
10s α
08i 1 v string?
0Bo 7
24
09o 30
05v :type-error
05v "[string->keyword] can only be called on strings"
10s α
08i 0 v current-lambda
08i 4 v list
08i 1 v throw
0D
10s α
08i 1 v str->sym
08i 1 v symbol->keyword
01
}]]][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/int [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" #{
10s a
08i 1 v int?
0C
0Ao 36
0D
10s a
08i 1 v float?
0C
0Ao 22
0D
10s a
08i 1 v vec?
0C
0Ao 8
0D
05v #f
01
}]] [def last? [λδ* last? [a] "Return #t if a is the last pair in a list" #{
10s a
08i 1 v cdr
08i 1 v nil?
01
}]] [def pos? [λδ* pos? [a] "Return #t if a is positive" #{
10s a
08i 1 v numeric?
0C
0Bo 18
0D
10s a
08i 1 v float
05v 0.0
21
01
}]] [def zero-neg? [λδ* zero-neg? [a] "Return #t if a is zero or negative" #{
10s a
08i 1 v numeric?
0C
0Bo 18
0D
10s a
08i 1 v float
05v 0.0
1F
01
}]] [def neg? [λδ* neg? [a] "Returns #t if a is negative" #{
10s a
08i 1 v numeric?
0C
0Bo 18
0D
10s a
08i 1 v float
05v 0.0
1E
01
}]] [def odd? [λδ* odd? [a] "Predicate that returns #t if a is odd" #{
10s a
08i 1 v int
02i 2
08i 2 v %
02i 1
20
01
}]] [def even? [λδ* even? [a] "Predicate that returns #t if a is even" #{
10s a
08i 1 v int
02i 2
08i 2 v mod/int
02i 0
20
01
}]] [def zero? [λδ* zero? [val] "#t if VAL is zero" #{
02i 0
10s val
20
01
}]] [def not-zero? [λδ* not-zero? [val] "#t if VAL is not zero" #{
02i 0
10s val
08i 2 v !=
01
}]] [def equal? [λδ* equal? [a b] "High level equality comparator, can also recursively test lists/arrays for equivalence, can be slow." #{
10s a
08i 1 v type-of
0Es cur-type
0D
10s cur-type
10s b
08i 1 v type-of
08i 2 v !=
0Bo 10
05v #f
09o 107
15
10s cur-type
0Es ΓεnΣym-188
0D
10s ΓεnΣym-188
05v :array
20
0Bo 19
10s a
10s b
08i 2 v array/equal?
09o 68
10s ΓεnΣym-188
05v :tree
20
0Bo 19
10s a
10s b
08i 2 v tree/equal?
09o 40
10s ΓεnΣym-188
05v :pair
20
0Bo 19
10s a
10s b
08i 2 v list/equal?
09o 12
10s a
10s b
20
16
01
}]] [def inequal? [λδ* inequal? [a b] "High level inequality comparator" #{
10s a
10s b
08i 2 v equal?
08i 1 v not
01
}]] [def int? [λδ* int? [val] "#t if VAL is a integer" #{
05v :int
10s val
08i 1 v type-of
20
01
}]] [def float? [λδ* float? [val] "#t if VAL is a floating-point number" #{
05v :float
10s val
08i 1 v type-of
20
01
}]] [def vec? [λδ* vec? [val] "#t if VAL is a vector" #{
05v :vec
10s val
08i 1 v type-of
20
01
}]] [def bool? [λδ* bool? [val] "#t if VAL is a boolean" #{
05v :bool
10s val
08i 1 v type-of
20
01
}]] [def pair? [λδ* pair? [val] "#t if VAL is a pair" #{
05v :pair
10s val
08i 1 v type-of
20
01
}]] [def array? [λδ* array? [val] "#t if VAL is an array" #{
05v :array
10s val
08i 1 v type-of
20
01
}]] [def string? [λδ* string? [val] "#t if VAL is a string" #{
05v :string
10s val
08i 1 v type-of
20
01
}]] [def symbol? [λδ* symbol? [val] "#t if VAL is a symbol" #{
05v :symbol
10s val
08i 1 v type-of
20
01
}]] [def object? [λδ* object? [val] "#t if VAL is an object" #{
05v :object
10s val
08i 1 v type-of
20
01
}]] [def tree? [λδ* tree? [val] "#t if VAL is an object" #{
05v :tree
10s val
08i 1 v type-of
20
01
}]] [def macro? [λδ* macro? [val] "#t if VAL is an object" #{
05v :macro
10s val
08i 1 v type-of
20
01
}]] [def lambda? [λδ* lambda? [val] "#t if VAL is a lambda" #{
05v :lambda
10s val
08i 1 v type-of
20
0C
0Ao 8
0D
05v #f
01
}]] [def native? [λδ* native? [val] "#t if VAL is a native function" #{
05v :native-function
10s val
08i 1 v type-of
20
01
}]] [def special-form? [λδ* special-form? [val] "#t if VAL is a native function" #{
05v :special-form
10s val
08i 1 v type-of
20
01
}]] [def procedure? [λδ* procedure? [val] "#t if VAL is a native or lisp function" #{
10s val
08i 1 v lambda?
0C
0Ao 36
0D
10s val
08i 1 v native?
0C
0Ao 22
0D
10s val
08i 1 v special-form?
0C
0Ao 8
0D
05v #f
01
}]] [def bytecode-array? [λδ* bytecode-array? [v] "" #{
05v :bytecode-array
10s v
08i 1 v type-of
20
01
}]] [def bytecode-op? [λδ* bytecode-op? [v] "" #{
05v :bytecode-op
10s v
08i 1 v type-of
20
01
}]] [def in-range? [λδ* in-range? [v min max] "" #{
10s v
10s min
21
0C
0Bo 13
0D
10s v
10s max
1F
01
}]]][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] "" #{
10s c
0Bo 142
10s c
08i 1 v closure
0Es info
0D
10s info
0C
0Bo 17
0D
10s info
05v :call
08i 2 v ref
0Bo 99
10s i
08i 1 v int
05v "# "
10s c
08i 1 v str/write
08i 3 v cat
08i 1 v ansi-blue
05v " - "
10s info
05v :data
08i 2 v ref
08i 1 v str/write
05v "\r\n"
10s c
08i 1 v closure-caller
10s i
08i 1 v int
02i 1
08i 2 v +
08i 2 v describe/closure
08i 5 v cat
09o 4
24
09o 4
24
01
}]] [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" #{
10s timestamp
08i 0 v time
08i 2 v default
02i 60
08i 2 v %
01
}]] [def time/minutes [λδ* time/minutes [timestamp] "Return the minutes part of TIMESTAMP, defaults to current time" #{
10s timestamp
08i 0 v time
08i 2 v default
02i 60
08i 2 v /
02i 60
08i 2 v %
01
}]] [def time/hours [λδ* time/hours [timestamp] "Return the hours part of TIMESTAMP, defaults to current time" #{
10s timestamp
08i 0 v time
08i 2 v default
05v 3600
08i 2 v /
02i 24
08i 2 v %
01
}]] [def profile-form [λδ* profile-form [raw] "" #{
08i 0 v time/milliseconds
0Es start-time
0D
10s raw
08i 0 v current-closure
08i 2 v compile
08i 1 v eval*
0Es val
0D
08i 0 v time/milliseconds
0Es end-time
0D
05v "Evaluating "
10s raw
08i 1 v str/write
08i 1 v ansi-yellow
05v " to "
10s val
08i 1 v str/write
08i 1 v ansi-green
05v " took "
10s end-time
10s start-time
08i 2 v -
05v "ms"
08i 2 v cat
05v "\n"
08i 2 v ansi-red
08i 6 v cat
08i 1 v display
01
}]] [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] "" #{
02i 1
0Es a
0D
02i 0
0Es b
0D
15
02i 0
0Es i
0D
10s data
08i 1 v string/length
0Es ΓεnΣym-50
0D
02i 0
1B
1C
10s i
10s ΓεnΣym-50
1E
0Bo 73
0D
10s a
10s data
10s i
08i 2 v char-at
03
05v 65521
08i 2 v mod/int
0Fs a
0D
10s a
10s b
03
05v 65521
08i 2 v mod/int
0Fs b
0D
02i 1
10s i
03
0Fs i
09o -80
16
0D
10s a
10s b
02i 16
08i 2 v ash
08i 2 v logior
01
}]][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" #{
10s i
02i 2
1E
0Bo 10
10s i
09o 40
10s i
02i 2
08i 2 v -
08i 1 v fib
10s i
02i 1
08i 2 v -
08i 1 v fib
08i 2 v +
01
}]] [def wrap-value [λδ* wrap-value [val min max] "Constrains VAL to be within MIN and MAX, wrapping it around" #{
10s min
10s val
10s min
08i 2 v -
10s max
10s min
08i 2 v -
08i 2 v %
08i 2 v +
01
}]] [def +1 [μ* +1 [v] "" [cons '+ [cons 1 [cons v #nil]]]]] [def radians [λδ* radians [degrees] "Convert a quantity in degrees to radians" #{
10s π
10s degrees
08i 2 v *
05v 180.0
08i 2 v /
01
}]]][do [def display/error/wrap [λδ* display/error/wrap [i text] "" #{
15
10s i
0Es ΓεnΣym-1
0D
10s ΓεnΣym-1
02i 0
20
0Bo 15
10s text
08i 1 v ansi-red
09o 78
10s ΓεnΣym-1
02i 1
20
0Bo 15
10s text
08i 1 v string
09o 56
10s ΓεnΣym-1
02i 2
20
0Bo 20
10s text
08i 1 v str/write
08i 1 v ansi-yellow
09o 29
10s ΓεnΣym-1
02i 3
20
0Bo 15
10s text
08i 1 v describe/closure
09o 7
10s text
16
01
}]] [def display/error/iter [λδ* display/error/iter [error i] "" #{
10s error
0Bo 54
10s i
10s error
08i 1 v car
08i 2 v display/error/wrap
10s error
08i 1 v cdr
02i 1
10s i
08i 2 v +
08i 2 v display/error/iter
08i 2 v cons
09o 13
05v ""
24
08i 2 v cons
01
}]] [def display/error [λδ* display/error [error] "Display ERROR in a nice, human readable way" #{
10s error
02i 0
08i 2 v display/error/iter
05v "\r\n"
08i 2 v join
08i 1 v display
01
}]] [def describe/thing [λδ* describe/thing [o] "Describe a specific value O" #{
10s o
08i 1 v closure
0Es doc
0D
10s doc
05v :arguments
08i 2 v ref
08i 1 v str/write
05v " - "
10s doc
05v :documentation
08i 2 v ref
08i 3 v cat
01
}]] [def describe/string [λδ* describe/string [a] "Descibe whatever value string A resolves to" #{
10s a
08i 1 v str->sym
08i 1 v resolve
08i 1 v describe/thing
01
}]] [def describe [λδ* describe [fun] "Describe FUN, if there is documentation available" #{
10s fun
08i 1 v string?
0Bo 15
10s fun
08i 1 v describe/string
09o 12
10s fun
08i 1 v describe/thing
01
}]] [def mem [λδ* mem [] "Return some pretty printed memory usage information" #{
08i 0 v memory-info
0Es info
0D
05v "Memory Info"
08i 1 v ansi-white
05v "\n"
05v "Values:   "
08i 1 v ansi-green
10s info
05v :value
08i 2 v getf
05v "\n"
05v "Closures: "
08i 1 v ansi-blue
10s info
05v :closure
08i 2 v getf
05v "\n"
05v "Arrays:   "
08i 1 v ansi-red
10s info
05v :array
08i 2 v getf
05v "\n"
05v "STrings:  "
08i 1 v ansi-yellow
10s info
05v :string
08i 2 v getf
05v "\n"
05v "Symbols:  "
08i 1 v ansi-pink
10s info
05v :symbol
08i 2 v getf
05v "\n"
10s ansi-reset
08i 18 v cat
01
}]] [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 gensym/counter 0] [def gensym [λδ* gensym [prefix] "" #{
02i 1
10s gensym/counter
08i 2 v +
0Fs gensym/counter
0D
10s prefix
05v "ΓεnΣym-"
10s gensym/counter
08i 3 v cat
08i 1 v str->sym
01
}]] [def root-closure [current-closure]]][do [def random/seed 0] [def random/seed-initialize! [λδ* random/seed-initialize! [] "" #{
08i 0 v time
08i 0 v time/milliseconds
08i 2 v logxor
0Fs random/seed
01
}]] [def random/rng! [λδ* random/rng! [] "" #{
05v 12345
10s random/seed
05v 1103515245
08i 2 v *
08i 2 v +
0Fs random/seed
0D
10s random/seed
05v 65535
08i 2 v logand
02i 16
08i 2 v ash
10s random/seed
02i -16
08i 2 v ash
05v 65535
08i 2 v logand
08i 2 v logior
01
}]] [def random/seed! [λδ* random/seed! [new-seed] "Set a new seed value for the RNG" #{
10s new-seed
0Fs seed
01
}]] [def random/seed [λδ* random/seed [] "Return the current RNG seed value" #{
10s seed
01
}]] [def random [λδ* random [max] "Return a value from 0 to MAX, or, if left out, a random int" #{
10s max
08i 1 v numeric?
0Bo 25
08i 0 v random/rng!
08i 1 v abs
10s max
08i 2 v mod
09o 8
08i 0 v random/rng!
01
}]] [random/seed-initialize!]][do [def tree->json [λδ* tree->json [v] "Converts a tree into a JSON encoded string, you should prefer VAL->JSON" #{
05v "{"
10s v
08i 1 v tree/keys
11v [:symbol :symbol] v [k] v "" v [cat "\"" [keyword->string k] "\": " [val->json [tree/ref v k]]]
08i 2 v map
05v ",\n"
08i 2 v join
05v "}"
08i 3 v cat
01
}]] [def val->json [λ* val->json [v] "Return V as a JSON encoded string" [let* [do [def ΓεnΣym-190 [type-of v]] [if [== ΓεnΣym-190 :nil] "null" [if [or [== ΓεnΣym-190 :int] [== ΓεnΣym-190 :float]] [string v] [if [== ΓεnΣym-190 :bool] [if v "true" "false"] [if [or [== ΓεnΣym-190 :array] [== ΓεnΣym-190 :pair]] [cat "[" [join [map v val->json] ","] "]"] [if [== ΓεnΣym-190 :string] [str/write v] [if [== ΓεnΣym-190 :symbol] [cat "\"" [sym->str v] "\""] [if [== ΓεnΣym-190 :keyword] [cat "\"" [keyword->string v] "\""] [if [== ΓεnΣym-190 :tree] [tree->json v] [throw [list :type-error "Can't encode the value into JSON" v [current-lambda]]]]]]]]]]]]]]]][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" #{
10s ansi/disabled
0C
0Ao 26
0D
10s ansi-fg
10s code
08i 2 v array/ref
0C
0Ao 8
0D
05v #f
10s string
10s ansi/disabled
0C
0Ao 17
0D
10s ansi-reset
0C
0Ao 8
0D
05v #f
08i 3 v cat
01
}]] [def ansi-black [λδ* ansi-black args "Wrap ARGS in black" #{
02i 0
10s cat
10s args
08i 2 v apply
08i 2 v ansi-wrap
01
}]] [def ansi-dark-red [λδ* ansi-dark-red args "Wrap ARGS in dark red" #{
02i 1
10s cat
10s args
08i 2 v apply
08i 2 v ansi-wrap
01
}]] [def ansi-dark-green [λδ* ansi-dark-green args "Wrap ARGS in dark green" #{
02i 2
10s cat
10s args
08i 2 v apply
08i 2 v ansi-wrap
01
}]] [def ansi-brown [λδ* ansi-brown args "Wrap ARGS in brown" #{
02i 3
10s cat
10s args
08i 2 v apply
08i 2 v ansi-wrap
01
}]] [def ansi-dark-blue [λδ* ansi-dark-blue args "Wrap ARGS in dark blue" #{
02i 4
10s cat
10s args
08i 2 v apply
08i 2 v ansi-wrap
01
}]] [def ansi-purple [λδ* ansi-purple args "Wrap ARGS in purple" #{
02i 5
10s cat
10s args
08i 2 v apply
08i 2 v ansi-wrap
01
}]] [def ansi-teal [λδ* ansi-teal args "Wrap ARGS in teal" #{
02i 6
10s cat
10s args
08i 2 v apply
08i 2 v ansi-wrap
01
}]] [def ansi-dark-gray [λδ* ansi-dark-gray args "Wrap ARGS in dark gray" #{
02i 7
10s cat
10s args
08i 2 v apply
08i 2 v ansi-wrap
01
}]] [def ansi-gray [λδ* ansi-gray args "Wrap ARGS in gray" #{
02i 8
10s cat
10s args
08i 2 v apply
08i 2 v ansi-wrap
01
}]] [def ansi-red [λδ* ansi-red args "Wrap ARGS in red" #{
02i 9
10s cat
10s args
08i 2 v apply
08i 2 v ansi-wrap
01
}]] [def ansi-green [λδ* ansi-green args "Wrap ARGS in green" #{
02i 10
10s cat
10s args
08i 2 v apply
08i 2 v ansi-wrap
01
}]] [def ansi-yellow [λδ* ansi-yellow args "Wrap ARGS in yellow" #{
02i 11
10s cat
10s args
08i 2 v apply
08i 2 v ansi-wrap
01
}]] [def ansi-blue [λδ* ansi-blue args "Wrap ARGS in blue" #{
02i 12
10s cat
10s args
08i 2 v apply
08i 2 v ansi-wrap
01
}]] [def ansi-pink [λδ* ansi-pink args "Wrap ARGS in pink" #{
02i 13
10s cat
10s args
08i 2 v apply
08i 2 v ansi-wrap
01
}]] [def ansi-cyan [λδ* ansi-cyan args "Wrap ARGS in cyan" #{
02i 14
10s cat
10s args
08i 2 v apply
08i 2 v ansi-wrap
01
}]] [def ansi-white [λδ* ansi-white args "Wrap ARGS in white" #{
02i 15
10s cat
10s args
08i 2 v apply
08i 2 v ansi-wrap
01
}]] [def ansi-rainbow [λδ* ansi-rainbow args "Wrap ARGS in the colors of the rainbow!" #{
15
02i 0
0Es count
0D
10s cat
10s args
08i 2 v apply
05v ""
08i 2 v split
11v [:symbol :symbol] v [a] v "" v [do [set! count [logand [+ 1 count] 7]] [cat [or ansi/disabled [array/ref ansi-fg [if [zero? count] 7 [+ count 8]]]] a]]
08i 2 v map
05v ""
08i 2 v join
10s ansi/disabled
0C
0Ao 17
0D
10s ansi-fg-reset
0C
0Ao 8
0D
05v #f
08i 2 v cat
16
01
}]] [def ansi-rainbow-bg [λδ* ansi-rainbow-bg args "Wrap ARGS in the colors of the rainbow!" #{
02i 0
0Es count
0D
10s cat
10s args
08i 2 v apply
05v ""
08i 2 v split
11v [:symbol :symbol] v [a] v "" v [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]]
08i 2 v map
0Es colored-list
0D
10s colored-list
05v ""
08i 2 v join
10s ansi/disabled
0C
0Ao 17
0D
10s ansi-reset
0C
0Ao 8
0D
05v #f
08i 2 v cat
01
}]] [def reprint-line [λδ* reprint-line [text width] "" #{
10s width
0Bo 7
24
09o 9
02i 20
0Fs width
0D
05v "\r"
08i 1 v print
0D
15
02i 0
0Es i
0D
10s width
0Es ΓεnΣym-191
0D
02i 0
1B
1C
10s i
10s ΓεnΣym-191
1E
0Bo 28
0D
05v " "
08i 1 v print
0D
02i 1
10s i
03
0Fs i
09o -35
16
0D
05v "\r"
08i 1 v print
0D
10s text
08i 1 v print
01
}]]][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] "" #{
10s i
02i 0
1E
0Bo 8
02i -1
09o 70
10s s
10s i
08i 2 v char-at
0Es char
0D
10s char
02i 48
21
0C
0Bo 11
0D
10s char
02i 57
1F
0Bo 26
10s s
10s i
02i 1
08i 2 v -
08i 2 v fmt/find-non-digit-from-right
09o 7
10s i
01
}]] [def fmt/parse-spec [λ* fmt/parse-spec [opts spec] "" [if [zero? [string/length spec]] opts [let* [do [def ΓεnΣym-198 [char-at spec [- [string/length spec] 1]]] [if [or [== ΓεnΣym-198 48] [== ΓεnΣym-198 49] [== ΓεnΣym-198 50] [== ΓεnΣym-198 51] [== ΓεnΣym-198 52] [== ΓεnΣym-198 53] [== ΓεnΣym-198 54] [== ΓεnΣym-198 55] [== ΓεnΣym-198 56] [== ΓεnΣym-198 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-198 63] [fmt/parse-spec [tree/set! opts :debug #t] [string/cut spec 0 [- [string/length spec] 1]]] [if [== ΓεnΣym-198 88] [fmt/parse-spec [tree/set! opts :base :HEXADECIMAL] [string/cut spec 0 [- [string/length spec] 1]]] [if [== ΓεnΣym-198 120] [fmt/parse-spec [tree/set! opts :base :hexadecimal] [string/cut spec 0 [- [string/length spec] 1]]] [if [== ΓεnΣym-198 100] [fmt/parse-spec [tree/set! opts :base :decimal] [string/cut spec 0 [- [string/length spec] 1]]] [if [== ΓεnΣym-198 111] [fmt/parse-spec [tree/set! opts :base :octal] [string/cut spec 0 [- [string/length spec] 1]]] [if [== ΓεnΣym-198 98] [fmt/parse-spec [tree/set! opts :base :binary] [string/cut spec 0 [- [string/length spec] 1]]] [if [== ΓεnΣym-198 60] [fmt/parse-spec [tree/set! opts :align :left] [string/cut spec 0 [- [string/length spec] 1]]] [if [== ΓεnΣym-198 94] [fmt/parse-spec [tree/set! opts :align :center] [string/cut spec 0 [- [string/length spec] 1]]] [if [== ΓεnΣym-198 62] [fmt/parse-spec [tree/set! opts :align :right] [string/cut spec 0 [- [string/length spec] 1]]] [if [== ΓεnΣym-198 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] "" #{
10s opts
05v :debug
08i 2 v tree/ref
0Bo 41
10s opts
05v :argument
10s str/write
10s opts
05v :argument
08i 2 v tree/ref
08i 2 v list
08i 3 v tree/set!
09o 7
10s opts
01
}]] [def fmt/number-format [λ* fmt/number-format [opts] "" [let* [do [def ΓεnΣym-199 [tree/ref opts :base]] [if [== ΓεnΣym-199 :binary] [tree/set! opts :argument [list int->string/binary [tree/ref opts :argument]]] [if [== ΓεnΣym-199 :octal] [tree/set! opts :argument [list int->string/octal [tree/ref opts :argument]]] [if [== ΓεnΣym-199 :decimal] [tree/set! opts :argument [list int->string/decimal [tree/ref opts :argument]]] [if [== ΓεnΣym-199 :hexadecimal] [tree/set! opts :argument [list int->string/hex [tree/ref opts :argument]]] [if [== ΓεnΣym-199 :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] "" #{
10s opts
05v :debug
08i 2 v tree/ref
08i 1 v not
0C
0Ao 31
0D
10s opts
05v :base
08i 2 v tree/ref
08i 1 v not
0C
0Ao 8
0D
05v #f
0Bo 10
10s opts
09o 105
05v [:binary :octal :decimal :hexadecimal :HEXADECIMAL]
10s opts
05v :base
08i 2 v tree/ref
08i 2 v member
0Bo 63
10s opts
05v :argument
10s cat
10s fmt/number-format-prefixex
10s opts
05v :base
08i 2 v tree/ref
08i 2 v tree/ref
10s opts
05v :argument
08i 2 v tree/ref
08i 3 v list
08i 3 v tree/set!
09o 7
10s opts
05v :debug
05v #f
08i 3 v tree/set!
01
}]] [def fmt/add-padding [λδ* fmt/add-padding [opts] "" #{
10s opts
05v :width
08i 2 v tree/ref
0Bo 198
10s opts
05v :argument
15
10s opts
05v :align
08i 2 v tree/ref
0Es ΓεnΣym-200
0D
10s ΓεnΣym-200
05v :right
20
0Bo 10
10s string/pad-start
09o 42
10s ΓεnΣym-200
05v :center
20
0Bo 10
10s string/pad-middle
09o 23
10s ΓεnΣym-200
05v :left
20
0Bo 10
10s string/pad-end
09o 4
24
16
10s opts
05v :argument
08i 2 v tree/ref
10s opts
05v :debug
08i 2 v tree/ref
0C
0Bo 17
0D
10s opts
05v :base
08i 2 v tree/ref
0Bo 26
10s opts
05v :width
08i 2 v tree/ref
02i 2
08i 2 v -
09o 16
10s opts
05v :width
08i 2 v tree/ref
10s opts
05v :padding-char
08i 2 v tree/ref
08i 4 v list
08i 3 v tree/set!
09o 7
10s opts
01
}]] [def fmt/precision [λδ* fmt/precision [opts] "" #{
10s opts
05v :precision
08i 2 v tree/ref
0Bo 54
10s opts
05v :argument
10s string/round
10s opts
05v :argument
08i 2 v tree/ref
10s opts
05v :precision
08i 2 v tree/ref
08i 3 v list
08i 3 v tree/set!
09o 7
10s opts
01
}]] [def fmt/truncate [λδ* fmt/truncate [opts] "" #{
10s opts
05v :width
08i 2 v tree/ref
0Bo 63
10s opts
05v :argument
10s string/cut
10s opts
05v :argument
08i 2 v tree/ref
02i 0
02i 1
10s opts
05v :width
08i 2 v tree/ref
08i 2 v +
08i 4 v list
08i 3 v tree/set!
09o 7
10s opts
01
}]] [def fmt/output [λδ* fmt/output [opts] "" #{
10s opts
05v :argument
08i 2 v tree/ref
01
}]] [def fmt/format-arg [λδ* fmt/format-arg [spec argument] "" #{
10s fmt/format-arg/default
08i 1 v tree/dup
10s spec
08i 2 v fmt/parse-spec
05v :argument
10s argument
08i 3 v tree/set!
08i 1 v fmt/number-format
08i 1 v fmt/precision
08i 1 v fmt/add-padding
08i 1 v fmt/truncate
08i 1 v fmt/number-format-prefix
08i 1 v fmt/debug
08i 1 v fmt/output
01
}]] [def fmt/valid-argument? [λδ* fmt/valid-argument? [argument] "" #{
10s argument
08i 1 v int?
0C
0Ao 22
0D
10s argument
08i 1 v symbol?
0C
0Ao 8
0D
05v #f
01
}]] [def fmt/expr/count 0] [def fmt/expr [λδ* fmt/expr [expr arguments-used] "" #{
10s expr
08i 1 v string?
0Bo 7
24
09o 30
05v :format-error
05v "fmt needs a string literal as a first argument, since it is implemented as a macro"
10s expr
08i 0 v current-lambda
08i 4 v list
08i 1 v throw
0D
10s expr
05v ":"
08i 2 v split
0Es split-expr
0D
10s split-expr
08i 1 v car
0Es argument
0D
10s split-expr
08i 1 v cadr
0C
0Ao 17
0D
05v ""
0C
0Ao 8
0D
05v #f
0Es format-spec
0D
05v ""
10s argument
20
0Bo 58
10s arguments-used
02i -1
10s fmt/expr/count
08i 2 v +
0Fs fmt/expr/count
05v #t
08i 3 v array/set!
0D
10s format-spec
10s fmt/expr/count
08i 1 v string
08i 1 v str->sym
08i 2 v fmt/format-arg
09o 264
15
10s argument
08i 1 v read
0Es read-vals
0D
10s read-vals
08i 1 v cdr
0Bo 33
05v :format-error
05v "Format argument specifier contains more than a single atom"
10s argument
08i 0 v current-lambda
08i 4 v list
08i 1 v throw
09o 4
24
0D
10s read-vals
08i 1 v car
08i 1 v fmt/valid-argument?
0Bo 7
24
09o 30
05v :format-error
05v "Format argument specifier should be either an integer or a symbol"
10s argument
08i 0 v current-lambda
08i 4 v list
08i 1 v throw
0D
10s read-vals
08i 1 v car
08i 1 v int?
0Bo 108
10s read-vals
08i 1 v car
02i 0
1E
0C
0Ao 32
0D
10s read-vals
08i 1 v car
10s arguments-used
08i 1 v array/length
21
0C
0Ao 8
0D
05v #f
0Bo 33
05v :format-error
05v "fmt numbered argument is out of bounds"
10s argument
08i 0 v current-lambda
08i 4 v list
08i 1 v throw
09o 4
24
0D
10s arguments-used
10s read-vals
08i 1 v car
05v #t
08i 3 v array/set!
09o 4
24
0D
10s format-spec
10s read-vals
08i 1 v car
08i 1 v string
08i 1 v str->sym
08i 2 v fmt/format-arg
16
01
}]] [def fmt/args/map-fun/count 0] [def fmt/args/map-fun [λδ* fmt/args/map-fun [arg] "" #{
10s fmt/args/map-fun/count
08i 1 v string
08i 1 v str->sym
0Es s
0D
02i 1
10s fmt/args/map-fun/count
08i 2 v +
0Fs fmt/args/map-fun/count
0D
23
00
00
89
10s s
10s arg
08i 3 v list
01
}]] [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-201 [string/length format-string]] [while [< i ΓεnΣym-201] [do [let* [do [def ΓεnΣym-202 [char-at format-string i]] [if [== ΓεnΣym-202 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-202 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/int 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-203 cuts] [if ΓεnΣym-203 [while ΓεnΣym-203 [do [def c [car ΓεnΣym-203]] [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-203 [cdr ΓεnΣym-203]]]] #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-204 [array/length arguments-used]] [while [< i ΓεnΣym-204] [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/int 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" #{
10s α
08i 1 v str->sym
08i 1 v symbol->keyword
01
}]] [def string->byte-array [λδ* string->byte-array [a] "Turn a string into an UTF-8 encoded byte array" #{
10s a
08i 1 v string/length
08i 1 v array/allocate
0Es ret
0D
15
02i 0
0Es i
0D
10s a
08i 1 v string/length
0Es ΓεnΣym-206
0D
02i 0
1B
1C
10s i
10s ΓεnΣym-206
1E
0Bo 45
0D
10s ret
10s i
10s a
10s i
08i 2 v char-at
08i 3 v array/set!
0D
02i 1
10s i
03
0Fs i
09o -52
16
0D
10s ret
01
}]] [def println [λδ* println [str] "Print STR on a single line" #{
10s str
05v "\r\n"
08i 2 v cat
08i 1 v print
01
}]] [def errorln [λδ* errorln [str] "Print to stderr STR on a single line" #{
10s str
05v "\r\n"
08i 2 v cat
08i 1 v print
01
}]] [def display [λδ* display [value] "Display VALUE" #{
10s value
08i 1 v print
01
}]] [def newline [λδ* newline [] "Print a single line feed character" #{
05v "\r\n"
08i 1 v display
01
}]] [def br [λδ* br [num] "Return NUM=1 linebreaks" #{
10s num
08i 1 v nil?
0C
0Ao 25
0D
10s num
08i 1 v int
02i 1
1F
0C
0Ao 8
0D
05v #f
0Bo 10
05v "\n"
09o 28
05v "\n"
02i -1
10s num
08i 2 v +
08i 1 v br
08i 2 v cat
01
}]] [def path/ext?! [λδ* path/ext?! [ext] "Return a predicate that checks if a path ends on EXT" #{
15
10s ext
08i 1 v type-of
0Es ΓεnΣym-207
0D
10s ΓεnΣym-207
05v :string
20
0Bo 19
11v [:symbol :symbol] v [path] v "" v [== ext [lowercase [path/extension path]]]
09o 53
10s ΓεnΣym-207
05v :pair
20
0Bo 19
11v [:symbol :symbol] v [path] v "" v [do [def cext [lowercase [path/extension path]]] [reduce ext [λ* #nil [α β] "" [or α [== β cext]]]]]
09o 25
05v :type-error
05v "Expected a :string or :list"
10s ext
08i 3 v list
08i 1 v throw
16
01
}]] [def path/extension [λδ* path/extension [path] "Return the extension of PATH" #{
10s path
05v "."
08i 2 v last-index-of
0Es last-period
0D
10s last-period
02i 0
21
0Bo 35
10s path
02i 1
10s last-period
08i 2 v +
10s path
08i 1 v string/length
08i 3 v string/cut
09o 7
10s path
01
}]] [def path/without-extension [λδ* path/without-extension [path] "Return PATH, but without the extension part" #{
10s path
05v "."
08i 2 v last-index-of
0Es last-period
0D
10s last-period
02i 0
21
0Bo 21
10s path
02i 0
10s last-period
08i 3 v string/cut
09o 7
10s path
01
}]] [def int->string/binary [λδ* int->string/binary [α] "Turn α into a its **binary** string representation" #{
05v ""
0Es ret
0D
10s α
0Bo 7
24
09o 9
02i 0
0Es α
0D
10s α
08i 1 v zero?
0Bo 14
05v "0"
0Fs ret
09o 4
24
0D
02i 0
1B
1C
10s α
08i 1 v not-zero?
0Bo 59
0D
02i 48
10s α
02i 1
08i 2 v logand
08i 2 v +
08i 1 v from-char-code
10s ret
08i 2 v cat
0Fs ret
0D
10s α
02i -1
08i 2 v ash
0Fs α
09o -66
0D
10s ret
01
}]] [def int->string/octal [λδ* int->string/octal [α] "Turn α into a its **octal** string representation" #{
05v ""
0Es ret
0D
10s α
0Bo 7
24
09o 9
02i 0
0Es α
0D
10s α
08i 1 v zero?
0Bo 14
05v "0"
0Fs ret
09o 4
24
0D
02i 0
1B
1C
10s α
08i 1 v not-zero?
0Bo 59
0D
02i 48
10s α
02i 7
08i 2 v logand
08i 2 v +
08i 1 v from-char-code
10s ret
08i 2 v cat
0Fs ret
0D
10s α
02i -3
08i 2 v ash
0Fs α
09o -66
0D
10s ret
01
}]] [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] "" #{
10s str
08i 1 v string/length
0Es slen
0D
02i 0
0Es start
0D
24
0Es ret
0D
02i 0
1B
1C
10s start
10s slen
1E
0Bo 60
0D
10s str
10s start
02i 1
10s start
08i 2 v +
08i 3 v string/cut
10s ret
08i 2 v cons
0Fs ret
0D
02i 1
10s start
08i 2 v +
0Fs start
09o -67
0D
10s ret
08i 1 v reverse
01
}]] [def split/string [λδ* split/string [str separator start] "" #{
10s start
0Bo 7
24
09o 9
02i 0
0Fs start
0D
10s str
10s separator
10s start
08i 3 v index-of
0Es pos-found
0D
10s pos-found
02i 0
21
0Bo 59
10s str
10s start
10s pos-found
08i 3 v string/cut
10s str
10s separator
10s pos-found
10s separator
08i 1 v string/length
08i 2 v +
08i 3 v split/string
08i 2 v cons
09o 31
10s str
10s start
10s str
08i 1 v string/length
08i 3 v string/cut
24
08i 2 v cons
01
}]] [def split [λ* split [str separator] "" [let* [do [def ΓεnΣym-208 [string/length separator]] [if [or [== ΓεnΣym-208 0]] [split/empty str] [split/string str separator 0]]]]]] [def read/single [λδ* read/single [text] "" #{
10s text
08i 1 v read
08i 1 v car
01
}]] [def string/length?! [λδ* string/length?! [chars] "" #{
11v [:symbol :symbol] v [a] v "" v [== chars [string/length a]]
01
}]] [def contains-any? [λδ* contains-any? [str chars] "" #{
10s or
10s chars
05v ""
08i 2 v split
11v [:symbol :symbol] v [a] v "" v [>= [index-of str a] 0]
08i 2 v map
08i 2 v apply
01
}]] [def contains-all? [λδ* contains-all? [str chars] "" #{
10s and
10s chars
05v ""
08i 2 v split
11v [:symbol :symbol] v [a] v "" v [>= [index-of str a] 0]
08i 2 v map
08i 2 v apply
01
}]]][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] "" #{
10s result
10s expr
08i 2 v cons
10s test-list
08i 2 v cons
0Fs test-list
0D
10s test-count
02i 1
08i 2 v +
0Fs test-count
01
}]] [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]]]]] [def display-results [λδ* display-results [] "Prints the result Message" #{
08i 0 v random/seed-initialize!
0D
05v [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!"]]]
08i 0 v current-closure
08i 2 v compile
08i 1 v eval*
01
}]] [def test-success [λδ* test-success [res-should res-is expr i] "Should be called after a test has finished successfully" #{
10s print-passes
0Bo 25
05v [efmtln "{} == {}\r\n{}\r\n\r\n" [ansi-green [str/write res-is]] [ansi-green [str/write res-should]] [str/write expr]]
08i 0 v current-closure
08i 2 v compile
08i 1 v eval*
09o 4
24
0D
02i 1
10s success-count
08i 2 v +
0Fs success-count
01
}]] [def test-failure [λδ* test-failure [res-should res-is expr i] "Should be called if EXPR does not equal RES" #{
10s print-errors
0Bo 25
05v [efmtln "{} != {}\r\n{}\r\n\r\n" [ansi-red [str/write res-is]] [ansi-green [str/write res-should]] [str/write expr]]
08i 0 v current-closure
08i 2 v compile
08i 1 v eval*
09o 4
24
0D
02i 1
10s error-count
08i 2 v +
0Fs error-count
01
}]] [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] "" #{
11v [:symbol :symbol] v [result rawexpr i] v "Tests that RAWEXPR evaluates to RESULT in a separate runtime" v [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]]]
01
}]] [def test-run-real [λδ* test-run-real [test] "" #{
08i 0 v time/milliseconds
0Fs nujel-start
0D
02i 0
0Fs success-count
0D
02i 0
0Fs error-count
0D
10s test-count
02i 1
08i 2 v +
0Es i
0D
15
10s test-list
0Es ΓεnΣym-209
0D
10s ΓεnΣym-209
0Bo 88
02i 0
1B
1C
10s ΓεnΣym-209
0Bo 74
0D
10s ΓεnΣym-209
08i 1 v car
0Es cur-test
0D
10s test
10s cur-test
08i 1 v car
10s cur-test
08i 1 v cdr
02i -1
10s i
08i 2 v +
0Fs i
1A
03
0D
10s ΓεnΣym-209
08i 1 v cdr
0Fs ΓεnΣym-209
09o -76
09o 4
24
16
0D
08i 0 v display-results
0D
10s error-count
01
}]] [def test-run [λδ* test-run [output-passes hide-errors] "Run through all automated Tests" #{
10s hide-errors
08i 1 v bool
08i 1 v not
0Fs print-errors
0D
10s output-passes
08i 1 v bool
0Fs print-passes
0D
10s test-default
08i 1 v test-run-real
01
}]] [def test-run-bytecode [λδ* test-run-bytecode [output-passes hide-errors] "Run through all automated Tests" #{
10s hide-errors
08i 1 v bool
08i 1 v not
0Fs print-errors
0D
10s output-passes
08i 1 v bool
0Fs print-passes
0D
10s test-bytecode
08i 1 v test-run-real
01
}]] [def test-run-forked [λδ* test-run-forked [nujel-runtime output-passes hide-errors] "Run through all automated Tests in a separate runtime" #{
10s hide-errors
08i 1 v bool
08i 1 v not
0Fs print-errors
0D
10s output-passes
08i 1 v bool
0Fs print-passes
0D
10s nujel-runtime
08i 1 v test-forked
08i 1 v test-run-real
01
}]] [test/add* 4 '[do [+ 3 1]]]]
Ben / Nujel
