Ben / Nujel

[do [def lognand [fn* lognand l "Returns the Nand of its arguments" #{
10s logand
10s l
08i 2 v apply
08i 1 v lognot
01
}]] [def bit-set?! [fn* bit-set?! [i] "" #{
02i 1
10s i
08i 2 v ash
0Es mask
0D
25v anonymous v [α] v "" v #{
10s α
10s mask
08i 2 v logand
08i 1 v zero?
08i 1 v not
01
}
01
}]] [def bit-clear?! [fn* bit-clear?! [i] "" #{
02i 1
10s i
08i 2 v ash
0Es mask
0D
25v anonymous v [α] v "" v #{
10s α
10s mask
08i 2 v logand
08i 1 v zero?
01
}
01
}]]][do [def array/+= [fn* 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/++ [fn* 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! [fn* 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-11
0D
02i 0
1B
1C
10s i
10s ΓεnΣym-11
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 [fn* 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-12
0D
02i 0
1B
1C
10s i
10s ΓεnΣym-12
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-13
0D
02i 0
1B
1C
10s i
10s ΓεnΣym-13
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 [fn* array/dup [a] "Duplicate Array A" #{
10s a
24
08i 1 v array/new
08i 2 v array/append
01
}]] [def array/reduce [fn* 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-14
0D
02i 0
1B
1C
10s i
10s ΓεnΣym-14
1E
0Bo 46
0D
10s fun
10s α
10s arr
10s i
08i 2 v array/ref
1Ai 2
0Fs α
0D
02i 1
10s i
03
0Fs i
09o -53
16
0D
10s α
01
}]] [def array/map [fn* 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-15
0D
02i 0
1B
1C
10s i
10s ΓεnΣym-15
1E
0Bo 51
0D
10s arr
10s i
10s fun
10s arr
10s i
08i 2 v array/ref
1Ai 1
08i 3 v array/set!
0D
02i 1
10s i
03
0Fs i
09o -58
16
0D
10s arr
01
}]] [def array/filter [fn* 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-16
0D
02i 0
1B
1C
10s ai
10s ΓεnΣym-16
1E
0Bo 87
0D
10s pred
10s arr
10s ai
08i 2 v array/ref
1Ai 1
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? [fn* 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-17
0D
02i 0
1B
1C
10s i
10s ΓεnΣym-17
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 [fn* array/push [arr . val] "Append all arguments following ARR to ARR" #{
15
10s val
0Es ΓεnΣym-18
0D
10s ΓεnΣym-18
0Bo 104
02i 0
1B
1C
10s ΓεnΣym-18
0Bo 90
0D
10s ΓεnΣym-18
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-18
08i 1 v cdr
0Fs ΓεnΣym-18
09o -92
09o 4
24
16
0D
10s arr
01
}]] [def array/swap [fn* 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 [fn* 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 [fn* 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 [fn* 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 [fn* 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-19
0D
02i 0
1B
1C
10s i
10s ΓεnΣym-19
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 [fn* 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! [fn* 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 [fn* 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! [fn* 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 [fn* array/2d/print [data] "" #{
15
02i 0
0Es y
0D
10s data
05v :height
08i 2 v tree/ref
0Es ΓεnΣym-22
0D
02i 0
1B
1C
10s y
10s ΓεnΣym-22
1E
0Bo 115
0D
15
02i 0
0Es x
0D
10s data
05v :width
08i 2 v tree/ref
0Es ΓεnΣym-23
0D
02i 0
1B
1C
10s x
10s ΓεnΣym-23
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? [fn* avl/empty? [n] "" #{
05v :e
10s n
20
01
}]] [def avl/default-cmp [fn* 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 [fn* 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 [fn* 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 [fn* 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 [fn* avl/key [n] "" #{
10s n
02i 1
08i 2 v array/ref
01
}]] [def avl/left [fn* avl/left [n] "" #{
10s n
02i 2
08i 2 v array/ref
01
}]] [def avl/right [fn* avl/right [n] "" #{
10s n
02i 3
08i 2 v array/ref
01
}]] [def avl/root [fn* avl/root [r] "" #{
10s r
02i 0
08i 2 v array/ref
01
}]] [def avl/cmp [fn* avl/cmp [r] "" #{
10s r
02i 1
08i 2 v array/ref
01
}]] [def avl/min-node [fn* 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
1Ai 1
16
01
}]] [def avl/update-left [fn* 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 [fn* 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 [fn* 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 [fn* 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 [fn* 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 [fn* 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 [fn* 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 [fn* 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 [fn* avl/insert-rebalance [n cmp v] "" #{
15
10s n
08i 1 v avl/balance
0Es b
0D
10s b
02i 1
22
0Bo 118
15
10s cmp
10s v
10s n
08i 1 v avl/left
08i 1 v avl/key
1Ai 2
0Es ΓεnΣym-29
0D
10s ΓεnΣym-29
02i -1
20
0Bo 15
10s n
08i 1 v avl/rotate-right
09o 62
10s ΓεnΣym-29
02i 1
20
0Bo 34
10s n
10s n
08i 1 v avl/left
08i 1 v avl/rotate-left
08i 2 v avl/update-left
08i 1 v avl/rotate-right
09o 21
10s ΓεnΣym-29
02i 0
20
0Bo 10
10s n
09o 4
24
16
09o 143
10s b
02i -1
1E
0Bo 118
15
10s cmp
10s v
10s n
08i 1 v avl/right
08i 1 v avl/key
1Ai 2
0Es ΓεnΣym-30
0D
10s ΓεnΣym-30
02i 1
20
0Bo 15
10s n
08i 1 v avl/rotate-left
09o 62
10s ΓεnΣym-30
02i -1
20
0Bo 34
10s n
10s n
08i 1 v avl/right
08i 1 v avl/rotate-right
08i 2 v avl/update-right
08i 1 v avl/rotate-left
09o 21
10s ΓεnΣym-30
02i 0
20
0Bo 10
10s n
09o 4
24
16
09o 18
05v #t
0Bo 10
10s n
09o 4
24
16
01
}]] [def avl/node-insert [fn* avl/node-insert [n cmp v] "" #{
10s n
08i 1 v avl/empty?
0Bo 25
02i 1
10s v
10s avl/empty
10s avl/empty
08i 4 v array/new
09o 180
15
10s cmp
10s v
10s n
08i 1 v avl/key
1Ai 2
0Es ΓεnΣym-31
0D
10s ΓεnΣym-31
02i -1
20
0Bo 55
10s n
10s n
08i 1 v avl/left
10s cmp
10s v
08i 3 v avl/node-insert
08i 2 v avl/update-left
08i 1 v avl/update-height
10s cmp
10s v
08i 3 v avl/insert-rebalance
09o 92
10s ΓεnΣym-31
02i 1
20
0Bo 55
10s n
10s n
08i 1 v avl/right
10s cmp
10s v
08i 3 v avl/node-insert
08i 2 v avl/update-right
08i 1 v avl/update-height
10s cmp
10s v
08i 3 v avl/insert-rebalance
09o 30
10s ΓεnΣym-31
02i 0
20
0Bo 19
10s n
10s v
08i 2 v avl/update-key
09o 4
24
16
01
}]] [def avl/insert [fn* 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 [fn* avl/node-get [n cmp v] "" #{
10s n
08i 1 v avl/empty?
0Bo 7
24
09o 122
15
10s cmp
10s v
10s n
08i 1 v avl/key
1Ai 2
0Es ΓεnΣym-32
0D
10s ΓεnΣym-32
02i 0
20
0Bo 15
10s n
08i 1 v avl/key
09o 74
10s ΓεnΣym-32
02i -1
20
0Bo 28
10s n
08i 1 v avl/left
10s cmp
10s v
08i 3 v avl/node-get
09o 39
10s ΓεnΣym-32
02i 1
20
0Bo 28
10s n
08i 1 v avl/right
10s cmp
10s v
08i 3 v avl/node-get
09o 4
24
16
01
}]] [def avl/get [fn* 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 [fn* 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 [fn* 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 [fn* avl/node-remove [n cmp v] "" #{
10s n
08i 1 v avl/empty?
0Bo 10
10s n
09o 301
15
15
10s cmp
10s v
10s n
08i 1 v avl/key
1Ai 2
0Es ΓεnΣym-33
0D
10s ΓεnΣym-33
02i -1
20
0Bo 37
10s n
10s n
08i 1 v avl/left
10s cmp
10s v
08i 3 v avl/node-remove
08i 2 v avl/update-left
09o 201
10s ΓεnΣym-33
02i 1
20
0Bo 37
10s n
10s n
08i 1 v avl/right
10s cmp
10s v
08i 3 v avl/node-remove
08i 2 v avl/update-right
09o 157
10s ΓεnΣym-33
02i 0
20
0Bo 146
10s n
08i 1 v avl/left
08i 1 v avl/empty?
0Bo 15
10s n
08i 1 v avl/right
09o 114
10s n
08i 1 v avl/right
08i 1 v avl/empty?
0Bo 15
10s n
08i 1 v avl/left
09o 85
05v #t
0Bo 77
15
10s n
08i 1 v avl/right
08i 1 v avl/min-node
08i 1 v avl/key
0Es k
0D
10s n
08i 1 v avl/right
10s n
08i 1 v avl/right
10s cmp
10s v
08i 3 v avl/node-remove
08i 2 v avl/update-right
10s k
08i 2 v avl/update-key
16
09o 4
24
09o 4
24
16
0Es root
0D
10s root
08i 1 v avl/update-height
0Fs root
0D
10s root
08i 1 v avl/remove-rebalance
16
01
}]] [def avl/remove [fn* 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? [fn* 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? [fn* 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 [fn* 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
1Ai 2
01
}]] [def avl/reduce [fn* 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 [fn* 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
1Ai 3
01
}]] [def avl/reduce-bin [fn* 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 [fn* 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
25v anonymous v [x acc] v "" v #{
10s acc
10s f
10s x
1Ai 1
08i 2 v avl/insert
01
}
10s t
08i 1 v avl/cmp
08i 1 v avl/tree
08i 3 v avl/reduce
01
}]] [def avl/map-to [fn* 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
25v anonymous v [x acc] v "" v #{
10s acc
10s f
10s x
1Ai 1
08i 2 v avl/insert
01
}
10s cmp
08i 1 v avl/tree
08i 3 v avl/reduce
01
}]] [def avl/to-list [fn* avl/to-list [t] "" #{
10s t
10s cons
24
08i 3 v avl/reduce
01
}]]][do [def sum [fn* sum [c] "Return the sum of every value in collection C" #{
10s c
10s +
02i 0
08i 3 v reduce
01
}]] [def join [fn* 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
25v anonymous v [a b] v "" v #{
10s a
0Bo 23
10s a
10s glue
10s b
08i 3 v cat
09o 7
10s b
01
}
24
08i 3 v reduce
09o 7
05v ""
01
}]] [def for-each [fn* for-each [l f] "Runs F over every item in collection L" #{
10s l
25v anonymous v [a b] v "" v #{
10s f
10s b
1Ai 1
01
}
24
08i 3 v reduce
01
}]] [def count [fn* count [l p] "Count the number of items in L where P is true" #{
10s p
0Bo 30
10s l
25v anonymous v [a b] v "" v #{
10s a
10s p
10s b
1Ai 1
0Bo 8
02i 1
09o 5
02i 0
08i 2 v +
01
}
02i 0
08i 3 v reduce
09o 27
10s l
25v anonymous v [a b] v "" v #{
10s a
02i 1
08i 2 v +
01
}
02i 0
08i 3 v reduce
01
}]] [def min [fn* 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
25v anonymous v [a b] v "" v #{
10s a
10s b
1E
0Bo 10
10s a
09o 7
10s b
01
}
08i 2 v reduce
01
}]] [def max [fn* 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
25v anonymous v [a b] v "" v #{
10s a
10s b
22
0Bo 10
10s a
09o 7
10s b
01
}
08i 2 v reduce
01
}]] [def delete [fn* delete [l e] "Returns a filtered list l with all elements equal to e omitted" #{
10s l
25v anonymous v [a] v "" v #{
10s a
10s e
20
08i 1 v not
01
}
08i 2 v filter
01
}]] [def remove [fn* remove [l p] "Returns a filtered list l with all elements where P equal true removed" #{
10s l
25v anonymous v [a] v "" v #{
10s p
10s a
1Ai 1
08i 1 v not
01
}
08i 2 v filter
01
}]] [def flatten/λ [fn* 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 [fn* 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 [fn* ref [l i] "Return whatver is at position I in L" #{
15
10s l
08i 1 v type-of
0Es ΓεnΣym-43
0D
10s ΓεnΣym-43
05v :nil
20
0Bo 7
24
09o 142
10s ΓεnΣym-43
05v :tree
20
0Bo 19
10s l
10s i
08i 2 v tree/ref
09o 114
10s ΓεnΣym-43
05v :string
20
0Bo 19
10s l
10s i
08i 2 v char-at
09o 86
10s ΓεnΣym-43
05v :array
20
0Bo 19
10s l
10s i
08i 2 v array/ref
09o 58
10s ΓεnΣym-43
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 [fn* 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-44
0D
10s ΓεnΣym-44
05v :nil
20
0Bo 7
24
09o 114
10s ΓεnΣym-44
05v :tree
20
0Bo 19
10s l
10s p
08i 2 v tree/filter
09o 86
10s ΓεnΣym-44
05v :pair
20
0Bo 19
10s l
10s p
08i 2 v list/filter
09o 58
10s ΓεnΣym-44
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 [fn* 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-45
0D
10s ΓεnΣym-45
05v :nil
20
0Bo 10
10s α
09o 113
10s ΓεnΣym-45
05v :tree
20
0Bo 23
10s l
10s f
10s α
08i 3 v tree/reduce
09o 81
10s ΓεnΣym-45
05v :pair
20
0Bo 23
10s l
10s f
10s α
08i 3 v list/reduce
09o 49
10s ΓεnΣym-45
05v :array
20
0Bo 23
10s l
10s f
10s α
08i 3 v array/reduce
09o 17
10s f
10s α
10s l
1Ai 2
16
01
}]] [def length [fn* length [α] "Returns the length of collection α" #{
15
10s α
08i 1 v type-of
0Es ΓεnΣym-46
0D
10s ΓεnΣym-46
05v :nil
20
0Bo 8
02i 0
09o 126
10s ΓεnΣym-46
05v :array
20
0Bo 15
10s α
08i 1 v array/length
09o 102
10s ΓεnΣym-46
05v :pair
20
0Bo 15
10s α
08i 1 v list/length
09o 78
10s ΓεnΣym-46
05v :string
20
0Bo 15
10s α
08i 1 v string/length
09o 54
10s ΓεnΣym-46
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 [fn* map [l f] "Runs f over every item in collection l and returns the resulting list" #{
15
10s l
08i 1 v type-of
0Es ΓεnΣym-47
0D
10s ΓεnΣym-47
05v :nil
20
0Bo 7
24
09o 86
10s ΓεnΣym-47
05v :pair
20
0Bo 19
10s l
10s f
08i 2 v list/map
09o 58
10s ΓεnΣym-47
05v :array
20
0Bo 19
10s l
10s f
08i 2 v array/map
09o 30
05v :type-error
05v "You can only use map with a collection"
10s l
08i 0 v current-lambda
08i 4 v list
08i 1 v throw
16
01
}]] [def sort [fn* sort [l] "Sorts the collection L" #{
15
10s l
08i 1 v type-of
0Es ΓεnΣym-48
0D
10s ΓεnΣym-48
05v :nil
20
0Bo 7
24
09o 78
10s ΓεnΣym-48
05v :pair
20
0Bo 15
10s l
08i 1 v list/sort/merge
09o 54
10s ΓεnΣym-48
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 [fn* 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-49
0D
10s ΓεnΣym-49
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 [fn* cut [l start end] "Return a subcollection of L from START to END" #{
15
10s l
08i 1 v type-of
0Es ΓεnΣym-50
0D
10s ΓεnΣym-50
05v :array
20
0Bo 23
10s l
10s start
10s end
08i 3 v array/cut
09o 94
10s ΓεnΣym-50
05v :pair
20
0Bo 23
10s l
10s start
10s end
08i 3 v list/cut
09o 62
10s ΓεnΣym-50
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? [fn* collection? [l] "" #{
15
10s l
08i 1 v type-of
0Es ΓεnΣym-51
0D
10s ΓεnΣym-51
05v :pair
20
0C
0Ao 36
0D
10s ΓεnΣym-51
05v :array
20
0C
0Ao 22
0D
10s ΓεnΣym-51
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 [fn* 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 [fn* 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 [fn* 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 [fn* 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 [fn* 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
1Ai 2
0Bo 42
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 [fn* list/reduce [l o s] "Combine all elements in l using operation o and starting value s" #{
15
10s l
0Es ΓεnΣym-57
0D
10s ΓεnΣym-57
0Bo 67
02i 0
1B
1C
10s ΓεnΣym-57
0Bo 53
0D
10s ΓεnΣym-57
08i 1 v car
0Es e
0D
10s o
10s s
10s e
1Ai 2
0Fs s
0D
10s ΓεnΣym-57
08i 1 v cdr
0Fs ΓεnΣym-57
09o -55
09o 4
24
16
0D
10s s
01
}]] [def list/ref [fn* 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 [fn* reverse [l] "Return the list l in reverse order" #{
24
0Es ret
0D
15
10s l
0Es ΓεnΣym-58
0D
10s ΓεnΣym-58
0Bo 66
02i 0
1B
1C
10s ΓεnΣym-58
0Bo 52
0D
10s ΓεnΣym-58
08i 1 v car
0Es e
0D
10s e
10s ret
08i 2 v cons
0Fs ret
0D
10s ΓεnΣym-58
08i 1 v cdr
0Fs ΓεnΣym-58
09o -54
09o 4
24
16
0D
10s ret
01
}]] [def list/length [fn* list/length [l] "Returns the length of list l" #{
02i 0
0Es ret
0D
15
10s l
0Es ΓεnΣym-59
0D
10s ΓεnΣym-59
0Bo 64
02i 0
1B
1C
10s ΓεnΣym-59
0Bo 50
0D
10s ΓεnΣym-59
08i 1 v car
0Es e
0D
02i 1
10s ret
08i 2 v +
0Fs ret
0D
10s ΓεnΣym-59
08i 1 v cdr
0Fs ΓεnΣym-59
09o -52
09o 4
24
16
0D
10s ret
01
}]] [def list/filter [fn* 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-60
0D
10s ΓεnΣym-60
0Bo 83
02i 0
1B
1C
10s ΓεnΣym-60
0Bo 69
0D
10s ΓεnΣym-60
08i 1 v car
0Es e
0D
10s p
10s e
1Ai 1
0Bo 23
10s e
10s ret
08i 2 v cons
0Fs ret
09o 4
24
0D
10s ΓεnΣym-60
08i 1 v cdr
0Fs ΓεnΣym-60
09o -71
09o 4
24
16
0D
10s ret
08i 1 v nreverse
01
}]] [def list/map [fn* 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-61
0D
10s ΓεnΣym-61
0Bo 72
02i 0
1B
1C
10s ΓεnΣym-61
0Bo 58
0D
10s ΓεnΣym-61
08i 1 v car
0Es e
0D
10s f
10s e
1Ai 1
10s ret
08i 2 v cons
0Fs ret
0D
10s ΓεnΣym-61
08i 1 v cdr
0Fs ΓεnΣym-61
09o -60
09o 4
24
16
0D
10s ret
08i 1 v nreverse
01
}]] [def append/iter [fn* 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 [fn* 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 [fn* 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 [fn* 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 [fn* 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 [fn* 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 [fn* 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 [fn* 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 [fn* list/merge-sorted-lists [l1 l2] "" #{
10s l1
08i 1 v nil?
0Bo 10
10s l2
09o 122
10s l2
08i 1 v nil?
0Bo 10
10s l1
09o 103
05v #t
0Bo 95
10s l1
08i 1 v car
10s l2
08i 1 v car
1E
0Bo 38
10s l1
08i 1 v car
10s l1
08i 1 v cdr
10s l2
08i 2 v list/merge-sorted-lists
08i 2 v cons
09o 35
10s l2
08i 1 v car
10s l1
10s l2
08i 1 v cdr
08i 2 v list/merge-sorted-lists
08i 2 v cons
09o 4
24
01
}]] [def list/split-half-rec [fn* list/split-half-rec [l acc1 acc2] "" #{
10s l
08i 1 v nil?
0Bo 19
10s acc1
10s acc2
08i 2 v cons
09o 111
10s l
08i 1 v cdr
08i 1 v nil?
0Bo 33
10s l
08i 1 v car
10s acc1
08i 2 v cons
10s acc2
08i 2 v cons
09o 64
05v #t
0Bo 56
10s l
08i 1 v cddr
10s l
08i 1 v car
10s acc1
08i 2 v cons
10s l
08i 1 v cadr
10s acc2
08i 2 v cons
08i 3 v list/split-half-rec
09o 4
24
01
}]] [def list/split-half [fn* list/split-half [l] "" #{
10s l
24
24
08i 3 v list/split-half-rec
01
}]] [def list/sort/merge [fn* 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? [fn* 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 [fn* 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 [fn* 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 [fn* 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 [fn* 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-64
0D
10s ΓεnΣym-64
0Bo 85
02i 0
1B
1C
10s ΓεnΣym-64
0Bo 71
0D
10s ΓεnΣym-64
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-64
08i 1 v cdr
0Fs ΓεnΣym-64
09o -73
09o 4
24
16
0D
10s ret
01
}]] [def tree/+= [fn* 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
0C
0Ao 15
0D
02i 0
0C
0Ao 8
0D
05v #f
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? [fn* 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 [fn* tree/reduce [l o s] "Combine all elements in l using operation o and starting value s" #{
10s l
08i 1 v tree/values
10s o
10s s
08i 3 v list/reduce
01
}]] [def tree/filter [fn* 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-65
0D
10s ΓεnΣym-65
0Bo 101
02i 0
1B
1C
10s ΓεnΣym-65
0Bo 87
0D
10s ΓεnΣym-65
08i 1 v car
0Es e
0D
10s l
10s e
08i 2 v tree/ref
0Es t
0D
10s f
10s t
1Ai 1
0Bo 23
10s ret
10s e
10s t
08i 3 v tree/set!
09o 4
24
0D
10s ΓεnΣym-65
08i 1 v cdr
0Fs ΓεnΣym-65
09o -89
09o 4
24
16
0D
10s ret
01
}]]][do [def val->bytecode-op [fn* 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 [fn* 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? [fn* int-fit-in-byte? [a] "" #{
10s a
02i 127
1F
0C
0Bo 11
0D
10s a
02i -128
21
01
}]] [def $nop [fn* $nop [] "- | Do nothing" #{
05v [#$0]
01
}]] [def $ret [fn* $ret [] "a - | Return top of value stack" #{
05v [#$1]
01
}]] [def $push/int/byte [fn* $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 [fn* $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 [fn* $add/int [] "a b - c | Adds the two topmost values and pushes the result" #{
05v [#$3]
01
}]] [def $debug/print-stack [fn* $debug/print-stack [] "- | Print out the stack for the current closure" #{
05v [#$4]
01
}]] [def $push/lval [fn* $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 [fn* $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 [fn* $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 [fn* $eval [a] "form - | Evaluates the form from the top of the stack" #{
05v [#$7]
01
}]] [def $apply [fn* $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-71
0D
10s ΓεnΣym-71
24
20
0Bo 10
10s do
09o 201
10s ΓεnΣym-71
02i 2
20
0Bo 164
15
10s fun
0Es ΓεnΣym-72
0D
10s ΓεnΣym-72
10s add/int
20
0Bo 11
08i 0 v $add/int
09o 130
10s ΓεnΣym-72
10s <
20
0Bo 11
08i 0 v $<
09o 110
10s ΓεnΣym-72
10s <=
20
0Bo 11
08i 0 v $<=
09o 90
10s ΓεnΣym-72
10s ==
20
0Bo 11
08i 0 v $==
09o 70
10s ΓεnΣym-72
10s >=
20
0Bo 11
08i 0 v $>=
09o 50
10s ΓεnΣym-72
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 [fn* $apply/dynamic [arg-count fun] "" #{
05v #$1A
10s arg-count
08i 1 v int->bytecode-op
08i 2 v list
01
}]] [def $call [fn* $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 [fn* $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 [fn* $throw [] " - | Return to the closest exception handler" #{
05v #$19
08i 1 v list
01
}]] [def $jmp [fn* $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 [fn* $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 [fn* $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 [fn* $dup [] "" #{
05v [#$C]
01
}]] [def $drop [fn* $drop [] "" #{
05v [#$D]
01
}]] [def $def [fn* $def [v] "" #{
05v #$E
10s v
08i 1 v sym->bytecode-op
08i 2 v list
01
}]] [def $set [fn* $set [v] "" #{
05v #$F
10s v
08i 1 v sym->bytecode-op
08i 2 v list
01
}]] [def $get [fn* $get [v] "" #{
05v #$10
10s v
08i 1 v sym->bytecode-op
08i 2 v list
01
}]] [def $lambda [fn* $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 $fn [fn* $fn [name args docs body] "" #{
05v #$25
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 [fn* $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 $macro* [fn* $macro* [name args docs body] "" #{
05v #$26
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 [fn* $closure/push [] "" #{
05v [#$13]
01
}]] [def $closure/enter [fn* $closure/enter [] "" #{
05v [#$14]
01
}]] [def $let [fn* $let [] "" #{
05v [#$15]
01
}]] [def $closure/pop [fn* $closure/pop [] "" #{
05v [#$16]
01
}]] [def $roots/save [fn* $roots/save [] "" #{
05v [#$1B]
01
}]] [def $roots/restore [fn* $roots/restore [] "" #{
05v [#$1C]
01
}]] [def $< [fn* $< [] "" #{
05v [#$1E]
01
}]] [def $<= [fn* $<= [] "" #{
05v [#$1F]
01
}]] [def $== [fn* $== [] "" #{
05v [#$20]
01
}]] [def $>= [fn* $>= [] "" #{
05v [#$21]
01
}]] [def $> [fn* $> [] "" #{
05v [#$22]
01
}]] [def $push/nil [fn* $push/nil [] "" #{
05v [#$24]
01
}]] [def $swap [fn* $swap [] "" #{
05v [#$27]
01
}]] [def assemble/build-sym-map [fn* 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-73
0D
10s ΓεnΣym-73
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-73
05v :symbol
20
0C
0Ao 22
0D
10s ΓεnΣym-73
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-73
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 [fn* 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 [fn* 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-74
0D
10s ΓεnΣym-74
0Bo 149
02i 0
1B
1C
10s ΓεnΣym-74
0Bo 135
0D
10s ΓεnΣym-74
08i 1 v car
0Es op
0D
15
10s op
08i 1 v type-of
0Es ΓεnΣym-75
0D
10s ΓεnΣym-75
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-75
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-74
08i 1 v cdr
0Fs ΓεnΣym-74
09o -137
09o 4
24
16
0D
10s pos
01
}]] [def assemble/verbose #f] [def assemble* [fn* 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 [fn* 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 [fn* 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 [fn* bytecompile/literal [source] "" #{
15
10s source
08i 1 v type-of
0Es ΓεnΣym-80
0D
10s ΓεnΣym-80
05v :symbol
20
0C
0Ao 22
0D
10s ΓεnΣym-80
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-80
05v :int
20
0Bo 15
10s source
08i 1 v $push/int
09o 32
10s ΓεnΣym-80
05v :nil
20
0Bo 11
08i 0 v $push/nil
09o 12
10s source
08i 1 v $push/lval
16
01
}]] [def bytecompile/quote [fn* bytecompile/quote [source] "" #{
15
10s source
08i 1 v type-of
0Es ΓεnΣym-81
0D
10s ΓεnΣym-81
05v :int
20
0Bo 15
10s source
08i 1 v $push/int
09o 36
10s ΓεnΣym-81
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 [fn* 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 [fn* 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 [fn* 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 [fn* 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! [fn* 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 [fn* 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 [fn* 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 [fn* 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 [fn* 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 [fn* 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 [fn* 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 [fn* 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 [fn* 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 [fn* 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 [fn* bytecompile/string [source env] "" #{
10s cat
10s source
10s env
08i 3 v bytecompile/procedure
01
}]] [def bytecompile/array [fn* bytecompile/array [source env] "" #{
10s array/ref
10s source
10s env
08i 3 v bytecompile/procedure
01
}]] [def bytecompile/tree [fn* bytecompile/tree [source env] "" #{
10s tree/ref
10s source
10s env
08i 3 v bytecompile/procedure
01
}]] [def bytecompile/λ* [fn* bytecompile/λ* [source env] "" #{
10s $lambda
10s source
08i 1 v cdr
08i 2 v apply
01
}]] [def bytecompile/fn* [fn* bytecompile/fn* [source env] "" #{
10s $fn
10s source
08i 1 v cdr
08i 2 v apply
01
}]] [def bytecompile/macro* [fn* bytecompile/macro* [source env] "" #{
10s $macro*
10s source
08i 1 v cdr
08i 2 v apply
01
}]] [def bytecompile/μ* [fn* bytecompile/μ* [source env] "" #{
10s $macro
10s source
08i 1 v cdr
08i 2 v apply
01
}]] [def bytecompile/ω* [fn* 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* [fn* 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 [fn* bytecompile/try [source env] "" #{
08i 0 v bytecompile/gen-label
0Es handler-sym
0D
08i 0 v bytecompile/gen-label
0Es end-sym
0D
08i 0 v bytecompile/gen-label
0Es final-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
10s final-sym
08i 1 v $jmp
05v :label
10s end-sym
08i 2 v list
08i 0 v $swap
08i 0 v $drop
05v :label
10s final-sym
08i 2 v list
08i 11 v list
01
}]] [def bytecompile* [fn* 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-82
0D
10s ΓεnΣym-82
05v :special-form
20
0Bo 470
15
10s op
0Es ΓεnΣym-83
0D
10s ΓεnΣym-83
10s do
20
0Bo 19
10s source
10s env
08i 2 v bytecompile/do
09o 428
10s ΓεnΣym-83
10s let*
20
0Bo 19
10s source
10s env
08i 2 v bytecompile/let*
09o 400
10s ΓεnΣym-83
10s def
20
0Bo 19
10s source
10s env
08i 2 v bytecompile/def
09o 372
10s ΓεnΣym-83
10s set!
20
0Bo 19
10s source
10s env
08i 2 v bytecompile/set!
09o 344
10s ΓεnΣym-83
10s if
20
0Bo 19
10s source
10s env
08i 2 v bytecompile/if
09o 316
10s ΓεnΣym-83
10s while
20
0Bo 19
10s source
10s env
08i 2 v bytecompile/while
09o 288
10s ΓεnΣym-83
10s and
20
0Bo 19
10s source
10s env
08i 2 v bytecompile/and
09o 260
10s ΓεnΣym-83
10s or
20
0Bo 19
10s source
10s env
08i 2 v bytecompile/or
09o 232
10s ΓεnΣym-83
10s fn*
20
0Bo 19
10s source
10s env
08i 2 v bytecompile/fn*
09o 204
10s ΓεnΣym-83
10s λ*
20
0Bo 19
10s source
10s env
08i 2 v bytecompile/λ*
09o 176
10s ΓεnΣym-83
10s macro*
20
0Bo 19
10s source
10s env
08i 2 v bytecompile/macro*
09o 148
10s ΓεnΣym-83
10s μ*
20
0Bo 19
10s source
10s env
08i 2 v bytecompile/μ*
09o 120
10s ΓεnΣym-83
10s ω*
20
0Bo 19
10s source
10s env
08i 2 v bytecompile/ω*
09o 92
10s ΓεnΣym-83
10s try
20
0Bo 19
10s source
10s env
08i 2 v bytecompile/try
09o 64
10s ΓεnΣym-83
10s quote
20
0Bo 20
10s source
08i 1 v cadr
08i 1 v bytecompile/quote
09o 35
05v :panic
05v "Found unknown special form in the bytecode compiler"
10s source
08i 1 v car
08i 0 v current-lambda
08i 4 v list
08i 1 v throw
16
09o 216
10s ΓεnΣym-82
05v :lambda
20
0C
0Ao 22
0D
10s ΓεnΣym-82
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-82
05v :pair
20
0C
0Ao 22
0D
10s ΓεnΣym-82
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-82
05v :string
20
0Bo 19
10s source
10s env
08i 2 v bytecompile/string
09o 68
10s ΓεnΣym-82
05v :array
20
0Bo 19
10s source
10s env
08i 2 v bytecompile/array
09o 40
10s ΓεnΣym-82
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 [fn* 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 [fn* 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 [fn* compile/do [source] "" #{
10s source
08i 1 v compile/do/args
0Es args
0D
10s args
08i 1 v last?
0Bo 15
10s args
08i 1 v car
09o 16
23s do
10s args
08i 2 v cons
01
}]] [def compile/def [fn* compile/def [source] "" #{
23s def
10s source
08i 1 v cadr
10s source
08i 1 v caddr
08i 1 v compile*
08i 3 v list
01
}]] [def compile/set! [fn* compile/set! [source] "" #{
23s set!
10s source
08i 1 v cadr
10s source
08i 1 v caddr
08i 1 v compile*
08i 3 v list
01
}]] [def compile/λ* [fn* compile/λ* [source] "" #{
23s λ*
10s source
08i 1 v cadr
10s source
08i 1 v caddr
10s source
08i 1 v cadddr
10s source
08i 1 v caddddr
08i 1 v compile
08i 5 v list
01
}]] [def compile/fn* [fn* compile/fn* [source] "" #{
23s fn*
10s source
08i 1 v cadr
10s source
08i 1 v caddr
10s source
08i 1 v cadddr
10s source
08i 1 v caddddr
08i 1 v compile
08i 5 v list
01
}]] [def compile/macro* [fn* compile/macro* [source] "" #{
23s macro*
10s source
08i 1 v cadr
10s source
08i 1 v caddr
10s source
08i 1 v cadddr
10s source
08i 1 v caddddr
08i 1 v compile
08i 5 v list
01
}]] [def compile/μ* [fn* compile/μ* [source] "" #{
23s μ*
10s source
08i 1 v cadr
10s source
08i 1 v caddr
10s source
08i 1 v cadddr
10s source
08i 1 v caddddr
08i 1 v compile
08i 5 v list
01
}]] [def compile/ω* [fn* compile/ω* [source] "" #{
23s ω*
10s source
08i 1 v cdr
08i 1 v compile/do
08i 2 v list
01
}]] [def compile/try [fn* compile/try [source] "" #{
23s try
10s source
08i 1 v cadr
08i 1 v compile*
10s source
08i 1 v cddr
08i 1 v compile/do
08i 3 v list
01
}]] [def compile/if [fn* compile/if [source] "" #{
23s if
10s source
08i 1 v cadr
08i 1 v compile*
10s source
08i 1 v caddr
08i 1 v compile*
10s source
08i 1 v cadddr
08i 1 v compile*
08i 4 v list
01
}]] [def compile/let* [fn* compile/let* [source] "" #{
23s let*
10s source
08i 1 v cdr
08i 1 v compile/do
08i 2 v list
01
}]] [def compile/and [fn* compile/and [source] "" #{
10s source
08i 1 v compile/procedure/arg
01
}]] [def compile/or [fn* compile/or [source] "" #{
10s source
08i 1 v compile/procedure/arg
01
}]] [def compile/while [fn* compile/while [source] "" #{
23s while
10s source
08i 1 v cadr
08i 1 v compile*
10s source
08i 1 v cddr
08i 1 v compile/do
08i 3 v list
01
}]] [def compile/macro [fn* compile/macro [macro source] "" #{
10s macro
10s source
08i 1 v cdr
08i 2 v macro-apply
08i 1 v compile*
01
}]] [def compile/procedure/arg [fn* compile/procedure/arg [source] "" #{
10s source
08i 1 v pair?
0Bo 39
10s source
08i 1 v car
08i 1 v compile*
10s source
08i 1 v cdr
08i 1 v compile/procedure/arg
08i 2 v cons
09o 4
24
01
}]] [def compile/procedure [fn* compile/procedure [proc source] "" #{
10s source
08i 1 v compile/procedure/arg
01
}]] [def compile* [fn* compile* [source] "Compile the forms in source" #{
10s compile/environment
23s do
23s resolves?
23s quote
10s source
08i 1 v car
08i 2 v list
24
08i 2 v cons
08i 2 v cons
24
08i 2 v cons
08i 2 v cons
08i 2 v apply
0Bo 63
10s compile/environment
23s do
23s resolve
23s quote
10s source
08i 1 v car
08i 2 v list
24
08i 2 v cons
08i 2 v cons
24
08i 2 v cons
08i 2 v cons
08i 2 v apply
09o 12
10s source
08i 1 v car
0Es op
0D
15
10s op
08i 1 v type-of
0Es ΓεnΣym-88
0D
10s ΓεnΣym-88
05v :special-form
20
0Bo 394
15
10s op
0Es ΓεnΣym-89
0D
10s ΓεnΣym-89
10s do
20
0Bo 15
10s source
08i 1 v compile/do
09o 356
10s ΓεnΣym-89
10s def
20
0Bo 15
10s source
08i 1 v compile/def
09o 332
10s ΓεnΣym-89
10s set!
20
0Bo 15
10s source
08i 1 v compile/set!
09o 308
10s ΓεnΣym-89
10s let*
20
0Bo 15
10s source
08i 1 v compile/let*
09o 284
10s ΓεnΣym-89
10s λ*
20
0Bo 15
10s source
08i 1 v compile/λ*
09o 260
10s ΓεnΣym-89
10s fn*
20
0Bo 15
10s source
08i 1 v compile/fn*
09o 236
10s ΓεnΣym-89
10s macro*
20
0Bo 15
10s source
08i 1 v compile/macro*
09o 212
10s ΓεnΣym-89
10s μ*
20
0Bo 15
10s source
08i 1 v compile/μ*
09o 188
10s ΓεnΣym-89
10s ω*
20
0Bo 15
10s source
08i 1 v compile/ω*
09o 164
10s ΓεnΣym-89
10s if
20
0Bo 15
10s source
08i 1 v compile/if
09o 140
10s ΓεnΣym-89
10s try
20
0Bo 15
10s source
08i 1 v compile/try
09o 116
10s ΓεnΣym-89
10s and
20
0Bo 15
10s source
08i 1 v compile/and
09o 92
10s ΓεnΣym-89
10s or
20
0Bo 15
10s source
08i 1 v compile/or
09o 68
10s ΓεnΣym-89
10s while
20
0Bo 15
10s source
08i 1 v compile/while
09o 44
10s ΓεnΣym-89
10s quote
20
0Bo 10
10s source
09o 25
05v :panic
05v "Unknown special form, please fix the compiler!"
10s source
08i 3 v list
08i 1 v throw
16
09o 291
10s ΓεnΣym-88
05v :macro
20
0Bo 19
10s op
10s source
08i 2 v compile/macro
09o 263
10s ΓεnΣym-88
05v :lambda
20
0C
0Ao 22
0D
10s ΓεnΣym-88
05v :native-function
20
0C
0Ao 8
0D
05v #f
0Bo 19
10s op
10s source
08i 2 v compile/procedure
09o 212
10s ΓεnΣym-88
05v :object
20
0Bo 15
10s source
08i 1 v compile/procedure/arg
09o 188
10s ΓεnΣym-88
05v :pair
20
0Bo 15
10s source
08i 1 v compile/procedure/arg
09o 164
10s ΓεnΣym-88
05v :int
20
0C
0Ao 36
0D
10s ΓεnΣym-88
05v :float
20
0C
0Ao 22
0D
10s ΓεnΣym-88
05v :vec
20
0C
0Ao 8
0D
05v #f
0Bo 15
10s source
08i 1 v compile/procedure/arg
09o 103
10s ΓεnΣym-88
05v :array
20
0Bo 15
10s source
08i 1 v compile/procedure/arg
09o 79
10s ΓεnΣym-88
05v :string
20
0Bo 15
10s source
08i 1 v compile/procedure/arg
09o 55
10s ΓεnΣym-88
05v :tree
20
0Bo 15
10s source
08i 1 v compile/procedure/arg
09o 31
10s source
08i 1 v last?
0Bo 10
10s source
09o 12
10s source
08i 1 v compile/procedure/arg
16
01
}]] [def compile [fn* 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 [fn* load/forms [source-raw environment] "Load multiple forms, evaluating the results in environment, so we can make use of macros we just defined" #{
24
0Es source
0D
10s source-raw
0Es source-next
0D
02i 0
0Es forms-compiled
0D
25v try-again v [source] v "" v #{
10s source
10s source-next
08i 2 v cons
0Fs source-next
01
}
0Es try-again
0D
02i 0
1B
1C
10s source-next
0Bo 268
0D
10s forms-compiled
0Es forms-compiled-last
0D
10s source-next
0Fs source
0D
24
0Fs source-next
0D
24
0Es errors
0D
15
10s source
0Es ΓεnΣym-90
0D
10s ΓεnΣym-90
0Bo 152
02i 0
1B
1C
10s ΓεnΣym-90
0Bo 138
0D
10s ΓεnΣym-90
08i 1 v car
0Es form
0D
25v anonymous v [err] v "" v #{
10s err
10s errors
08i 2 v cons
0Fs errors
0D
15
10s err
08i 1 v car
0Es ΓεnΣym-91
0D
10s ΓεnΣym-91
05v :unresolved-procedure
20
0Bo 21
10s try-again
10s source
08i 1 v car
1Ai 1
09o 42
10s ΓεnΣym-91
05v :runtime-macro
20
0Bo 21
10s try-again
10s source
08i 1 v car
1Ai 1
09o 12
10s err
08i 1 v throw
16
01
}
18o 83
10s form
10s environment
05v #t
08i 3 v compile
0Es compiled-form
0D
10s compiled-form
0Bo 50
10s environment
23s eval*
10s compiled-form
24
08i 2 v cons
08i 2 v cons
08i 2 v apply
0D
02i 1
10s forms-compiled
08i 2 v +
0Fs forms-compiled
09o 4
24
09o 8
1Ai 1
09o 5
27
0D
0D
10s ΓεnΣym-90
08i 1 v cdr
0Fs ΓεnΣym-90
09o -140
09o 4
24
16
0D
10s source-next
08i 1 v nreverse
0Fs source-next
0D
10s forms-compiled
10s forms-compiled-last
1F
0Bo 38
10s errors
10s display/error
08i 2 v for-each
0D
05v :you-can-not-advance
05v "The compiler got stuck trying to compile various forms, the final pass did not have a single form that compiled without errors"
08i 2 v list
08i 1 v throw
09o 4
24
09o -270
01
}]] [def compile/forms [fn* 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" #{
10s environment
0Bo 7
24
09o 10
15
13
16
0Fs environment
0D
10s source-raw
10s environment
08i 2 v load/forms
0D
10s source-raw
10s environment
08i 2 v compile
01
}]] [def defmacro [μ* defmacro [name args . body] "Define a new bytecoded macro" [do [def doc-string [if [string? [car body]] [car body] ""]] [list 'def name [list macro* name args doc-string [assemble* [bytecompile [compile [cons 'do body] [current-closure]]]]]]]]] [def macro [μ* macro [args . body] "Return a new bytecoded macro" [do [def doc-string [if [string? [car body]] [car body] ""]] [list macro* #nil args doc-string [assemble* [bytecompile [compile [cons 'do body] [current-closure]]]]]]]] [def fn [μ* fn [args . body] "Define a λδ with the self-hosting Nujel compiler" [do [def doc-string [if [string? [car body]] [car body] ""]] [list fn* 'anonymous args doc-string [assemble* [bytecompile [compile [cons 'do body] [current-closure]]]]]]]] [def defn [μ* defn [name args . body] "Define a new bytecoded function" [do [def doc-string [if [string? [car body]] [car body] ""]] [list 'def name [list fn* name args doc-string [assemble* [bytecompile [compile [cons 'do body] [current-closure]]]]]]]]] [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 [fn* eval-compile [expr closure] "Compile and the immediatly evaluate the result, mostly used by lRun()" #{
10s display/error
18o 24
10s expr
10s closure
08i 2 v compile
08i 1 v eval*
09o 8
1Ai 1
09o 5
27
0D
01
}]] [def read-eval-compile [fn* read-eval-compile [expr closure] "Compile and the immediatly evaluate the result, mostly used by lRun()" #{
10s display/error
18o 29
10s expr
08i 1 v read
10s closure
08i 2 v compile
08i 1 v eval*
09o 8
1Ai 1
09o 5
27
0D
01
}]] [def eval-load [fn* eval-load [expr closure] "Compile and the immediatly evaluate the result, mostly used by lRun()" #{
10s display/error
18o 19
10s expr
10s closure
08i 2 v load/forms
09o 8
1Ai 1
09o 5
27
0D
01
}]] [def read-eval-load [fn* read-eval-load [expr closure] "Compile and the immediatly evaluate the result, mostly used by lRun()" #{
10s display/error
18o 24
10s expr
08i 1 v read
10s closure
08i 2 v load/forms
09o 8
1Ai 1
09o 5
27
0D
01
}]] [def typecheck/only [μ* typecheck/only [v t] "" [cons 'when-not [cons [cons '== [cons [cons 'type-of [cons v #nil]] [cons t #nil]]] [cons [cons 'throw [cons [cons 'list [cons :type-error [cons [cat "Expected a value of type " t] [cons v [cons [cons 'current-lambda #nil] #nil]]]]] #nil]] #nil]]]]]][do [def disassemble/length [fn* disassemble/length [op] "Return the length in bytes of a bytecode operation and all its arguments" #{
15
10s op
0Es ΓεnΣym-97
0D
10s ΓεnΣym-97
05v #$0
20
0C
0Ao 288
0D
10s ΓεnΣym-97
05v #$1
20
0C
0Ao 274
0D
10s ΓεnΣym-97
05v #$3
20
0C
0Ao 260
0D
10s ΓεnΣym-97
05v #$4
20
0C
0Ao 246
0D
10s ΓεnΣym-97
05v #$7
20
0C
0Ao 232
0D
10s ΓεnΣym-97
05v #$C
20
0C
0Ao 218
0D
10s ΓεnΣym-97
05v #$D
20
0C
0Ao 204
0D
10s ΓεnΣym-97
05v #$13
20
0C
0Ao 190
0D
10s ΓεnΣym-97
05v #$14
20
0C
0Ao 176
0D
10s ΓεnΣym-97
05v #$15
20
0C
0Ao 162
0D
10s ΓεnΣym-97
05v #$16
20
0C
0Ao 148
0D
10s ΓεnΣym-97
05v #$19
20
0C
0Ao 134
0D
10s ΓεnΣym-97
05v #$1B
20
0C
0Ao 120
0D
10s ΓεnΣym-97
05v #$1C
20
0C
0Ao 106
0D
10s ΓεnΣym-97
05v #$1E
20
0C
0Ao 92
0D
10s ΓεnΣym-97
05v #$1F
20
0C
0Ao 78
0D
10s ΓεnΣym-97
05v #$20
20
0C
0Ao 64
0D
10s ΓεnΣym-97
05v #$21
20
0C
0Ao 50
0D
10s ΓεnΣym-97
05v #$22
20
0C
0Ao 36
0D
10s ΓεnΣym-97
05v #$24
20
0C
0Ao 22
0D
10s ΓεnΣym-97
05v #$27
20
0C
0Ao 8
0D
05v #f
0Bo 8
02i 1
09o 342
10s ΓεnΣym-97
05v #$2
20
0C
0Ao 36
0D
10s ΓεnΣym-97
05v #$6
20
0C
0Ao 22
0D
10s ΓεnΣym-97
05v #$1A
20
0C
0Ao 8
0D
05v #f
0Bo 8
02i 2
09o 288
10s ΓεnΣym-97
05v #$9
20
0C
0Ao 64
0D
10s ΓεnΣym-97
05v #$A
20
0C
0Ao 50
0D
10s ΓεnΣym-97
05v #$B
20
0C
0Ao 36
0D
10s ΓεnΣym-97
05v #$17
20
0C
0Ao 22
0D
10s ΓεnΣym-97
05v #$18
20
0C
0Ao 8
0D
05v #f
0Bo 8
02i 3
09o 206
10s ΓεnΣym-97
05v #$5
20
0C
0Ao 64
0D
10s ΓεnΣym-97
05v #$E
20
0C
0Ao 50
0D
10s ΓεnΣym-97
05v #$F
20
0C
0Ao 36
0D
10s ΓεnΣym-97
05v #$10
20
0C
0Ao 22
0D
10s ΓεnΣym-97
05v #$23
20
0C
0Ao 8
0D
05v #f
0Bo 8
02i 4
09o 124
10s ΓεnΣym-97
05v #$8
20
0C
0Ao 8
0D
05v #f
0Bo 8
02i 5
09o 98
10s ΓεnΣym-97
05v #$11
20
0C
0Ao 50
0D
10s ΓεnΣym-97
05v #$12
20
0C
0Ao 36
0D
10s ΓεnΣym-97
05v #$25
20
0C
0Ao 22
0D
10s ΓεnΣym-97
05v #$26
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 [fn* 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 [fn* 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 [fn* bytecode-arr->val [a i] "Read a bytecode encoded value in A at I and return it" #{
10s bytecode/nil-catcher
18o 64
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 8
1Ai 1
09o 5
27
0D
01
}]] [def bytecode-op->sym [fn* 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 [fn* bytecode-arr->sym [a i] "Read a bytecode encoded symbol in A at I and return it" #{
10s bytecode/nil-catcher
18o 64
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 8
1Ai 1
09o 5
27
0D
01
}]] [def bytecode-op->offset [fn* 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 [fn* 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 [fn* 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-98
0D
10s ΓεnΣym-98
05v #$0
20
0Bo 10
05v [$nop]
09o 1711
10s ΓεnΣym-98
05v #$1
20
0Bo 10
05v [$ret]
09o 1692
10s ΓεnΣym-98
05v #$2
20
0Bo 46
23s $push/int/byte
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 1637
10s ΓεnΣym-98
05v #$3
20
0Bo 10
05v [$add/int]
09o 1618
10s ΓεnΣym-98
05v #$4
20
0Bo 10
05v [$debug/print-stack]
09o 1599
10s ΓεnΣym-98
05v #$5
20
0Bo 41
23s $push/lval
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 1549
10s ΓεnΣym-98
05v #$6
20
0Bo 46
23s $make-list
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 1494
10s ΓεnΣym-98
05v #$7
20
0Bo 10
05v [$eval]
09o 1475
10s ΓεnΣym-98
05v #$8
20
0Bo 71
23s $apply
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 1395
10s ΓεnΣym-98
05v #$9
20
0Bo 41
23s $jmp*
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 1345
10s ΓεnΣym-98
05v #$A
20
0Bo 41
23s $jt*
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 1295
10s ΓεnΣym-98
05v #$B
20
0Bo 41
23s $jf*
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 1245
10s ΓεnΣym-98
05v #$C
20
0Bo 10
05v [$dup]
09o 1226
10s ΓεnΣym-98
05v #$D
20
0Bo 10
05v [$drop]
09o 1207
10s ΓεnΣym-98
05v #$E
20
0Bo 41
23s $def
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 1157
10s ΓεnΣym-98
05v #$F
20
0Bo 41
23s $set
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 1107
10s ΓεnΣym-98
05v #$10
20
0Bo 41
23s $get
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 1057
10s ΓεnΣym-98
05v #$11
20
0Bo 116
23s $lambda
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 932
10s ΓεnΣym-98
05v #$12
20
0Bo 116
23s $macro
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 807
10s ΓεnΣym-98
05v #$13
20
0Bo 10
05v [$closure/push]
09o 788
10s ΓεnΣym-98
05v #$14
20
0Bo 10
05v [$closure/enter]
09o 769
10s ΓεnΣym-98
05v #$15
20
0Bo 10
05v [$let]
09o 750
10s ΓεnΣym-98
05v #$16
20
0Bo 10
05v [$closure/pop]
09o 731
10s ΓεnΣym-98
05v #$17
20
0Bo 41
23s $call
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 681
10s ΓεnΣym-98
05v #$18
20
0Bo 41
23s $try
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 631
10s ΓεnΣym-98
05v #$19
20
0Bo 10
05v [$throw]
09o 612
10s ΓεnΣym-98
05v #$1A
20
0Bo 46
23s $apply/dynamic
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 557
10s ΓεnΣym-98
05v #$1B
20
0Bo 16
23s $roots/push
24
08i 2 v cons
09o 532
10s ΓεnΣym-98
05v #$1C
20
0Bo 16
23s $roots/pop
24
08i 2 v cons
09o 507
10s ΓεnΣym-98
05v #$1D
20
0Bo 16
23s $roots/peek
24
08i 2 v cons
09o 482
10s ΓεnΣym-98
05v #$1E
20
0Bo 16
23s $<
24
08i 2 v cons
09o 457
10s ΓεnΣym-98
05v #$1F
20
0Bo 16
23s $<=
24
08i 2 v cons
09o 432
10s ΓεnΣym-98
05v #$20
20
0Bo 16
23s $==
24
08i 2 v cons
09o 407
10s ΓεnΣym-98
05v #$21
20
0Bo 16
23s $>=
24
08i 2 v cons
09o 382
10s ΓεnΣym-98
05v #$22
20
0Bo 16
23s $>
24
08i 2 v cons
09o 357
10s ΓεnΣym-98
05v #$23
20
0Bo 41
23s $push/symbol
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 307
10s ΓεnΣym-98
05v #$24
20
0Bo 16
23s $push/nil
24
08i 2 v cons
09o 282
10s ΓεnΣym-98
05v #$25
20
0Bo 116
23s $fn
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 157
10s ΓεnΣym-98
05v #$26
20
0Bo 116
23s $macro*
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 32
10s ΓεnΣym-98
05v #$27
20
0Bo 16
23s $swap
24
08i 2 v cons
09o 7
05v :unknown-op
16
01
}]] [def disassemble/array [fn* 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/bytecode-array [fn* disassemble/bytecode-array [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/print [fn* disassemble/print [bc] "" #{
15
10s bc
08i 1 v disassemble/bytecode-array
0Es ΓεnΣym-99
0D
10s ΓεnΣym-99
0Bo 98
02i 0
1B
1C
10s ΓεnΣym-99
0Bo 84
0D
10s ΓεnΣym-99
08i 1 v car
0Es a
0D
10s a
08i 1 v car
08i 1 v string
02i 6
08i 2 v string/pad-start
08i 1 v ansi-blue
05v " - "
10s a
08i 1 v cdr
08i 3 v cat
08i 1 v println
0D
10s ΓεnΣym-99
08i 1 v cdr
0Fs ΓεnΣym-99
09o -86
09o 4
24
16
01
}]] [def disassemble [fn* disassemble [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," #{
15
10s bc
08i 1 v type-of
0Es ΓεnΣym-100
0D
10s ΓεnΣym-100
05v :lambda
20
0C
0Ao 22
0D
10s ΓεnΣym-100
05v :macro
20
0C
0Ao 8
0D
05v #f
0Bo 29
10s bc
08i 1 v closure
05v :code
08i 2 v ref
08i 1 v disassemble/print
09o 54
10s ΓεnΣym-100
05v :bytecode-array
20
0Bo 15
10s bc
08i 1 v disassemble/print
09o 30
05v :type-error
05v "Can't disassemble that"
10s bc
08i 0 v current-lambda
08i 4 v list
08i 1 v throw
16
01
}]] [def disassemble/test [fn* 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
15
10s asm
0Es ΓεnΣym-101
0D
10s ΓεnΣym-101
0Bo 94
02i 0
1B
1C
10s ΓεnΣym-101
0Bo 80
0D
10s ΓεnΣym-101
08i 1 v car
0Es a
0D
02i 1
10s cur-line
08i 2 v +
0Fs cur-line
02i 6
08i 2 v string/pad-start
08i 1 v ansi-yellow
05v " - "
10s a
08i 3 v cat
08i 1 v println
0D
10s ΓεnΣym-101
08i 1 v cdr
0Fs ΓεnΣym-101
09o -82
09o 4
24
16
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
0D
05v "--------- Fin -----------\n"
08i 1 v ansi-red
08i 1 v println
0D
10s display/error
18o 25
10s bc
08i 1 v bytecode-eval
08i 1 v str/write
08i 1 v println
09o 8
1Ai 1
09o 5
27
0D
01
}]]][do [def yield-queue #nil] [def yield [fn* yield [pred fun] "Evaluates FUN once PRED is true" #{
10s pred
10s fun
08i 2 v cons
10s yield-queue
08i 2 v cons
0Fs yield-queue
0D
05v #t
01
}]] [def yield-run [fn* yield-run [] "Executes pending coroutines if their predicate evaluates to #t" #{
24
0Es new
0D
15
10s yield-queue
0Es ΓεnΣym-104
0D
10s ΓεnΣym-104
0Bo 94
02i 0
1B
1C
10s ΓεnΣym-104
0Bo 80
0D
10s ΓεnΣym-104
08i 1 v car
0Es cur
0D
10s cur
08i 1 v car
1Ai 0
0Bo 17
10s cur
08i 1 v cdr
1Ai 0
09o 20
10s cur
10s new
08i 2 v cons
0Fs new
0D
10s ΓεnΣym-104
08i 1 v cdr
0Fs ΓεnΣym-104
09o -82
09o 4
24
16
0D
10s new
0Fs yield-queue
01
}]] [def timeout [fn* timeout [milliseconds] "Returns a function that evaluates to true once MILLISECONDS have passed" #{
08i 0 v time/milliseconds
10s milliseconds
08i 2 v +
0Es goal
0D
25v anonymous v [] v "" v #{
08i 0 v time/milliseconds
10s goal
22
01
}
01
}]] [def event-bind [fn* event-bind [event id handler] "Bind handler to be evaluated when event-name fires, overwriting whichever handler has been associated with id before." #{
10s event
10s id
10s handler
08i 3 v tree/set!
01
}]] [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 [fn* event-fire [event . val] "Applies ...val to all event handlers associated with event-name" #{
15
10s event
08i 1 v tree/values
0Es ΓεnΣym-105
0D
10s ΓεnΣym-105
0Bo 59
02i 0
1B
1C
10s ΓεnΣym-105
0Bo 45
0D
10s ΓεnΣym-105
08i 1 v car
0Es h
0D
10s h
10s val
1Ai 1
0D
10s ΓεnΣym-105
08i 1 v cdr
0Fs ΓεnΣym-105
09o -47
09o 4
24
16
01
}]]][do [def let/arg [fn* 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
23s def
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 [fn* 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 [macro* comment body "Does nothing" #{
24
01
}]] [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 [fn* not [v] "Return true if V is false" #{
10s v
0Bo 10
05v #f
09o 7
05v #t
01
}]] [def identity [fn* identity [α] "Returns its argument" #{
10s α
01
}]] [def list [fn* list arguments "Return ARGUMENTS as a list" #{
10s arguments
01
}]] [def default [fn* 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 [fn* caar [p] "[car [car p]]" #{
10s p
08i 1 v car
08i 1 v car
01
}]] [def cadr [fn* cadr [p] "[car [cdr p]]" #{
10s p
08i 1 v cdr
08i 1 v car
01
}]] [def cdar [fn* cdar [p] "[cdr [car p]]" #{
10s p
08i 1 v car
08i 1 v cdr
01
}]] [def cddr [fn* cddr [p] "[cdr [cdr p]]" #{
10s p
08i 1 v cdr
08i 1 v cdr
01
}]] [def cadar [fn* cadar [p] "[cdr [car p]]" #{
10s p
08i 1 v car
08i 1 v cdr
08i 1 v car
01
}]] [def caddr [fn* caddr [p] "[car [cdr [cdr p]]]" #{
10s p
08i 1 v cdr
08i 1 v cdr
08i 1 v car
01
}]] [def cdddr [fn* cdddr [p] "[cdr [cdr [cdr p]]]" #{
10s p
08i 1 v cdr
08i 1 v cdr
08i 1 v cdr
01
}]] [def cadddr [fn* 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 [fn* 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 [fn* 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 [fn* 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 [macro* if-not [pred then else] "" #{
23s if
10s pred
10s else
10s then
24
08i 2 v cons
08i 2 v cons
08i 2 v cons
08i 2 v cons
01
}]] [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 [fn* case/clauses/multiple [key-sym cases] "" #{
10s cases
0Bo 51
23s ==
10s key-sym
10s cases
08i 1 v car
08i 3 v list
10s key-sym
10s cases
08i 1 v cdr
08i 2 v case/clauses/multiple
08i 2 v cons
09o 4
24
01
}]] [def case/clauses [fn* case/clauses [key-sym clauses] "" #{
10s clauses
0Bo 253
10s clauses
08i 1 v caar
23s otherwise
20
0Bo 24
23s do
10s clauses
08i 1 v cdar
08i 2 v cons
09o 212
23s if
10s clauses
08i 1 v caar
08i 1 v pair?
0Bo 128
10s clauses
08i 1 v caar
08i 1 v car
23s quote
20
0C
0Bo 47
0D
10s clauses
08i 1 v caar
08i 1 v cdr
08i 1 v last?
0C
0Bo 23
0D
10s clauses
08i 1 v caar
08i 1 v cadr
08i 1 v symbol?
0Bo 28
23s ==
10s key-sym
10s clauses
08i 1 v caar
08i 3 v list
09o 30
23s or
10s key-sym
10s clauses
08i 1 v caar
08i 2 v case/clauses/multiple
08i 2 v cons
09o 25
23s ==
10s key-sym
10s clauses
08i 1 v caar
08i 3 v list
23s do
10s clauses
08i 1 v cdar
08i 2 v cons
10s key-sym
10s clauses
08i 1 v cdr
08i 2 v case/clauses
08i 4 v list
09o 4
24
01
}]] [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/-> [fn* thread/-> [init fun] "" #{
10s fun
0Bo 110
10s fun
08i 1 v car
08i 1 v pair?
0Bo 58
10s fun
08i 1 v caar
10s init
10s fun
08i 1 v cdr
08i 2 v thread/->
10s fun
08i 1 v cdar
24
08i 2 v append
08i 2 v cons
08i 2 v cons
09o 35
10s fun
08i 1 v car
10s init
10s fun
08i 1 v cdr
08i 2 v thread/->
08i 2 v list
09o 7
10s init
01
}]] [def -> [μ* -> [init . fun] "Thread init as the first argument through every function in fun" [thread/-> init [reverse fun]]]] [def thread/->> [fn* thread/->> [init fun] "" #{
10s fun
0Bo 44
10s fun
08i 1 v car
10s init
10s fun
08i 1 v cdr
08i 2 v thread/->>
24
08i 2 v cons
08i 2 v append
09o 7
10s init
01
}]] [def ->> [μ* ->> [init . fun] "Thread init as the last argument through every function in fun" [thread/->> init [reverse fun]]]] [def returnable/λ [fn* returnable/λ [e] "" #{
10s e
08i 1 v car
05v :return
20
0Bo 15
10s e
08i 1 v cdr
09o 12
10s e
08i 1 v throw
01
}]] [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? [fn* 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? [fn* 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? [fn* 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? [fn* 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? [fn* 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? [fn* 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? [fn* 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? [fn* zero? [val] "#t if VAL is zero" #{
02i 0
10s val
20
01
}]] [def not-zero? [fn* not-zero? [val] "#t if VAL is not zero" #{
02i 0
10s val
08i 2 v !=
01
}]] [def equal? [fn* 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-107
0D
10s ΓεnΣym-107
05v :array
20
0Bo 19
10s a
10s b
08i 2 v array/equal?
09o 68
10s ΓεnΣym-107
05v :tree
20
0Bo 19
10s a
10s b
08i 2 v tree/equal?
09o 40
10s ΓεnΣym-107
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? [fn* inequal? [a b] "High level inequality comparator" #{
10s a
10s b
08i 2 v equal?
08i 1 v not
01
}]] [def int? [fn* int? [val] "#t if VAL is a integer" #{
05v :int
10s val
08i 1 v type-of
20
01
}]] [def float? [fn* float? [val] "#t if VAL is a floating-point number" #{
05v :float
10s val
08i 1 v type-of
20
01
}]] [def vec? [fn* vec? [val] "#t if VAL is a vector" #{
05v :vec
10s val
08i 1 v type-of
20
01
}]] [def bool? [fn* bool? [val] "#t if VAL is a boolean" #{
05v :bool
10s val
08i 1 v type-of
20
01
}]] [def pair? [fn* pair? [val] "#t if VAL is a pair" #{
05v :pair
10s val
08i 1 v type-of
20
01
}]] [def array? [fn* array? [val] "#t if VAL is an array" #{
05v :array
10s val
08i 1 v type-of
20
01
}]] [def string? [fn* string? [val] "#t if VAL is a string" #{
05v :string
10s val
08i 1 v type-of
20
01
}]] [def symbol? [fn* symbol? [val] "#t if VAL is a symbol" #{
05v :symbol
10s val
08i 1 v type-of
20
01
}]] [def object? [fn* object? [val] "#t if VAL is an object" #{
05v :object
10s val
08i 1 v type-of
20
01
}]] [def tree? [fn* tree? [val] "#t if VAL is an object" #{
05v :tree
10s val
08i 1 v type-of
20
01
}]] [def macro? [fn* macro? [val] "#t if VAL is an object" #{
05v :macro
10s val
08i 1 v type-of
20
01
}]] [def lambda? [fn* 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? [fn* native? [val] "#t if VAL is a native function" #{
05v :native-function
10s val
08i 1 v type-of
20
01
}]] [def special-form? [fn* special-form? [val] "#t if VAL is a native function" #{
05v :special-form
10s val
08i 1 v type-of
20
01
}]] [def procedure? [fn* 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? [fn* bytecode-array? [v] "" #{
05v :bytecode-array
10s v
08i 1 v type-of
20
01
}]] [def bytecode-op? [fn* bytecode-op? [v] "" #{
05v :bytecode-op
10s v
08i 1 v type-of
20
01
}]] [def in-range? [fn* in-range? [v min max] "" #{
10s v
10s min
21
0C
0Bo 13
0D
10s v
10s max
1F
01
}]]][do [def quasiquote-real [fn* quasiquote-real [l depth] "" #{
10s l
08i 1 v nil?
0Bo 7
24
09o 412
10s l
08i 1 v pair?
0Bo 349
10s l
08i 1 v caar
23s unquote-splicing
20
0Bo 96
10s depth
08i 1 v zero?
0Bo 47
23s append
10s l
08i 1 v car
08i 1 v cadr
10s l
08i 1 v cdr
10s depth
08i 2 v quasiquote-real
08i 3 v list
09o 37
23s unquote-splicing
10s l
08i 1 v cadr
02i -1
10s depth
08i 2 v +
08i 2 v quasiquote-real
08i 2 v list
09o 236
10s l
08i 1 v car
23s unquote
20
0Bo 64
10s depth
08i 1 v zero?
0Bo 15
10s l
08i 1 v cadr
09o 37
23s unquote
10s l
08i 1 v cadr
02i -1
10s depth
08i 2 v +
08i 2 v quasiquote-real
08i 2 v list
09o 158
10s l
08i 1 v car
23s quasiquote
20
0Bo 40
10s l
08i 1 v cadr
02i 1
10s depth
08i 2 v +
08i 2 v quasiquote-real
10s depth
08i 2 v quasiquote-real
09o 104
10s depth
08i 1 v zero?
0Bo 51
23s cons
10s l
08i 1 v car
10s depth
08i 2 v quasiquote-real
10s l
08i 1 v cdr
10s depth
08i 2 v quasiquote-real
08i 3 v list
09o 44
10s l
08i 1 v car
10s depth
08i 2 v quasiquote-real
10s l
08i 1 v cdr
10s depth
08i 2 v quasiquote-real
08i 2 v cons
09o 54
10s depth
08i 1 v zero?
0C
0Bo 13
0D
10s l
08i 1 v symbol?
0Bo 24
23s quote
10s l
08i 1 v cons
08i 2 v cons
09o 7
10s l
01
}]] [def quasiquote [μ* quasiquote [l] "" [quasiquote-real l 0]]] [def unquote [fn* unquote [expr] "" #{
05v :unquote-without-quasiquote
05v "unquote should only occur inside a quasiquote, never evaluated directly"
08i 2 v list
08i 1 v throw
01
}]] [def unquote-splicing [fn* unquote-splicing [expr] "" #{
05v :unquote-splicing-without-quasiq
05v "unquote-splicing should only occur inside a quasiquote, never evaluated directly"
08i 2 v list
08i 1 v throw
01
}]]][do [def describe/closure [fn* describe/closure [c i] "" #{
10s c
0Bo 174
10s c
08i 1 v closure
0Es info
0D
10s info
0C
0Bo 17
0D
10s info
05v :call
08i 2 v ref
0Bo 131
10s i
0C
0Ao 15
0D
02i 0
0C
0Ao 8
0D
05v #f
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
0C
0Ao 15
0D
02i 0
0C
0Ao 8
0D
05v #f
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 [fn* stacktrace [] "" #{
08i 0 v current-lambda
08i 1 v closure-caller
08i 1 v describe/closure
08i 1 v display
01
}]]][do [def time/seconds [fn* 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 [fn* 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 [fn* 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 [fn* 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 [fn* 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-109
0D
02i 0
1B
1C
10s i
10s ΓεnΣym-109
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 ++ [macro* ++ [i] "Increment I by 1 and store the result in I" #{
23s set!
10s i
23s +
02i 1
10s i
24
08i 2 v cons
08i 2 v cons
08i 2 v cons
24
08i 2 v cons
08i 2 v cons
08i 2 v cons
01
}]] [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 [fn* +x [α] "Return a function that adds α to it's argument, useful for mapping" #{
25v anonymous v [β] v "" v #{
10s α
10s β
08i 2 v +
01
}
01
}]] [def >> [fn* >> [val amount] "Shifts VAL by AMOUNT bits to the right" #{
10s val
10s amount
08i 1 v -
08i 2 v ash
01
}]] [def fib [fn* 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 [fn* 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 [fn* 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 [fn* display/error/wrap [i text] "" #{
15
10s i
0Es ΓεnΣym-111
0D
10s ΓεnΣym-111
02i 0
20
0Bo 15
10s text
08i 1 v ansi-red
09o 78
10s ΓεnΣym-111
02i 1
20
0Bo 15
10s text
08i 1 v string
09o 56
10s ΓεnΣym-111
02i 2
20
0Bo 20
10s text
08i 1 v str/write
08i 1 v ansi-yellow
09o 29
10s ΓεnΣym-111
02i 3
20
0Bo 15
10s text
08i 1 v describe/closure
09o 7
10s text
16
01
}]] [def display/error/iter [fn* 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 [fn* 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 [fn* 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 [fn* 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 [fn* 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 [fn* 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 [fn* symbol-table [off len environment] "Return a list of LEN symbols defined in ENVIRONMENT starting at OFF" #{
10s environment
0Bo 7
24
09o 11
10s root-closure
0Fs environment
0D
10s off
0Bo 7
24
09o 9
02i 0
0Fs off
0D
10s len
0Bo 7
24
09o 11
05v 9999999
0Fs len
0D
10s environment
05v [[symbol-table*]]
08i 2 v apply
10s off
10s off
10s len
08i 2 v +
24
08i 4 v sublist
01
}]] [def gensym/counter 0] [def gensym [fn* 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! [fn* random/seed-initialize! [] "" #{
08i 0 v time
08i 0 v time/milliseconds
08i 2 v logxor
0Fs random/seed
01
}]] [def random/rng! [fn* 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! [fn* random/seed! [new-seed] "Set a new seed value for the RNG" #{
10s new-seed
0Fs seed
01
}]] [def random/seed [fn* random/seed [] "Return the current RNG seed value" #{
10s seed
01
}]] [def random [fn* 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 [fn* tree->json [v] "Converts a tree into a JSON encoded string, you should prefer VAL->JSON" #{
05v "{"
10s v
08i 1 v tree/keys
25v anonymous v [k] v "" v #{
05v "\""
10s k
08i 1 v keyword->string
05v "\": "
10s v
10s k
08i 2 v tree/ref
08i 1 v val->json
08i 4 v cat
01
}
08i 2 v map
05v ",\n"
08i 2 v join
05v "}"
08i 3 v cat
01
}]] [def val->json [fn* val->json [v] "Return V as a JSON encoded string" #{
15
10s v
08i 1 v type-of
0Es ΓεnΣym-113
0D
10s ΓεnΣym-113
05v :nil
20
0Bo 10
05v "null"
09o 305
10s ΓεnΣym-113
05v :int
20
0C
0Ao 22
0D
10s ΓεnΣym-113
05v :float
20
0C
0Ao 8
0D
05v #f
0Bo 15
10s v
08i 1 v string
09o 258
10s ΓεnΣym-113
05v :bool
20
0Bo 24
10s v
0Bo 10
05v "true"
09o 7
05v "false"
09o 225
10s ΓεnΣym-113
05v :array
20
0C
0Ao 22
0D
10s ΓεnΣym-113
05v :pair
20
0C
0Ao 8
0D
05v #f
0Bo 41
05v "["
10s v
10s val->json
08i 2 v map
05v ","
08i 2 v join
05v "]"
08i 3 v cat
09o 152
10s ΓεnΣym-113
05v :string
20
0Bo 15
10s v
08i 1 v str/write
09o 128
10s ΓεnΣym-113
05v :symbol
20
0Bo 28
05v "\""
10s v
08i 1 v sym->str
05v "\""
08i 3 v cat
09o 91
10s ΓεnΣym-113
05v :keyword
20
0Bo 28
05v "\""
10s v
08i 1 v keyword->string
05v "\""
08i 3 v cat
09o 54
10s ΓεnΣym-113
05v :tree
20
0Bo 15
10s v
08i 1 v tree->json
09o 30
05v :type-error
05v "Can't encode the value into JSON"
10s v
08i 0 v current-lambda
08i 4 v list
08i 1 v throw
16
01
}]]][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 [fn* 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 [fn* 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 [fn* 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 [fn* 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 [fn* 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 [fn* 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 [fn* 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 [fn* 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 [fn* 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 [fn* 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 [fn* 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 [fn* 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 [fn* 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 [fn* 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 [fn* 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 [fn* 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 [fn* 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 [fn* 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
25v anonymous v [a] v "" v #{
02i 1
10s count
08i 2 v +
02i 7
08i 2 v logand
0Fs count
0D
10s ansi/disabled
0C
0Ao 50
0D
10s ansi-fg
10s count
08i 1 v zero?
0Bo 8
02i 7
09o 14
10s count
02i 8
08i 2 v +
08i 2 v array/ref
0C
0Ao 8
0D
05v #f
10s a
08i 2 v cat
01
}
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 [fn* 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
25v anonymous v [a] v "" v #{
02i 1
10s count
08i 2 v +
02i 7
08i 2 v logand
0Fs count
0D
10s ansi/disabled
0C
0Ao 33
0D
10s ansi-fg
10s count
02i 7
08i 2 v logxor
08i 2 v array/ref
0C
0Ao 8
0D
05v #f
10s ansi/disabled
0C
0Ao 26
0D
10s ansi-bg
10s count
08i 2 v array/ref
0C
0Ao 8
0D
05v #f
10s a
08i 3 v cat
01
}
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 [fn* 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-115
0D
02i 0
1B
1C
10s i
10s ΓεnΣym-115
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 [fn* 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 [fn* fmt/parse-spec [opts spec] "" #{
10s spec
08i 1 v string/length
08i 1 v zero?
0Bo 10
10s opts
09o 978
15
10s spec
10s spec
08i 1 v string/length
02i 1
08i 2 v -
08i 2 v char-at
0Es ΓεnΣym-123
0D
10s ΓεnΣym-123
02i 48
20
0C
0Ao 116
0D
10s ΓεnΣym-123
02i 49
20
0C
0Ao 104
0D
10s ΓεnΣym-123
02i 50
20
0C
0Ao 92
0D
10s ΓεnΣym-123
02i 51
20
0C
0Ao 80
0D
10s ΓεnΣym-123
02i 52
20
0C
0Ao 68
0D
10s ΓεnΣym-123
02i 53
20
0C
0Ao 56
0D
10s ΓεnΣym-123
02i 54
20
0C
0Ao 44
0D
10s ΓεnΣym-123
02i 55
20
0C
0Ao 32
0D
10s ΓεnΣym-123
02i 56
20
0C
0Ao 20
0D
10s ΓεnΣym-123
02i 57
20
0C
0Ao 8
0D
05v #f
0Bo 163
10s spec
10s spec
08i 1 v string/length
02i 1
08i 2 v -
08i 2 v fmt/find-non-digit-from-right
0Es next-non-digit
0D
10s spec
02i 1
10s next-non-digit
08i 2 v +
10s spec
08i 1 v string/length
08i 3 v string/cut
0Es number
0D
10s opts
05v :width
10s number
08i 1 v read/single
08i 3 v tree/set!
0D
02i 48
10s number
02i 0
08i 2 v char-at
20
0Bo 23
10s opts
05v :padding-char
05v "0"
08i 3 v tree/set!
09o 4
24
0D
10s opts
10s spec
02i 0
02i 1
10s next-non-digit
08i 2 v +
08i 3 v string/cut
08i 2 v fmt/parse-spec
09o 659
10s ΓεnΣym-123
02i 63
20
0Bo 55
10s opts
05v :debug
05v #t
08i 3 v tree/set!
10s spec
02i 0
10s spec
08i 1 v string/length
02i 1
08i 2 v -
08i 3 v string/cut
08i 2 v fmt/parse-spec
09o 597
10s ΓεnΣym-123
02i 88
20
0Bo 55
10s opts
05v :base
05v :HEXADECIMAL
08i 3 v tree/set!
10s spec
02i 0
10s spec
08i 1 v string/length
02i 1
08i 2 v -
08i 3 v string/cut
08i 2 v fmt/parse-spec
09o 535
10s ΓεnΣym-123
02i 120
20
0Bo 55
10s opts
05v :base
05v :hexadecimal
08i 3 v tree/set!
10s spec
02i 0
10s spec
08i 1 v string/length
02i 1
08i 2 v -
08i 3 v string/cut
08i 2 v fmt/parse-spec
09o 473
10s ΓεnΣym-123
02i 100
20
0Bo 55
10s opts
05v :base
05v :decimal
08i 3 v tree/set!
10s spec
02i 0
10s spec
08i 1 v string/length
02i 1
08i 2 v -
08i 3 v string/cut
08i 2 v fmt/parse-spec
09o 411
10s ΓεnΣym-123
02i 111
20
0Bo 55
10s opts
05v :base
05v :octal
08i 3 v tree/set!
10s spec
02i 0
10s spec
08i 1 v string/length
02i 1
08i 2 v -
08i 3 v string/cut
08i 2 v fmt/parse-spec
09o 349
10s ΓεnΣym-123
02i 98
20
0Bo 55
10s opts
05v :base
05v :binary
08i 3 v tree/set!
10s spec
02i 0
10s spec
08i 1 v string/length
02i 1
08i 2 v -
08i 3 v string/cut
08i 2 v fmt/parse-spec
09o 287
10s ΓεnΣym-123
02i 60
20
0Bo 55
10s opts
05v :align
05v :left
08i 3 v tree/set!
10s spec
02i 0
10s spec
08i 1 v string/length
02i 1
08i 2 v -
08i 3 v string/cut
08i 2 v fmt/parse-spec
09o 225
10s ΓεnΣym-123
02i 94
20
0Bo 55
10s opts
05v :align
05v :center
08i 3 v tree/set!
10s spec
02i 0
10s spec
08i 1 v string/length
02i 1
08i 2 v -
08i 3 v string/cut
08i 2 v fmt/parse-spec
09o 163
10s ΓεnΣym-123
02i 62
20
0Bo 55
10s opts
05v :align
05v :right
08i 3 v tree/set!
10s spec
02i 0
10s spec
08i 1 v string/length
02i 1
08i 2 v -
08i 3 v string/cut
08i 2 v fmt/parse-spec
09o 101
10s ΓεnΣym-123
02i 46
20
0Bo 64
10s opts
05v :precision
10s opts
05v :width
08i 2 v tree/ref
08i 3 v tree/set!
10s spec
02i 0
10s spec
08i 1 v string/length
02i 1
08i 2 v -
08i 3 v string/cut
08i 2 v fmt/parse-spec
09o 30
05v :format-error
05v "Unknown form-spec option"
10s spec
08i 0 v current-closure
08i 4 v list
08i 1 v throw
16
01
}]] [def fmt/debug [fn* 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 [fn* fmt/number-format [opts] "" #{
15
10s opts
05v :base
08i 2 v tree/ref
0Es ΓεnΣym-124
0D
10s ΓεnΣym-124
05v :binary
20
0Bo 41
10s opts
05v :argument
10s int->string/binary
10s opts
05v :argument
08i 2 v tree/ref
08i 2 v list
08i 3 v tree/set!
09o 207
10s ΓεnΣym-124
05v :octal
20
0Bo 41
10s opts
05v :argument
10s int->string/octal
10s opts
05v :argument
08i 2 v tree/ref
08i 2 v list
08i 3 v tree/set!
09o 157
10s ΓεnΣym-124
05v :decimal
20
0Bo 41
10s opts
05v :argument
10s int->string/decimal
10s opts
05v :argument
08i 2 v tree/ref
08i 2 v list
08i 3 v tree/set!
09o 107
10s ΓεnΣym-124
05v :hexadecimal
20
0Bo 41
10s opts
05v :argument
10s int->string/hex
10s opts
05v :argument
08i 2 v tree/ref
08i 2 v list
08i 3 v tree/set!
09o 57
10s ΓεnΣym-124
05v :HEXADECIMAL
20
0Bo 41
10s opts
05v :argument
10s int->string/HEX
10s opts
05v :argument
08i 2 v tree/ref
08i 2 v list
08i 3 v tree/set!
09o 7
10s opts
16
01
}]] [def fmt/number-format-prefixex [tree/new :binary "#b" :octal "#o" :decimal "#d" :hexadecimal "#x" :HEXADECIMAL "#x"]] [def fmt/number-format-prefix [fn* 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 [fn* 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-125
0D
10s ΓεnΣym-125
05v :right
20
0Bo 10
10s string/pad-start
09o 42
10s ΓεnΣym-125
05v :center
20
0Bo 10
10s string/pad-middle
09o 23
10s ΓεnΣym-125
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 [fn* 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 [fn* 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 [fn* fmt/output [opts] "" #{
10s opts
05v :argument
08i 2 v tree/ref
01
}]] [def fmt/format-arg [fn* 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? [fn* 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 [fn* 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 [fn* 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
23s def
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-126 [string/length format-string]] [while [< i ΓεnΣym-126] [do [let* [do [def ΓεnΣym-127 [char-at format-string i]] [if [== ΓεnΣym-127 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-127 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-128 cuts] [if ΓεnΣym-128 [while ΓεnΣym-128 [do [def c [car ΓεnΣym-128]] [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-128 [cdr ΓεnΣym-128]]]] #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-129 [array/length arguments-used]] [while [< i ΓεnΣym-129] [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 [fn* string->keyword [α] "Return string α as a keyword" #{
10s α
08i 1 v str->sym
08i 1 v symbol->keyword
01
}]] [def string->byte-array [fn* 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-133
0D
02i 0
1B
1C
10s i
10s ΓεnΣym-133
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 [fn* println [str] "Print STR on a single line" #{
10s str
05v "\r\n"
08i 2 v cat
08i 1 v print
01
}]] [def errorln [fn* 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 [fn* display [value] "Display VALUE" #{
10s value
08i 1 v print
01
}]] [def newline [fn* newline [] "Print a single line feed character" #{
05v "\r\n"
08i 1 v display
01
}]] [def br [fn* 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?! [fn* 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-134
0D
10s ΓεnΣym-134
05v :string
20
0Bo 19
25v anonymous v [path] v "" v #{
10s ext
10s path
08i 1 v path/extension
08i 1 v lowercase
20
01
}
09o 53
10s ΓεnΣym-134
05v :pair
20
0Bo 19
25v anonymous v [path] v "" v #{
10s path
08i 1 v path/extension
08i 1 v lowercase
0Es cext
0D
10s ext
25v anonymous v [α β] v "" v #{
10s α
0C
0Ao 22
0D
10s β
10s cext
20
0C
0Ao 8
0D
05v #f
01
}
08i 2 v reduce
01
}
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 [fn* 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 [fn* 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 [fn* 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 [fn* 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/conversion-arr [array/new "0" "1" "2" "3" "4" "5" "6" "7" "8" "9" "A" "B" "C" "D" "E" "F"]] [def int->string/HEX [fn* int->string/HEX [α] "Turn α into a its **hexadecimal** 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
10s α
02i 0
1E
0Bo 33
05v :type-error
05v "Can't print negative numbers in hex for now"
10s α
08i 0 v current-lambda
08i 4 v list
08i 1 v throw
09o 4
24
0D
02i 0
1B
1C
10s α
08i 1 v not-zero?
0Bo 56
0D
10s int->string/hex/conversion-arr
10s α
02i 15
08i 2 v logand
08i 2 v array/ref
10s ret
08i 2 v cat
0Fs ret
0D
10s α
02i -4
08i 2 v ash
0Fs α
09o -63
0D
10s ret
01
}]] [def int->string/hex [fn* int->string/hex [α] "Turn α into a its **hexadecimal** string representation" #{
10s α
08i 1 v int->string/HEX
08i 1 v lowercase
01
}]] [def int->string/decimal [fn* int->string/decimal [α] "Turn α into a its **decimal** string representation" #{
10s α
08i 1 v string
01
}]] [def int->string int->string/decimal] [def string/pad-start [fn* 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" #{
10s char
0Bo 7
24
09o 11
05v " "
0Fs char
0D
10s text
08i 1 v string?
0Bo 7
24
09o 16
10s text
08i 1 v string
0Fs text
0D
10s char
08i 1 v string?
0Bo 7
24
09o 30
05v :type-error
05v "string/pad-start needs char as a string, so that one can pad with multiple characters"
10s char
08i 0 v current-lambda
08i 4 v list
08i 1 v throw
0D
02i 0
1B
1C
10s text
08i 1 v string/length
10s goal-length
1E
0Bo 24
0D
10s char
10s text
08i 2 v cat
0Fs text
09o -36
0D
10s text
08i 1 v string/length
10s goal-length
22
0Bo 42
10s text
10s text
08i 1 v string/length
10s goal-length
08i 2 v -
10s text
08i 1 v string/length
08i 3 v string/cut
09o 7
10s text
01
}]] [def string/pad-end [fn* 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" #{
10s char
0Bo 7
24
09o 11
05v " "
0Fs char
0D
10s text
08i 1 v string?
0Bo 7
24
09o 16
10s text
08i 1 v string
0Fs text
0D
10s char
08i 1 v string?
0Bo 7
24
09o 30
05v :type-error
05v "string/pad-start needs char as a string, so that one can pad with multiple characters"
10s char
08i 0 v current-lambda
08i 4 v list
08i 1 v throw
0D
02i 0
1B
1C
10s text
08i 1 v string/length
10s goal-length
1E
0Bo 24
0D
10s text
10s char
08i 2 v cat
0Fs text
09o -36
0D
10s text
08i 1 v string/length
10s goal-length
22
0Bo 21
10s text
02i 0
10s goal-length
08i 3 v string/cut
09o 7
10s text
01
}]] [def string/pad-middle [fn* 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" #{
10s char
0Bo 7
24
09o 11
05v " "
0Fs char
0D
10s text
08i 1 v string?
0Bo 7
24
09o 16
10s text
08i 1 v string
0Fs text
0D
10s char
08i 1 v string?
0Bo 7
24
09o 30
05v :type-error
05v "string/pad-middle needs char as a string, so that one can pad with multiple characters"
10s char
08i 0 v current-lambda
08i 4 v list
08i 1 v throw
0D
02i 0
1B
1C
10s text
08i 1 v string/length
10s goal-length
1E
0Bo 28
0D
10s char
10s text
10s char
08i 3 v cat
0Fs text
09o -40
0D
10s text
08i 1 v string/length
10s goal-length
22
0Bo 96
15
10s text
08i 1 v string/length
10s goal-length
08i 2 v -
02i 2
08i 2 v /
0Es end-overflow
0D
10s text
08i 1 v string/length
10s goal-length
08i 2 v -
10s end-overflow
08i 2 v -
0Es start-overflow
0D
10s text
10s start-overflow
10s start-overflow
10s goal-length
08i 2 v +
08i 3 v string/cut
16
09o 7
10s text
01
}]] [def string/round [fn* string/round [text decimal-digits] "Round the floating point representation in TEXT to have at most DECIMAL-DIGITS after the period" #{
10s text
05v "."
08i 2 v last-index-of
0Es pos
0D
10s pos
02i 0
21
0Bo 32
10s text
02i 0
10s pos
02i 1
10s decimal-digits
08i 3 v +
08i 3 v string/cut
09o 7
10s text
01
}]] [def split/empty [fn* 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 [fn* 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 [fn* split [str separator] "Splits STR into a list at every occurunse of SEPARATOR" #{
10s str
08i 1 v type-of
05v :string
20
0Bo 7
24
09o 30
05v :type-error
05v "Expected a value of type :string"
10s str
08i 0 v current-lambda
08i 4 v list
08i 1 v throw
0D
10s separator
08i 1 v type-of
05v :string
20
0Bo 7
24
09o 30
05v :type-error
05v "Expected a value of type :string"
10s separator
08i 0 v current-lambda
08i 4 v list
08i 1 v throw
0D
15
10s separator
08i 1 v string/length
0Es ΓεnΣym-135
0D
10s ΓεnΣym-135
02i 0
20
0Bo 15
10s str
08i 1 v split/empty
09o 18
10s str
10s separator
02i 0
08i 3 v split/string
16
01
}]] [def read/single [fn* read/single [text] "Uses the reader and returns the first single value read from string TEXT" #{
10s text
08i 1 v type-of
05v :string
20
0Bo 7
24
09o 30
05v :type-error
05v "Expected a value of type :string"
10s text
08i 0 v current-lambda
08i 4 v list
08i 1 v throw
0D
10s text
08i 1 v read
08i 1 v car
01
}]] [def read/int [fn* read/int [text] "Reads the first string from TEXT" #{
10s text
08i 1 v read/single
08i 1 v int
01
}]] [def read/float [fn* read/float [text] "Reads the first float from TEXT" #{
10s text
08i 1 v read/single
08i 1 v float
01
}]] [def string/length?! [fn* string/length?! [chars] "" #{
25v anonymous v [a] v "" v #{
10s chars
10s a
08i 1 v string/length
20
01
}
01
}]] [def contains-any? [fn* contains-any? [str chars] "" #{
10s or
10s chars
05v ""
08i 2 v split
25v anonymous v [a] v "" v #{
10s str
10s a
08i 2 v index-of
02i 0
21
01
}
08i 2 v map
08i 2 v apply
01
}]] [def contains-all? [fn* contains-all? [str chars] "" #{
10s and
10s chars
05v ""
08i 2 v split
25v anonymous v [a] v "" v #{
10s str
10s a
08i 2 v index-of
02i 0
21
01
}
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* [fn* 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 [fn* 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 [fn* 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 [fn* 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 [fn* test-bytecode [result rawexpr i] "Tests that RAWEXPR evaluates to RESULT when run through the bytecode interpreter" #{
25v anonymous v [err] v "" v #{
10s result
05v :exception-caught
10s err
08i 2 v list
10s rawexpr
10s i
08i 4 v test-failure
01
}
18o 96
10s rawexpr
08i 1 v compile
08i 1 v bytecompile
08i 1 v assemble*
08i 1 v bytecode-eval
0Es expr
0D
10s result
10s expr
08i 2 v equal?
0Bo 27
10s result
10s expr
10s rawexpr
10s i
08i 4 v test-success
09o 24
10s result
10s expr
10s rawexpr
10s i
08i 4 v test-failure
09o 8
1Ai 1
09o 5
27
0D
01
}]] [def test-default [fn* test-default [result rawexpr i] "Tests that RAWEXPR evaluates to RESULT" #{
25v anonymous v [err] v "" v #{
10s result
05v :exception-caught
10s err
08i 2 v list
10s rawexpr
10s i
08i 4 v test-failure
01
}
18o 91
10s rawexpr
08i 0 v current-closure
08i 2 v compile
08i 1 v eval*
0Es expr
0D
10s result
10s expr
08i 2 v equal?
0Bo 27
10s result
10s expr
10s rawexpr
10s i
08i 4 v test-success
09o 24
10s result
10s expr
10s rawexpr
10s i
08i 4 v test-failure
09o 8
1Ai 1
09o 5
27
0D
01
}]] [def test-forked [fn* test-forked [nujel-runtime] "" #{
25v anonymous v [result rawexpr i] v "Tests that RAWEXPR evaluates to RESULT in a separate runtime" v #{
10s nujel-runtime
10s rawexpr
08i 2 v eval/forked
0Es eval-result
0D
10s eval-result
08i 1 v cdr
0Es expr
0D
10s result
08i 1 v string?
0Bo 7
24
09o 21
10s expr
08i 1 v read
08i 1 v car
0Fs expr
0D
10s eval-result
08i 1 v car
08i 1 v zero?
0C
0Bo 17
0D
10s result
10s expr
08i 2 v equal?
0Bo 27
10s result
10s expr
10s rawexpr
10s i
08i 4 v test-success
09o 24
10s result
10s expr
10s rawexpr
10s i
08i 4 v test-failure
01
}
01
}]] [def test-run-real [fn* 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-137
0D
10s ΓεnΣym-137
0Bo 88
02i 0
1B
1C
10s ΓεnΣym-137
0Bo 74
0D
10s ΓεnΣym-137
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
1Ai 3
0D
10s ΓεnΣym-137
08i 1 v cdr
0Fs ΓεnΣym-137
09o -76
09o 4
24
16
0D
08i 0 v display-results
0D
10s error-count
01
}]] [def test-run [fn* 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 [fn* 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 [fn* 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]]]]