rubymotionlisp 0.2.2 → 1.0.0

Sign up to get free protection for your applications and to get access to all the features.
Files changed (60) hide show
  1. checksums.yaml +4 -4
  2. data/README.md +129 -2
  3. data/lib/rubylisp/atom.rb +25 -6
  4. data/lib/rubylisp/boolean.rb +9 -6
  5. data/lib/rubylisp/builtins.rb +33 -0
  6. data/lib/rubylisp/character.rb +14 -275
  7. data/lib/rubylisp/class_object.rb +56 -0
  8. data/lib/rubylisp/cons_cell.rb +50 -20
  9. data/lib/rubylisp/environment.rb +27 -0
  10. data/lib/rubylisp/environment_frame.rb +24 -6
  11. data/lib/rubylisp/eof_object.rb +26 -0
  12. data/lib/rubylisp/exception.rb +61 -61
  13. data/lib/rubylisp/ext.rb +32 -6
  14. data/lib/rubylisp/ffi_new.rb +2 -1
  15. data/lib/rubylisp/ffi_send.rb +15 -5
  16. data/lib/rubylisp/frame.rb +5 -164
  17. data/lib/rubylisp/function.rb +4 -3
  18. data/lib/rubylisp/macro.rb +13 -8
  19. data/lib/rubylisp/{object.rb → native_object.rb} +0 -15
  20. data/lib/rubylisp/number.rb +5 -0
  21. data/lib/rubylisp/parser.rb +81 -52
  22. data/lib/rubylisp/port.rb +27 -0
  23. data/lib/rubylisp/prim_alist.rb +115 -0
  24. data/lib/rubylisp/prim_assignment.rb +61 -0
  25. data/lib/rubylisp/prim_character.rb +273 -0
  26. data/lib/rubylisp/{ffi_class.rb → prim_class_object.rb} +16 -69
  27. data/lib/rubylisp/prim_environment.rb +203 -0
  28. data/lib/rubylisp/prim_equivalence.rb +93 -0
  29. data/lib/rubylisp/prim_frame.rb +166 -0
  30. data/lib/rubylisp/prim_io.rb +266 -0
  31. data/lib/rubylisp/prim_list_support.rb +496 -0
  32. data/lib/rubylisp/{logical.rb → prim_logical.rb} +9 -14
  33. data/lib/rubylisp/prim_math.rb +397 -0
  34. data/lib/rubylisp/prim_native_object.rb +21 -0
  35. data/lib/rubylisp/prim_relational.rb +42 -0
  36. data/lib/rubylisp/{special_forms.rb → prim_special_forms.rb} +97 -84
  37. data/lib/rubylisp/prim_string.rb +792 -0
  38. data/lib/rubylisp/prim_system.rb +55 -0
  39. data/lib/rubylisp/prim_type_checks.rb +58 -0
  40. data/lib/rubylisp/prim_vector.rb +497 -0
  41. data/lib/rubylisp/primitive.rb +51 -6
  42. data/lib/rubylisp/string.rb +4 -803
  43. data/lib/rubylisp/symbol.rb +0 -1
  44. data/lib/rubylisp/tokenizer.rb +160 -136
  45. data/lib/rubylisp/vector.rb +10 -31
  46. data/lib/rubymotion/debug.rb +40 -0
  47. data/lib/rubymotion/require-fix.rb +1 -0
  48. data/lib/rubymotionlisp.rb +4 -0
  49. metadata +28 -17
  50. data/lib/rubylisp/alist.rb +0 -230
  51. data/lib/rubylisp/assignment.rb +0 -65
  52. data/lib/rubylisp/equivalence.rb +0 -118
  53. data/lib/rubylisp/io.rb +0 -74
  54. data/lib/rubylisp/list_support.rb +0 -526
  55. data/lib/rubylisp/math.rb +0 -405
  56. data/lib/rubylisp/motion_builtins.rb +0 -31
  57. data/lib/rubylisp/relational.rb +0 -46
  58. data/lib/rubylisp/system.rb +0 -20
  59. data/lib/rubylisp/testing.rb +0 -136
  60. data/lib/rubylisp/type_checks.rb +0 -60
@@ -0,0 +1,55 @@
1
+ module Lisp
2
+
3
+ class PrimSystem
4
+
5
+ def self.register
6
+ Primitive.register("sleep", "1") {|args, env| Lisp::PrimSystem.sleep_impl(args, env) }
7
+ Primitive.register("time", "1", "", true) {|args, env| Lisp::PrimSystem.time_impl(args, env) }
8
+ Primitive.register("quit", "0") {|args, env| exit() }
9
+ Primitive.register("error", "1") {|args, env| Lisp::PrimSystem.error_impl(args, env) }
10
+ Primitive.register("on-error", "2|3", "", true) {|args, env| Lisp::PrimSystem.on_error_impl(args, env) }
11
+ end
12
+
13
+
14
+ def self.sleep_impl(args, env)
15
+ arg = args.car
16
+ return Lisp::Debug.process_error("sleep needs a numeric argument", env) unless arg.number?
17
+ sleep(arg.value)
18
+ end
19
+
20
+
21
+ def self.time_impl(args, env)
22
+ start_time = Time.now
23
+ args.car.evaluate(env)
24
+ end_time = Time.now
25
+ Lisp::Number.with_value(end_time - start_time)
26
+ end
27
+
28
+
29
+ def self.error_impl(args, env)
30
+ #puts "error #{args.car.print_string}"
31
+ Lisp::Debug.process_error(args.car.to_s, env)
32
+ end
33
+
34
+
35
+ def self.on_error_impl(args, env)
36
+ #puts "on-error ===> #{args.car.body.print_string}"
37
+ begin
38
+ result = args.car.evaluate(env)
39
+ rescue => e
40
+ handler = args.cadr.evaluate(env)
41
+ return Lisp::Debug.process_error("on-error needs a function as it's second argument", env) unless handler.function?
42
+ #puts "ERROR: #{e}"
43
+ err_string = Lisp::String.with_value("#{e}")
44
+ handler.apply_to(Lisp::ConsCell.array_to_list([err_string]), env)
45
+ else
46
+ if args.length == 3
47
+ handler = args.caddr.evaluate(env)
48
+ return Lisp::Debug.process_error("on-error needs a function as it's third argument", env) unless handler.function?
49
+ handler.apply_to(nil, env)
50
+ end
51
+ end
52
+ end
53
+
54
+ end
55
+ end
@@ -0,0 +1,58 @@
1
+ module Lisp
2
+
3
+ class PrimTypeChecks
4
+
5
+ def self.register
6
+ Primitive.register("list?", "1") {|args, env| Lisp::PrimTypeChecks::typep_impl(args.car, :pair) }
7
+ Primitive.register("pair?", "1") {|args, env| Lisp::PrimTypeChecks::typep_impl(args.car, :pair) }
8
+ Primitive.register("symbol?", "1") {|args, env| Lisp::PrimTypeChecks::typep_impl(args.car, :symbol) }
9
+ Primitive.register("number?", "1") {|args, env| Lisp::PrimTypeChecks::typep_impl(args.car, :number) }
10
+ Primitive.register("frame?", "1") {|args, env| Lisp::PrimTypeChecks::typep_impl(args.car, :frame) }
11
+
12
+ Primitive.register("integer?", "1") {|args, env| Lisp::PrimTypeChecks::integerp_impl(args, env) }
13
+ Primitive.register("float?", "1") {|args, env| Lisp::PrimTypeChecks::floatp_impl(args, env) }
14
+ Primitive.register("function?", "1") {|args, env| Lisp::PrimTypeChecks::functionp_impl(args, env) }
15
+
16
+ Primitive.register("nil?", "1") {|args, env| Lisp::PrimTypeChecks::nilp_impl(args, env) }
17
+ Primitive.register("null?", "1") {|args, env| Lisp::PrimTypeChecks::nilp_impl(args, env) }
18
+ Primitive.register("not-nil?", "1") {|args, env| Lisp::PrimTypeChecks::not_nilp_impl(args, env) }
19
+ Primitive.register("not-null?", "1") {|args, env| Lisp::PrimTypeChecks::not_nilp_impl(args, env) }
20
+ end
21
+
22
+
23
+ def self.typep_impl(val, sym)
24
+ return Lisp::Boolean.with_value(val.type == sym)
25
+ end
26
+
27
+
28
+ def self.integerp_impl(args, env)
29
+ val = args.car
30
+ return Lisp::Boolean.with_value(val.type == :number && val.integer?)
31
+ end
32
+
33
+
34
+ def self.floatp_impl(args, env)
35
+ val = args.car
36
+ return Lisp::Boolean.with_value(val.type == :number && val.float?)
37
+ end
38
+
39
+
40
+ def self.functionp_impl(args, env)
41
+ val = args.car
42
+ return Lisp::Boolean.with_value(val.type == :function || val.type == :primitive)
43
+ end
44
+
45
+
46
+ def self.nilp_impl(args, env)
47
+ return Lisp::Boolean.with_value(args.car.nil? || (args.car.pair? && args.car.empty?))
48
+ end
49
+
50
+
51
+ def self.not_nilp_impl(args, env)
52
+ return Lisp::FALSE if args.car.nil?
53
+ return Lisp::TRUE unless args.car.pair?
54
+ return Lisp::Boolean.with_value(args.car.pair? && !args.car.empty?)
55
+ end
56
+
57
+ end
58
+ end
@@ -0,0 +1,497 @@
1
+ module Lisp
2
+
3
+ class PrimVector
4
+
5
+ def self.register
6
+ Primitive.register("vector?", "1") {|args, env| Lisp::PrimVector::vectorp_impl(args, env) }
7
+ Primitive.register("make-vector", "1|2") {|args, env| Lisp::PrimVector::make_vector_impl(args, env) }
8
+ Primitive.register("make-initialized-vector", "2") {|args, env| Lisp::PrimVector::make_initialized_vector_impl(args, env) }
9
+ Primitive.register("vector", "*") {|args, env| Lisp::PrimVector::vector_impl(args, env) }
10
+ Primitive.register("list->vector", "1") {|args, env| Lisp::PrimVector::list_to_vector_impl(args, env) }
11
+ Primitive.register("vector->list", "1") {|args, env| Lisp::PrimVector::vector_to_list_impl(args, env) }
12
+ Primitive.register("vector-copy", "1") {|args, env| Lisp::PrimVector::vector_copy_impl(args, env) }
13
+ Primitive.register("vector-grow", "2") {|args, env| Lisp::PrimVector::vector_grow_impl(args, env) }
14
+ Primitive.register("vector-map", "2") {|args, env| Lisp::PrimVector::vector_map_impl(args, env) }
15
+ Primitive.register("vector-reduce-left", "3") {|args, env| Lisp::PrimVector::vector_reduce_left_impl(args, env) }
16
+ Primitive.register("vector-for-each", "2") {|args, env| Lisp::PrimVector::vector_for_each_impl(args, env) }
17
+ Primitive.register("vector-length", "1") {|args, env| Lisp::PrimVector::vector_length_impl(args, env) }
18
+ Primitive.register("vector-ref", "2") {|args, env| Lisp::PrimVector::vector_ref_impl(args, env) }
19
+ Primitive.register("vector-set!", "3") {|args, env| Lisp::PrimVector::vector_set_impl(args, env) }
20
+ Primitive.register("vector-first", "1") {|args, env| Lisp::PrimVector::vector_first_impl(args, env) }
21
+ Primitive.register("vector-second", "1") {|args, env| Lisp::PrimVector::vector_second_impl(args, env) }
22
+ Primitive.register("vector-third", "1") {|args, env| Lisp::PrimVector::vector_third_impl(args, env) }
23
+ Primitive.register("vector-fourth", "1") {|args, env| Lisp::PrimVector::vector_fourth_impl(args, env) }
24
+ Primitive.register("vector-fifth", "1") {|args, env| Lisp::PrimVector::vector_fifth_impl(args, env) }
25
+ Primitive.register("vector-sixth", "1") {|args, env| Lisp::PrimVector::vector_sixth_impl(args, env) }
26
+ Primitive.register("vector-seventh", "1") {|args, env| Lisp::PrimVector::vector_seventh_impl(args, env) }
27
+ Primitive.register("vector-eighth", "1") {|args, env| Lisp::PrimVector::vector_eighth_impl(args, env) }
28
+ Primitive.register("vector-ninth", "1") {|args, env| Lisp::PrimVector::vector_ninth_impl(args, env) }
29
+ Primitive.register("vector-tenth", "1") {|args, env| Lisp::PrimVector::vector_tenth_impl(args, env) }
30
+ Primitive.register("vector-binary-search", "4") {|args, env| Lisp::PrimVector::vector_binary_search_impl(args, env) }
31
+ Primitive.register("subvector", "3") {|args, env| Lisp::PrimVector::subvector_impl(args, env) }
32
+ Primitive.register("vector-head", "2") {|args, env| Lisp::PrimVector::vector_head_impl(args, env) }
33
+ Primitive.register("vector-tail", "2") {|args, env| Lisp::PrimVector::vector_tail_impl(args, env) }
34
+ Primitive.register("vector-fill!", "2") {|args, env| Lisp::PrimVector::vector_fill_impl(args, env) }
35
+ Primitive.register("subvector-fill!", "4") {|args, env| Lisp::PrimVector::subvector_fill_impl(args, env) }
36
+ Primitive.register("subvector-move-left!", "5") {|args, env| Lisp::PrimVector::subvector_move_left_impl(args, env) }
37
+ Primitive.register("subvector-move-right!", "5") {|args, env| Lisp::PrimVector::subvector_move_right_impl(args, env) }
38
+ Primitive.register("vector-filter", "2") {|args, env| Lisp::PrimVector::vector_filter_impl(args, env) }
39
+ Primitive.register("vector-remove", "2") {|args, env| Lisp::PrimVector::vector_remove_impl(args, env) }
40
+ Primitive.register("sort!", "2") {|args, env| Lisp::PrimVector::vector_merge_sort_impl(args, env) }
41
+ Primitive.register("merge-sort!", "2") {|args, env| Lisp::PrimVector::vector_merge_sort_impl(args, env) }
42
+ Primitive.register("quick-sort!", "2") {|args, env| Lisp::PrimVector::vector_quick_sort_impl(args, env) }
43
+ end
44
+
45
+ def self.vectorp_impl(args, env)
46
+ Boolean.with_value(args.car.vector?)
47
+ end
48
+
49
+
50
+ def self.make_initialized_vector_impl(args, env)
51
+ k = args.car
52
+ return Lisp::Debug.process_error("make-vector requires its first argument to be a non-negative integer, but received #{k.to_s}.", env) unless k.integer? && k.value >= 0
53
+ proc = args.cadr
54
+ return Lisp::Debug.process_error("make-initialized-vector requires its second argument to be a procedure, but received #{proc.to_s}.", env) unless proc.function? || proc.primitive?
55
+ a = Array.new(k.value) {|i| proc.apply_to(Lisp::ConsCell.array_to_list([Lisp::Number.with_value(i)]), env)}
56
+ Lisp::Vector.with_array(a)
57
+ end
58
+
59
+
60
+ def self.make_vector_impl(args, env)
61
+ k = args.car
62
+ return Lisp::Debug.process_error("make-vector requires its first argument to be a non-negative integer, but received #{k.to_s}.", env) unless k.integer? && k.value >= 0
63
+ obj = (args.length == 2) ? args.cadr : nil
64
+ Lisp::Vector.new(Array.new(k.value, obj))
65
+ end
66
+
67
+
68
+ def self.vector_impl(args, env)
69
+ Lisp::Vector.with_array(args.to_a)
70
+ end
71
+
72
+
73
+ def self.list_to_vector_impl(args, env)
74
+ l = args.car
75
+ return Lisp::Debug.process_error("list->vector requires its first argument to be a list, but received #{l.to_s}.", env) unless l.list?
76
+ Lisp::Vector.with_array(l.to_a)
77
+ end
78
+
79
+
80
+ def self.vector_to_list_impl(args, env)
81
+ v = args.car
82
+ return Lisp::Debug.process_error("vector->list requires its first argument to be a vector, but received #{v.to_s}.", env) unless v.vector?
83
+ Lisp::ConsCell.array_to_list(v.to_a)
84
+ end
85
+
86
+
87
+ def self.vector_copy_impl(args, env)
88
+ v = args.car
89
+ return Lisp::Debug.process_error("list->vector requires its first argument to be a vector, but received #{v.to_s}.", env) unless v.vector?
90
+ Lisp::Vector.with_array(v.to_a.clone)
91
+ end
92
+
93
+
94
+ def self.vector_grow_impl(args, env)
95
+ v = args.car
96
+ return Lisp::Debug.process_error("vector-grow requires its first argument to be a vector, but received #{v.to_s}.", env) unless v.vector?
97
+ len = v.length
98
+ k = args.cadr
99
+ return Lisp::Debug.process_error("vector-grow requires its second argument to be a non-negative integer > the length of the vector, but received #{k.to_s}.", env) unless k.integer? && k.value > len
100
+ new_array = v.to_a.clone
101
+ new_array[len..len] = Array.new(k.value - len)
102
+ Lisp::Vector.with_array(new_array)
103
+ end
104
+
105
+
106
+ def self.vector_map_impl(args, env)
107
+ proc = args.car
108
+ return Lisp::Debug.process_error("vector-map requires its first argument to be a procedure, but received #{proc.to_s}.", env) unless proc.function? || proc.primitive?
109
+ v = args.cadr
110
+ return Lisp::Debug.process_error("vector-map requires its second argument to be a vector, but received #{v.to_s}.", env) unless v.vector?
111
+ Lisp::Vector.with_array(v.to_a.collect {|e| proc.apply_to_without_evaluating(Lisp::ConsCell.array_to_list([e]), env)})
112
+ end
113
+
114
+
115
+ def self.vector_reduce_left_impl(args, env)
116
+ proc = args.car
117
+ return Lisp::Debug.process_error("vector-reduce-left requires its first argument to be a procedure, but received #{proc.to_s}.", env) unless proc.function? || proc.primitive?
118
+ initial = args.cadr
119
+ v = args.caddr
120
+ return Lisp::Debug.process_error("vector-reduce-left requires its second argument to be a vector, but received #{v.to_s}.", env) unless v.vector?
121
+ return initial if v.empty?
122
+ return v.at(0) if v.length == 1
123
+ v.to_a.inject do |acc, item|
124
+ proc.apply_to_without_evaluating(Lisp::ConsCell.array_to_list([acc, item]), env)
125
+ end
126
+ end
127
+
128
+
129
+ def self.vector_for_each_impl(args, env)
130
+ proc = args.car
131
+ return Lisp::Debug.process_error("vector-for-each requires its first argument to be a procedure, but received #{proc.to_s}.", env) unless proc.function? || proc.primitive?
132
+ v = args.cadr
133
+ return Lisp::Debug.process_error("vector-for-each requires its second argument to be a vector, but received #{v.to_s}.", env) unless v.vector?
134
+ v.to_a.each {|e| proc.apply_to_without_evaluating(Lisp::ConsCell.array_to_list([e]), env)}
135
+ nil
136
+ end
137
+
138
+
139
+ def self.vector_length_impl(args, env)
140
+ v = args.car
141
+ return Lisp::Debug.process_error("vector-length requires its first argument to be a vector, but received #{v.to_s}.", env) unless v.vector?
142
+ Lisp::Number.with_value(v.to_a.length)
143
+ end
144
+
145
+
146
+ def self.vector_ref_impl(args, env)
147
+ v = args.car
148
+ return Lisp::Debug.process_error("vector-ref requires its first argument to be a vector, but received #{v.to_s}.", env) unless v.vector?
149
+ len = v.length
150
+ k = args.cadr
151
+ return Lisp::Debug.process_error("vector-ref requires its second argument to be a non-negative integer < the length of the vector, but received #{k.to_s}.", env) unless k.integer? && k.value < len
152
+ v.at(k.value)
153
+ end
154
+
155
+
156
+ def self.vector_set_impl(args, env)
157
+ v = args.car
158
+ return Lisp::Debug.process_error("vector-set requires its first argument to be a vector, but received #{v.to_s}.", env) unless v.vector?
159
+ len = v.length
160
+ k = args.cadr
161
+ return Lisp::Debug.process_error("vector-set requires its second argument to be a non-negative integer < the length of the vector, but received #{k.to_s}.", env) unless k.integer? && k.value < len
162
+ obj = args.caddr
163
+ v.at_put(k.value, obj)
164
+ v
165
+ end
166
+
167
+
168
+ def self.vector_first_impl(args, env)
169
+ v = args.car
170
+ return Lisp::Debug.process_error("vector-first requires its first argument to be a vector, but received #{v.to_s}.", env) unless v.vector?
171
+ return Lisp::Debug.process_error("vector index out of bounds", env) unless v.length >= 1
172
+ v.at(0)
173
+ end
174
+
175
+
176
+ def self.vector_second_impl(args, env)
177
+ v = args.car
178
+ return Lisp::Debug.process_error("vector-second requires its first argument to be a vector, but received #{v.to_s}.", env) unless v.vector?
179
+ return Lisp::Debug.process_error("vector index out of bounds", env) unless v.length >= 2
180
+ v.at(1)
181
+ end
182
+
183
+
184
+ def self.vector_third_impl(args, env)
185
+ v = args.car
186
+ return Lisp::Debug.process_error("vector-third requires its first argument to be a vector, but received #{v.to_s}.", env) unless v.vector?
187
+ return Lisp::Debug.process_error("vector index out of bounds", env) unless v.length >= 3
188
+ v.at(2)
189
+ end
190
+
191
+
192
+ def self.vector_fourth_impl(args, env)
193
+ v = args.car
194
+ return Lisp::Debug.process_error("vector-fourth requires its first argument to be a vector, but received #{v.to_s}.", env) unless v.vector?
195
+ return Lisp::Debug.process_error("vector index out of bounds", env) unless v.length >= 4
196
+ v.at(3)
197
+ end
198
+
199
+
200
+ def self.vector_fifth_impl(args, env)
201
+ v = args.car
202
+ return Lisp::Debug.process_error("vector-fifth requires its first argument to be a vector, but received #{v.to_s}.", env) unless v.vector?
203
+ return Lisp::Debug.process_error("vector index out of bounds", env) unless v.length >= 5
204
+ v.at(4)
205
+ end
206
+
207
+
208
+ def self.vector_sixth_impl(args, env)
209
+ v = args.car
210
+ return Lisp::Debug.process_error("vector-sixth requires its first argument to be a vector, but received #{v.to_s}.", env) unless v.vector?
211
+ return Lisp::Debug.process_error("vector index out of bounds", env) unless v.length >= 6
212
+ v.at(5)
213
+ end
214
+
215
+
216
+ def self.vector_seventh_impl(args, env)
217
+ v = args.car
218
+ return Lisp::Debug.process_error("vector-seventh requires its first argument to be a vector, but received #{v.to_s}.", env) unless v.vector?
219
+ return Lisp::Debug.process_error("vector index out of bounds", env) unless v.length >= 7
220
+ v.at(6)
221
+ end
222
+
223
+
224
+ def self.vector_eighth_impl(args, env)
225
+ v = args.car
226
+ return Lisp::Debug.process_error("vector-eighth requires its first argument to be a vector, but received #{v.to_s}.", env) unless v.vector?
227
+ return Lisp::Debug.process_error("vector index out of bounds", env) unless v.length >= 8
228
+ v.at(7)
229
+ end
230
+
231
+
232
+ def self.vector_ninth_impl(args, env)
233
+ v = args.car
234
+ return Lisp::Debug.process_error("vector-ninth requires its first argument to be a vector, but received #{v.to_s}.", env) unless v.vector?
235
+ return Lisp::Debug.process_error("vector index out of bounds", env) unless v.length >= 9
236
+ v.at(8)
237
+ end
238
+
239
+
240
+ def self.vector_tenth_impl(args, env)
241
+ v = args.car
242
+ return Lisp::Debug.process_error("vector-tenth requires its first argument to be a vector, but received #{v.to_s}.", env) unless v.vector?
243
+ return Lisp::Debug.process_error("vector index out of bounds", env) unless v.length >= 10
244
+ v.at(9)
245
+ end
246
+
247
+
248
+ def self.vector_binary_search_impl(args, env)
249
+ v = args.car
250
+ return Lisp::Debug.process_error("vector-binary-search requires its first argument to be a vector, but received #{v.to_s}.", env) unless v.vector?
251
+
252
+ comparison_predicate = args.cadr
253
+ return Lisp::Debug.process_error("vector-binary-search requires its second argument to be a procedure, but received #{comparison_predicate.to_s}.", env) unless comparison_predicate.function? || comparison_predicate.primitive?
254
+
255
+ unwrap_proc = args.caddr
256
+ return Lisp::Debug.process_error("vector-binary-search requires its third argument to be a procedure, but received #{unwrap_proc.to_s}.", env) unless unwrap_proc.function? || unwrap_proc.primitive?
257
+
258
+ key = args.cadddr
259
+
260
+ lo = 0
261
+ hi = v.length - 1
262
+
263
+ while lo <= hi
264
+ mid = lo + (hi - lo) / 2
265
+ val = unwrap_proc.apply_to_without_evaluating(Lisp::ConsCell.cons(v.at(mid)), env)
266
+ return v.at(mid) if key.equal?(val)
267
+ if comparison_predicate.apply_to_without_evaluating(Lisp::ConsCell.array_to_list([key, val]), env).value
268
+ hi = mid - 1
269
+ else
270
+ lo = mid + 1
271
+ end
272
+ end
273
+ Lisp::FALSE
274
+ end
275
+
276
+
277
+ def self.subvector_impl(args, env)
278
+ v = args.car
279
+ return Lisp::Debug.process_error("subvector requires its first argument to be a vector, but received #{v.to_s}.", env) unless v.vector?
280
+ len = v.length
281
+ s = args.cadr
282
+ return Lisp::Debug.process_error("subvector requires its second argument to be a non-negative integer < the length of the vector, but received #{s.to_s}.", env) unless s.integer? && s.value >= 0 && s.value < len
283
+ e = args.caddr
284
+ return Lisp::Debug.process_error("subvector requires its third argument to be a non-negative integer >= the second argument and <= the length of the vector, but received #{e.to_s}.", env) unless e.integer? && e.value >= s.value && e.value <= len
285
+ Vector.with_array(v.to_a[s.value...e.value])
286
+ end
287
+
288
+
289
+ def self.vector_head_impl(args, env)
290
+ v = args.car
291
+ return Lisp::Debug.process_error("vector-head requires its first argument to be a vector, but received #{v.to_s}.", env) unless v.vector?
292
+ e = args.cadr
293
+ return Lisp::Debug.process_error("vector-head requires its second argument to be a non-negative integer <= the length of the vector, but received #{e.to_s}.", env) unless e.integer? && e.value >= 0 && e.value <= v.length
294
+ Vector.with_array(v.to_a[0...e.value])
295
+ end
296
+
297
+
298
+ def self.vector_tail_impl(args, env)
299
+ v = args.car
300
+ return Lisp::Debug.process_error("vector-tail requires its first argument to be a vector, but received #{v.to_s}.", env) unless v.vector?
301
+ s = args.cadr
302
+ return Lisp::Debug.process_error("vector-tail requires its second argument to be a non-negative integer <= the length of the vector, but received #{s.to_s}.", env) unless s.integer? && s.value >= 0 && s.value <= v.length
303
+ Vector.with_array(v.to_a[s.value..-1])
304
+ end
305
+
306
+
307
+ def self.vector_fill_impl(args, env)
308
+ v = args.car
309
+ return Lisp::Debug.process_error("vector-tail requires its first argument to be a vector, but received #{v.to_s}.", env) unless v.vector?
310
+ obj = args.cadr
311
+ (0...v.length).each {|i| v.at_put(i, obj)}
312
+ v
313
+ end
314
+
315
+
316
+ def self.subvector_fill_impl(args, env)
317
+ v = args.car
318
+ return Lisp::Debug.process_error("subvector requires its first argument to be a vector, but received #{v.to_s}.", env) unless v.vector?
319
+ len = v.length
320
+ s = args.cadr
321
+ return Lisp::Debug.process_error("subvector requires its second argument to be a non-negative integer < the length of the vector, but received #{s.to_s}.", env) unless s.integer? && s.value >= 0 && s.value < len
322
+ e = args.caddr
323
+ return Lisp::Debug.process_error("subvector requires its third argument to be a non-negative integer >= the second argument and <= the length of the vector, but received #{e.to_s}.", env) unless e.integer? && e.value >= s.value && e.value <= len
324
+ obj = args.cadddr
325
+ (s.value...e.value).each {|i| v.at_put(i, obj)}
326
+ v
327
+ end
328
+
329
+
330
+ def self.vector_filter_impl(args, env)
331
+ proc = args.car
332
+ return Lisp::Debug.process_error("vector-filter requires its first argument to be a procedure, but received #{proc.to_s}.", env) unless proc.function? || proc.primitive?
333
+ v = args.cadr
334
+ return Lisp::Debug.process_error("vector-filter requires its second argument to be a vector, but received #{v.to_s}.", env) unless v.vector?
335
+ new_array = v.to_a.select {|e| proc.apply_to_without_evaluating(Lisp::ConsCell.cons(e), env).value}
336
+ Lisp::Vector.with_array(new_array)
337
+ end
338
+
339
+
340
+ def self.vector_remove_impl(args, env)
341
+ proc = args.car
342
+ return Lisp::Debug.process_error("vector-remove requires its first argument to be a procedure, but received #{proc.to_s}.", env) unless proc.function? || proc.primitive?
343
+ v = args.cadr
344
+ return Lisp::Debug.process_error("vector-remove requires its second argument to be a vector, but received #{v.to_s}.", env) unless v.vector?
345
+ new_array = v.to_a.reject {|e| proc.apply_to_without_evaluating(Lisp::ConsCell.cons(e), env).value}
346
+ Lisp::Vector.with_array(new_array)
347
+ end
348
+
349
+
350
+ def self.subvector_move_left_impl(args, env)
351
+ v1 = args.car
352
+ return Lisp::Debug.process_error("subvector-move-left! requires its first argument to be a vector, but received #{v1.to_s}.", env) unless v1.vector?
353
+ len1 = v1.length
354
+
355
+ s1 = args.cadr
356
+ return Lisp::Debug.process_error("subvector-move-left! requires its second argument to be a non-negative integer < the length of the vector, but received #{s1.to_s}.", env) unless s1.integer? && s1.value >= 0 && s1.value < len1
357
+
358
+ e1 = args.caddr
359
+ return Lisp::Debug.process_error("subvector-move-left! requires its third argument to be a non-negative integer >= the second argument and <= the length of the vector, but received #{e1.to_s}.", env) unless e1.integer? && e1.value >= s1.value && e1.value <= len1
360
+
361
+ v2 = args.cadddr
362
+ return Lisp::Debug.process_error("subvector-move-left! requires its fourth argument to be a vector, but received #{v2.to_s}.", env) unless v2.vector?
363
+ len2 = v2.length
364
+
365
+ s2 = args.caddddr
366
+ return Lisp::Debug.process_error("subvector-move-left! requires its fifth argument to be a non-negative integer < the length of the vector, but received #{s2.to_s}.", env) unless s2.integer? && s2.value >= 0 && s2.value < len2
367
+
368
+ source_length = e1.value - s1.value
369
+ tail_size2 = len2 - s2.value
370
+ return Lisp::Debug.process_error("subvector-move-left! source subvector is longer than the available space in the destination (0-#{tail_size2}), got #{source_length}.", env) unless source_length < tail_size2
371
+
372
+ i1 = s1.value
373
+ i2 = s2.value
374
+ while i1 < e1.value
375
+ v2.at_put(i2, v1.at(i1))
376
+ i1 = i1 + 1
377
+ i2 = i2 + 1
378
+ end
379
+
380
+ v2
381
+ end
382
+
383
+
384
+ def self.subvector_move_right_impl(args, env)
385
+ v1 = args.car
386
+ return Lisp::Debug.process_error("subvector-move-right! requires its first argument to be a vector, but received #{v1.to_s}.", env) unless v1.vector?
387
+ len1 = v1.length
388
+
389
+ s1 = args.cadr
390
+ return Lisp::Debug.process_error("subvector-move-right! requires its second argument to be a non-negative integer < the length of the vector, but received #{s1.to_s}.", env) unless s1.integer? && s1.value >= 0 && s1.value < len1
391
+
392
+ e1 = args.caddr
393
+ return Lisp::Debug.process_error("subvector-move-right! requires its third argument to be a non-negative integer >= the second argument and <= the length of the vector, but received #{e1.to_s}.", env) unless e1.integer? && e1.value >= s1.value && e1.value <= len1
394
+
395
+ v2 = args.cadddr
396
+ return Lisp::Debug.process_error("subvector-move-right! requires its fourth argument to be a vector, but received #{v2.to_s}.", env) unless v2.vector?
397
+ len2 = v2.length
398
+
399
+ s2 = args.caddddr
400
+ return Lisp::Debug.process_error("subvector-move-right! requires its fifth argument to be a non-negative integer < the length of the vector, but received #{s2.to_s}.", env) unless s2.integer? && s2.value >= 0 && s2.value < len2
401
+
402
+ source_length = e1.value - s1.value
403
+ tail_size2 = len2 - s2.value
404
+ return Lisp::Debug.process_error("subvector-move-right! source subvector is longer than the available space in the destination (0-#{tail_size2}), got #{source_length}.", env) unless source_length < tail_size2
405
+
406
+ i1 = e1.value - 1
407
+ i2 = s2.value + source_length - 1
408
+ while i1 >= s1.value
409
+ v2.at_put(i2, v1.at(i1))
410
+ i1 = i1 - 1
411
+ i2 = i2 - 1
412
+ end
413
+
414
+ v2
415
+ end
416
+
417
+
418
+ def self.merge(left, right, comparison_predicate, env)
419
+ result = []
420
+ while !left.empty? && !right.empty?
421
+ if comparison_predicate.apply_to_without_evaluating(Lisp::ConsCell.array_to_list([left[0], right[0]]), env).value
422
+ result << left.shift
423
+ else
424
+ result << right.shift
425
+ end
426
+ end
427
+ result[result.length..result.length] = left
428
+ result[result.length..result.length] = right
429
+ result
430
+ end
431
+
432
+
433
+ def self.merge_sort(m, comparison_predicate, env)
434
+ return m if m.length <= 1
435
+ middle = m.length / 2
436
+ left = m[0...middle]
437
+ right = m[middle..-1]
438
+ merge(merge_sort(left, comparison_predicate, env), merge_sort(right, comparison_predicate, env), comparison_predicate, env)
439
+ end
440
+
441
+
442
+ def self.vector_merge_sort_impl(args, env)
443
+ v = args.car
444
+ return Lisp::Debug.process_error("merge-sort! requires its first argument to be a vector, but received #{v.to_s}.", env) unless v.vector?
445
+
446
+ comparison_predicate = args.cadr
447
+ return Lisp::Debug.process_error("merge-sort! requires its second argument to be a procedure, but received #{comparison_predicate.to_s}.", env) unless comparison_predicate.function? || comparison_predicate.primitive?
448
+
449
+ v.update!(merge_sort(v.to_a, comparison_predicate, env))
450
+ v
451
+ end
452
+
453
+
454
+ def self.partition(v, lo, hi, comparison_predicate, env)
455
+ pivot = v[lo]
456
+ i = lo - 1
457
+ j = hi + 1
458
+ while true
459
+ begin
460
+ j = j - 1
461
+ end while comparison_predicate.apply_to_without_evaluating(Lisp::ConsCell.array_to_list([pivot, v[j]]), env).value
462
+ begin
463
+ i = i + 1
464
+ end while comparison_predicate.apply_to_without_evaluating(Lisp::ConsCell.array_to_list([v[i], pivot]), env).value
465
+ if i < j
466
+ v[i], v[j] = v[j], v[i]
467
+ else
468
+ return j
469
+ end
470
+ end
471
+ end
472
+
473
+
474
+ def self.quicksort(v, lo, hi, comparison_predicate, env)
475
+ if lo < hi
476
+ p = partition(v, lo, hi, comparison_predicate, env)
477
+ quicksort(v, lo, p, comparison_predicate, env)
478
+ quicksort(v, p + 1, hi, comparison_predicate, env)
479
+ end
480
+ v
481
+ end
482
+
483
+
484
+ def self.vector_quick_sort_impl(args, env)
485
+ v = args.car
486
+ return Lisp::Debug.process_error("quick-sort! requires its first argument to be a vector, but received #{v.to_s}.", env) unless v.vector?
487
+
488
+ comparison_predicate = args.cadr
489
+ return Lisp::Debug.process_error("quick-sort! requires its second argument to be a procedure, but received #{comparison_predicate.to_s}.", env) unless comparison_predicate.function? || comparison_predicate.primitive?
490
+ v.update!(quicksort(v.to_a, 0, v.length - 1, comparison_predicate, env))
491
+ v
492
+ end
493
+
494
+
495
+ end
496
+
497
+ end