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,61 @@
1
+ module Lisp
2
+
3
+ class PrimAssignment
4
+
5
+ def self.register
6
+ Primitive.register("set!", "2",
7
+ "(set! name new-value)\n\nThe way to assign (i.e. rebind) a symbol. `name` is the symbol to be rebound.
8
+ The `new-value` sexpr is evaluated to arrive at the new value to be bound to. Use of `set!` is frowned upon, and should not be used without thought.",
9
+ true) { |args, env| Lisp::PrimAssignment::setbang_impl(args, env) }
10
+
11
+ Primitive.register("set-car!", "2",
12
+ "(set-car! cons-cell new-value)\n\nSet the `car` pointer of `cons-cell`.") { |args, env| Lisp::PrimAssignment::setcarbang_impl(args, env) }
13
+
14
+ Primitive.register("set-cdr!", "2",
15
+ "(set-cdr! cons-cell new-value)\n\nSet the `cdr` pointer of `cons-cell`.") { |args, env| Lisp::PrimAssignment::setcdrbang_impl(args, env) }
16
+
17
+ Primitive.register("set-nth!", "3",
18
+ "(set-nth! n list-or-vector new-value)\n\nSets the `n`th element of `list-or-vector` to `new-value`.") { |args, env| Lisp::PrimAssignment::setnthbang_impl(args, env) }
19
+
20
+ end
21
+
22
+
23
+ def self.setbang_impl(args, env)
24
+ sym = args.car
25
+ return Lisp::Debug.process_error("set! requires a raw (unevaluated) symbol as it's first argument.", env) unless sym.symbol?
26
+ value = args.cadr.evaluate(env)
27
+ env.set(sym, value)
28
+ end
29
+
30
+
31
+ def self.setcarbang_impl(args, env)
32
+ pair = args.car
33
+ return Lisp::Debug.process_error("set-car! requires a pair as it's first argument.", env) unless pair.pair?
34
+ value = args.cadr
35
+ pair.set_car!(value)
36
+ end
37
+
38
+
39
+ def self.setcdrbang_impl(args, env)
40
+ pair = args.car
41
+ return Lisp::Debug.process_error("set-cdr! requires a pair as it's first argument.", env) unless pair.pair?
42
+ value = args.cadr
43
+ pair.set_cdr!(value)
44
+ end
45
+
46
+
47
+ def self.setnthbang_impl(args, env)
48
+ n = args.car
49
+ return Lisp::Debug.process_error("The first argument of set-nth! has to be an number.", env) unless n.number?
50
+ return Lisp::Debug.process_error("The first argument of set-nth! has to be non negative.", env) unless n.value >= 0
51
+
52
+ l = args.cadr
53
+ return Lisp::Debug.process_error("set-nth! requires a list or vector as it's first argument.", env) unless l.list? || l.vector?
54
+ value = args.caddr
55
+ l.set_nth!(n.value, value)
56
+ l
57
+ end
58
+
59
+
60
+ end
61
+ end
@@ -0,0 +1,273 @@
1
+ # -*- coding: utf-8 -*-
2
+ module Lisp
3
+
4
+ class PrimCharacter
5
+
6
+ def self.register
7
+ Primitive.register("char->name", "1", "(char->name char)\n\nReturns a string corresponding to the printed representation of char. This is the character or character-name component of the external representation.") do |args, env|
8
+ Lisp::PrimCharacter::char_name_impl(args, env)
9
+ end
10
+
11
+ Primitive.register("name->char", "1", "(name->char string)\n\nConverts a string that names a character into the character specified. If string does not name any character, name->char signals an error.") do |args, env|
12
+ Lisp::PrimCharacter::name_char_impl(args, env)
13
+ end
14
+
15
+ Primitive.register("char=?", "2", "(char=? char1 char2)\n\nReturn whether char1 and char2 are the same") do |args, env|
16
+ Lisp::PrimCharacter::char_eq_impl(args, env)
17
+ end
18
+
19
+ Primitive.register("char<?", "2", "(char<? char1 char2)\n\nReturn whether char1 is less than char2") do |args, env|
20
+ Lisp::PrimCharacter::char_lt_impl(args, env)
21
+ end
22
+
23
+ Primitive.register("char>?", "2", "(char>? char1 char2)\n\nReturn whether char1 is greater than char2") do |args, env|
24
+ Lisp::PrimCharacter::char_gt_impl(args, env)
25
+ end
26
+
27
+ Primitive.register("char<=?", "2", "(char<=? char1 char2)\n\nReturn whether char1 is less than or equal to char2") do |args, env|
28
+ Lisp::PrimCharacter::char_lteq_impl(args, env)
29
+ end
30
+
31
+ Primitive.register("char>=?", "2", "(char>=? char1 char2)\n\nReturn whether char1 is greater than or equal to char2") do |args, env|
32
+ Lisp::PrimCharacter::char_gteq_impl(args, env)
33
+ end
34
+
35
+ Primitive.register("char-ci=?", "2", "(char=? char1 char2)\n\nReturn whether char1 is equal to char2, ignoring case") do |args, env|
36
+ Lisp::PrimCharacter::char_ci_eq_impl(args, env)
37
+ end
38
+
39
+ Primitive.register("char-ci<?", "2", "(char=? char1 char2)\n\nReturn whether char1 is less than char2, ignoring case") do |args, env|
40
+ Lisp::PrimCharacter::char_ci_lt_impl(args, env)
41
+ end
42
+
43
+ Primitive.register("char-ci>?", "2", "(char=? char1 char2)\n\nReturn whether char1 is greater than char2, ignoring case") do |args, env|
44
+ Lisp::PrimCharacter::char_ci_gt_impl(args, env)
45
+ end
46
+
47
+ Primitive.register("char-ci<=?", "2", "(char=? char1 char2)\n\nReturn whether char1 is less than or equal to char2, ignoring case") do |args, env|
48
+ Lisp::PrimCharacter::char_ci_lteq_impl(args, env)
49
+ end
50
+
51
+ Primitive.register("char-ci>=?", "2", "(char=? char1 char2)\n\nReturn whether char1 is greater than orequal to char2, ignoring case") do |args, env|
52
+ Lisp::PrimCharacter::char_ci_gteq_impl(args, env)
53
+ end
54
+
55
+ Primitive.register("char?", "1", "(char? sexpr)\n\nReturns #t if object is a character; otherwise returns #f.") do |args, env|
56
+ Lisp::PrimCharacter::charp_impl(args, env)
57
+ end
58
+
59
+ Primitive.register("char-upcase", "1", "(char-upcase char)\n\nReturns the uppercase equivalent of char if char is a letter; otherwise returns char. These procedures return a character char2 such that (char-ci=? char char2).") do |args, env|
60
+ Lisp::PrimCharacter::char_upcase_impl(args, env)
61
+ end
62
+
63
+ Primitive.register("char-downcase", "1", "(char-downcase char)\n\nReturns the lowercase equivalent of char if char is a letter; otherwise returns char. These procedures return a character char2 such that (char-ci=? char char2).") do |args, env|
64
+ Lisp::PrimCharacter::char_downcase_impl(args, env)
65
+ end
66
+
67
+ Primitive.register("char->digit", "1|2", "(char->digit char [radix])\n\nIf char is a character representing a digit in the given radix, returns the corresponding integer value. If you specify radix (which must be an integer between 2 and 36 inclusive), the conversion is done in that base, otherwise it is done in base 10. If char doesn’t represent a digit in base radix, char->digit returns #f.\n\nNote that this procedure is insensitive to the alphabetic case of char.") do |args, env|
68
+ Lisp::PrimCharacter::char_digit_impl(args, env)
69
+ end
70
+
71
+ Primitive.register("digit->char", "1|2", "(digit->char digit [radix])\n\nReturns a character that represents digit in the radix given by radix. Radix must be an exact integer between 2 and 36 (inclusive), and defaults to 10. Digit, which must be a non-negative integer, should be less than radix; if digit is greater than or equal to radix, digit->char returns #f.") do |args, env|
72
+ Lisp::PrimCharacter::digit_char_impl(args, env)
73
+ end
74
+
75
+ Primitive.register("char->integer", "1", "(char->integer char)\n\nchar->integer returns the character code representation for char.") do |args, env|
76
+ Lisp::PrimCharacter::char_int_impl(args, env)
77
+ end
78
+
79
+ Primitive.register("integer->char", "1", "(integer->char k)\n\ninteger->char returns the character whose character code representation is k.") do |args, env|
80
+ Lisp::PrimCharacter::int_char_impl(args, env)
81
+ end
82
+ end
83
+
84
+
85
+ def self.find_character_for_chr(ch)
86
+ Lisp::Character.character_constants.each_value {|v| return v if v.value == ch}
87
+ return Lisp::Character.character_constants[ch] = Lisp::Character.new(ch)
88
+ end
89
+
90
+
91
+ def self.find_character_for_name(n)
92
+ return Lisp::Character.character_constants[n] if Lisp::Character.character_constants.has_key?(n)
93
+ if n.length == 1
94
+ ch = self.new(n[0])
95
+ return Lisp::Character.character_constants[n] = ch
96
+ end
97
+ nil
98
+ end
99
+
100
+
101
+ def self.char_name_impl(args, env)
102
+ char = args.car
103
+ return Lisp::Debug.process_error("char->name requires a character argument", env) unless char.character?
104
+ kv = Lisp::Character.character_constants.rassoc(char)
105
+ return Lisp::String.with_value(kv[0]) unless kv.nil?
106
+ return Lisp::Debug.process_error("char->name was passed an invalid character", env)
107
+ end
108
+
109
+
110
+ def self.name_char_impl(args, env)
111
+ name = args.car
112
+ return Lisp::Debug.process_error("name->char requires a string argument", env) unless name.string?
113
+ ch = find_character_for_name(name.value)
114
+ return ch unless ch.nil?
115
+ return Lisp::Debug.process_error("There is no character with the name #{name}", env)
116
+ end
117
+
118
+
119
+ def self.get_one_character_arg(func, args, env)
120
+ char1 = args.car
121
+ return Lisp::Debug.process_error("#{func} requires a character argument, found #{char1}", env) unless char1.character?
122
+ return char1
123
+ end
124
+
125
+
126
+ def self.get_two_character_args(func, args, env)
127
+ char1 = args.car
128
+ return Lisp::Debug.process_error("#{func} requires character arguments, found #{char1}", env) unless char1.character?
129
+ char2 = args.cadr
130
+ return Lisp::Debug.process_error("#{func} requires character arguments, found #{char2}", env) unless char2.character?
131
+ return [char1, char2]
132
+ end
133
+
134
+
135
+ def self.char_eq_impl(args, env)
136
+ char1, char2 = get_two_character_args("char=?", args, env)
137
+ Lisp::Boolean.with_value(char1.value == char2.value)
138
+ end
139
+
140
+
141
+ def self.char_lt_impl(args, env)
142
+ char1, char2 = get_two_character_args("char<?", args, env)
143
+ Lisp::Boolean.with_value(char1.value < char2.value)
144
+ end
145
+
146
+
147
+ def self.char_gt_impl(args, env)
148
+ char1, char2 = get_two_character_args("char>?", args, env)
149
+ Lisp::Boolean.with_value(char1.value > char2.value)
150
+ end
151
+
152
+
153
+ def self.char_lteq_impl(args, env)
154
+ char1, char2 = get_two_character_args("char<=?", args, env)
155
+ Lisp::Boolean.with_value(char1.value <= char2.value)
156
+ end
157
+
158
+
159
+ def self.char_gteq_impl(args, env)
160
+ char1, char2 = get_two_character_args("char>=?", args, env)
161
+ Lisp::Boolean.with_value(char1.value >= char2.value)
162
+ end
163
+
164
+
165
+ def self.char_ci_eq_impl(args, env)
166
+ char1, char2 = get_two_character_args("char-ci=?", args, env)
167
+ Lisp::Boolean.with_value(char1.value.downcase == char2.value.downcase)
168
+ end
169
+
170
+
171
+ def self.char_ci_lt_impl(args, env)
172
+ char1, char2 = get_two_character_args("char-ci<?", args, env)
173
+ Lisp::Boolean.with_value(char1.value.downcase < char2.value.downcase)
174
+ end
175
+
176
+
177
+ def self.char_ci_gt_impl(args, env)
178
+ char1, char2 = get_two_character_args("char-ci>?", args, env)
179
+ Lisp::Boolean.with_value(char1.value.downcase > char2.value.downcase)
180
+ end
181
+
182
+
183
+ def self.char_ci_lteq_impl(args, env)
184
+ char1, char2 = get_two_character_args("char-ci<=?", args, env)
185
+ Lisp::Boolean.with_value(char1.value.downcase <= char2.value.downcase)
186
+ end
187
+
188
+
189
+ def self.char_ci_gteq_impl(args, env)
190
+ char1, char2 = get_two_character_args("char-ci>=?", args, env)
191
+ Lisp::Boolean.with_value(char1.value.downcase >= char2.value.downcase)
192
+ end
193
+
194
+
195
+ def self.charp_impl(args, env)
196
+ char = args.car
197
+ Lisp::Boolean.with_value(char.character?)
198
+ end
199
+
200
+
201
+ def self.char_upcase_impl(args, env)
202
+ char = get_one_character_arg("char->digit", args, env)
203
+ find_character_for_chr(char.value.upcase)
204
+ end
205
+
206
+
207
+ def self.char_downcase_impl(args, env)
208
+ char = get_one_character_arg("char->digit", args, env)
209
+ find_character_for_chr(char.value.downcase)
210
+ end
211
+
212
+
213
+ def self.char_digit_impl(args, env)
214
+ char = get_one_character_arg("char->digit", args, env)
215
+ base = if args.length == 1
216
+ 10
217
+ else
218
+ b = args.cadr
219
+ return Lisp::Debug.process_error("Base for char->digit has to be an integer", env) unless b.integer?
220
+ return Lisp::Debug.process_error("Base for char->digit has to be between 2 and 36", env) unless b.value >=2 && b.value <= 36
221
+ b.value
222
+ end
223
+ ch = char.value.upcase
224
+ value = case ch
225
+ when /[0-9]/
226
+ ch[0].ord - 48
227
+ when /[A-Z]/
228
+ 10 + ch[0].ord - 65
229
+ else
230
+ -1
231
+ end
232
+ if value == -1
233
+ Lisp::FALSE
234
+ elsif value >= base
235
+ Lisp::FALSE
236
+ else
237
+ Lisp::Number.with_value(value)
238
+ end
239
+ end
240
+
241
+
242
+ def self.digit_char_impl(args, env)
243
+ d = args.car
244
+ return Lisp::Debug.process_error("Digit value for digit->char has to be an integer", env) unless d.integer?
245
+ base = if args.length == 1
246
+ 10
247
+ else
248
+ b = args.cadr
249
+ return Lisp::Debug.process_error("Base for char->digit has to be an integer", env) unless b.integer?
250
+ return Lisp::Debug.process_error("Base for char->digit has to be between 2 and 36", env) unless b.value >=2 && b.value <= 36
251
+ b.value
252
+ end
253
+ val = d.value
254
+ return Lisp::FALSE if val < 0 || val >= base
255
+ find_character_for_chr((((val < 10) ? 48 : 55) + val).chr)
256
+ end
257
+
258
+
259
+ def self.char_int_impl(args, env)
260
+ char = get_one_character_arg("char->int", args, env)
261
+ Lisp::Number.with_value(char.value.ord)
262
+ end
263
+
264
+
265
+ def self.int_char_impl(args, env)
266
+ i = args.car
267
+ return Lisp::Debug.process_error("Integer value for int->char has to be an integer", env) unless i.integer?
268
+ find_character_for_chr(i.value.chr)
269
+ end
270
+
271
+ end
272
+
273
+ end
@@ -1,41 +1,38 @@
1
1
  # -*- coding: utf-8 -*-
2
2
  module Lisp
3
3
 
4
- class ClassObject < Atom
4
+ class PrimClassObject
5
5
 
6
6
  def self.register
7
- Primitive.register("extend", "(extend parent child)\n\nCreates a new class named child that extends (i.e. inherits from) the class parent. The names (parent and child can be either stirngs or symbols). The new class is accessible by name and is returned.") do |args, env|
8
- Lisp::ClassObject::extend_impl(args, env)
7
+ Primitive.register("extend", "2", "(extend parent child)\n\nCreates a new class named child that extends (i.e. inherits from) the class parent. The names (parent and child can be either stirngs or symbols). The new class is accessible by name and is returned.") do |args, env|
8
+ Lisp::PrimClassObject::extend_impl(args, env)
9
9
  end
10
10
 
11
- Primitive.register("add-method", "(add-method class selector function)\n\nAdd a method named selector to the class named class using function as it’s body. function can be a reference to a named function or, more likely, a lambda expression.") do |args, env|
12
- Lisp::ClassObject::add_method_impl(args, env)
11
+ Primitive.register("add-method", "3", "(add-method class selector function)\n\nAdd a method named selector to the class named class using function as it’s body. function can be a reference to a named function or, more likely, a lambda expression.") do |args, env|
12
+ Lisp::PrimClassObject::add_method_impl(args, env)
13
13
  end
14
14
 
15
15
  Primitive.register("add-static-method", "Not Implemented.") do |args, env|
16
- Lisp::ClassObject::add_static_method_impl(args, env)
16
+ Lisp::PrimClassObject::add_static_method_impl(args, env)
17
17
  end
18
18
 
19
19
  Primitive.register("super", "Not implemented.") do |args, env|
20
- Lisp::ClassObject::super_impl(args, env)
20
+ Lisp::PrimClassObject::super_impl(args, env)
21
21
  end
22
22
 
23
23
  end
24
24
 
25
25
 
26
26
  def self.extend_impl(args, env)
27
- return Lisp::Debug.process_error("'extend' requires 2 arguments.", env) if args.length != 2
28
-
29
- class_name = args.car.evaluate(env)
27
+ class_name = args.car
30
28
  return Lisp::Debug.process_error("'extend' requires a name as it's first argument.", env) unless class_name.string? || class_name.symbol?
31
29
  super_class = Object.const_get(class_name.to_s)
32
30
  return Lisp::Debug.process_error("'extend' requires the name of an existing class as it's first argument.", env) if super_class.nil?
33
31
 
34
- new_class_name = args.cadr.evaluate(env)
32
+ new_class_name = args.cadr
35
33
  return Lisp::Debug.process_error("'extend' requires a name as it's second argument.", env) unless new_class_name.string? || new_class_name.symbol?
36
34
  new_class = Class.new(super_class)
37
- return Lisp::Debug.process_error("'extend' requires the name of a new (i.e. nonexistant) class as it's second argument.", env) if Object.const_defined?(new_class_name.to_s)
38
-
35
+ return Lisp::Debug.process_error("'extend' requires the name of a new (i.e. nonexistant) class as it's second argument.", env) if Lisp.const_defined?(new_class_name.to_s)
39
36
  Object.const_set(new_class_name.to_s, new_class)
40
37
  ClassObject.with_class(new_class)
41
38
  end
@@ -77,23 +74,22 @@ module Lisp
77
74
 
78
75
 
79
76
  def self.add_method_impl(args, env)
80
- return Lisp::Debug.process_error("'add-method' requires 3 arguments.", env) if args.length != 3
81
- class_name = args.car.evaluate(env)
77
+ class_name = args.car
82
78
  return Lisp::Debug.process_error("'add-method' requires a class name as it's first argument.", env) unless class_name.string? || class_name.symbol?
83
79
  target_class = Object.const_get(class_name.to_s)
84
80
  return Lisp::Debug.process_error("'add-method' requires the name of an existing class.", env) if target_class.nil?
85
81
 
86
- method_name = args.cadr.evaluate(env)
82
+ method_name = args.cadr
87
83
  return Lisp::Debug.process_error("'add-method' requires a method name as it's second argument.", env) unless class_name.string? || class_name.symbol?
88
84
 
89
- body = args.caddr.evaluate(env)
85
+ body = args.caddr
90
86
  return Lisp::Debug.process_error("'add-method' requires a function as it's third argument.", env) unless body.function?
91
87
 
92
88
  target_class.send(:define_method, method_name.to_s) do |*args|
93
- local_env = Lisp::EnvironmentFrame.extending(env)
89
+ local_env = Lisp::EnvironmentFrame.extending(env, "#{class_name.to_s}-#{method_name.to_s}")
94
90
  local_env.bind_locally(Symbol.named("self"), Lisp::NativeObject.with_value(self))
95
91
  processed_args = args.map {|a| Lisp::ClassObject.convert_to_lisp(a)}
96
- Lisp::ClassObject.convert_to_ruby(body.apply_to(Lisp::ConsCell.array_to_list(processed_args), local_env), local_env)
92
+ Lisp::PrimClassObject.convert_to_ruby(body.apply_to(Lisp::ConsCell.array_to_list(processed_args), local_env), local_env)
97
93
  end
98
94
  Lisp::String.with_value("OK")
99
95
  end
@@ -108,55 +104,6 @@ module Lisp
108
104
  Lisp::String.with_value("NOT IMPLEMENTED")
109
105
  end
110
106
 
111
-
112
- def self.new_instance
113
- self.new(@value.alloc.init)
114
- end
115
-
116
-
117
- def self.with_class(c)
118
- self.new(c)
119
- end
120
-
121
-
122
- def initialize(c)
123
- @value = c
124
- end
125
-
126
-
127
- def with_value(&block)
128
- block.call(@value)
129
- end
130
-
131
-
132
- def class?
133
- true
134
- end
135
-
136
-
137
- def type
138
- :class
139
- end
140
-
141
-
142
- def native_type
143
- @value.class
144
- end
145
-
146
-
147
- def to_s
148
- "<a class: #{@value.name}>"
149
- end
150
-
151
-
152
- def true?
153
- @value != nil
154
- end
155
-
156
-
157
- def false?
158
- @value == nil
159
- end
160
-
161
107
  end
108
+
162
109
  end
@@ -0,0 +1,203 @@
1
+ module Lisp
2
+
3
+ class PrimEnvironment
4
+
5
+ def self.register
6
+ Primitive.register("environment?", "1") {|args, env| Lisp::PrimEnvironment::environmentp_impl(args, env)}
7
+ Primitive.register("environment-has-parent?", "1") {|args, env| Lisp::PrimEnvironment::environment_parentp_impl(args, env) }
8
+ Primitive.register("environment-bound-names", "1") {|args, env| Lisp::PrimEnvironment::environment_bound_names_impl(args, env) }
9
+ Primitive.register("environment-macro-names", "1") {|args, env| Lisp::PrimEnvironment::environment_macro_names_impl(args, env) }
10
+ Primitive.register("environment-bindings", "1") {|args, env| Lisp::PrimEnvironment::environment_bindings_impl(args, env) }
11
+ Primitive.register("environment-reference-type", "2") {|args, env| Lisp::PrimEnvironment::environment_reference_type_impl(args, env) }
12
+ Primitive.register("environment-bound?", "2") {|args, env| Lisp::PrimEnvironment::environment_boundp_impl(args, env) }
13
+ Primitive.register("environment-assigned?", "2") {|args, env| Lisp::PrimEnvironment::environment_assignedp_impl(args, env) }
14
+ Primitive.register("environment-lookup", "2") {|args, env| Lisp::PrimEnvironment::environment_lookup_impl(args, env) }
15
+ Primitive.register("environment-lookup-macro", "2") {|args, env| Lisp::PrimEnvironment::environment_lookup_macro_impl(args, env) }
16
+ Primitive.register("environment-assignable?", "2") {|args, env| Lisp::PrimEnvironment::environment_assignablep_impl(args, env) }
17
+ Primitive.register("environment-assign!", "3") {|args, env| Lisp::PrimEnvironment::environment_assign_bang_impl(args, env) }
18
+ Primitive.register("environment-definable?", "2") {|args, env| Lisp::PrimEnvironment::environment_definablep_impl(args, env) }
19
+ Primitive.register("environment-define", "3") {|args, env| Lisp::PrimEnvironment::environment_define_impl(args, env) }
20
+ Primitive.register("the-environment", "0") {|args, env| Lisp::PrimEnvironment::the_environment_impl(args, env) }
21
+ Primitive.register("procedure-environment", "1") {|args, env| Lisp::PrimEnvironment::procedure_environment_impl(args, env) }
22
+ Primitive.register("environment-parent", "1") {|args, env| Lisp::PrimEnvironment::environment_parent_impl(args, env) }
23
+ Primitive.register("system-global-environment", "0") {|args, env| Lisp::PrimEnvironment::system_global_environment_impl(args, env) }
24
+ Primitive.register("make-top-level-environment", "1|2|3") {|args, env| Lisp::PrimEnvironment::make_top_level_environment_impl(args, env) }
25
+ Primitive.register("find-top-level-environment", "1") {|args, env| Lisp::PrimEnvironment::find_top_level_environment_impl(args, env) }
26
+ end
27
+
28
+
29
+ def self.environmentp_impl(args, env)
30
+ Lisp::Boolean.with_value(args.car.environment?)
31
+ end
32
+
33
+
34
+ def self.environment_parentp_impl(args, env)
35
+ return Lisp::Debug.process_error("environment-has-parent? requires an environment for it's argument, received: #{args.car}", env) unless args.car.environment?
36
+ Lisp::Boolean.with_value(!args.car.value.parent.nil?)
37
+ end
38
+
39
+
40
+ def self.environment_bound_names_impl(args, env)
41
+ return Lisp::Debug.process_error("environment-bound-names requires an environment for it's argument, received: #{args.car}", env) unless args.car.environment?
42
+ e = args.car.value
43
+ Lisp::ConsCell.array_to_list(e.bound_names)
44
+ end
45
+
46
+
47
+ def self.environment_macro_names_impl(args, env)
48
+ return Lisp::Debug.process_error("environment-macro-names requires an environment for it's argument, received: #{args.car}", env) unless args.car.environment?
49
+ e = args.car.value
50
+ Lisp::ConsCell.array_to_list(e.bound_values.select {|v| v.macro?})
51
+ end
52
+
53
+
54
+ def self.environment_bindings_impl(args, env)
55
+ return Lisp::Debug.process_error("environment-bindings requires an environment for it's argument, received: #{args.car}", env) unless args.car.environment?
56
+ Lisp::ConsCell.array_to_list(args.car.value.bindings.map { |b| Lisp::ConsCell.array_to_list(b.value.nil? ? [b.symbol] : [b.symbol, b.value]) })
57
+ end
58
+
59
+
60
+ def self.environment_reference_type_impl(args, env)
61
+ return Lisp::Debug.process_error("environment-reference-type requires an environment for it's first argument, received: #{args.car}", env) unless args.car.environment?
62
+ return Lisp::Debug.process_error("environment-reference-type requires a symbol for it's second argument, received: #{args.cadr}", env) unless args.cadr.symbol?
63
+ b = args.car.value.binding_for(args.cadr.value)
64
+ return Lisp::Symbol.named("unbound") if b.nil?
65
+ return Lisp::Symbol.named("unassigned") if b.value.nil?
66
+ return Lisp::Symbol.named("macro") if b.value.binding?
67
+ Lisp::Symbol.named("normal")
68
+ end
69
+
70
+
71
+ def self.environment_boundp_impl(args, env)
72
+ return Lisp::Debug.process_error("environment-bound? requires an environment for it's first argument, received: #{args.car}", env) unless args.car.environment?
73
+ return Lisp::Debug.process_error("environment-bound? requires a symbol for it's second argument, received: #{args.cadr}", env) unless args.cadr.symbol?
74
+ Lisp::Boolean.with_value(args.car.value.name_bound_locally?(args.cadr.name))
75
+ end
76
+
77
+
78
+ def self.environment_assignedp_impl(args, env)
79
+ return Lisp::Debug.process_error("environment-assigned? requires an environment for it's first argument, received: #{args.car}", env) unless args.car.environment?
80
+ return Lisp::Debug.process_error("environment-assigned? requires a symbol for it's second argument, received: #{args.cadr}", env) unless args.cadr.symbol?
81
+ return Lisp::Debug.process_error("environment-assigned?: #{args.cadr.to_s} is unbound", env) unless args.car.value.name_bound_locally?(args.cadr.name)
82
+ b = args.car.value.local_binding_for(args.cadr)
83
+ return Lisp::Debug.process_error("environment-assigned?: #{args.cadr.to_s} is bound to a macro", env) if b.value.macro?
84
+ Lisp::Boolean.with_value(!b.value.nil?)
85
+ end
86
+
87
+
88
+ def self.environment_lookup_impl(args, env)
89
+ return Lisp::Debug.process_error("environment-lookup requires an environment for it's first argument, received: #{args.car}", env) unless args.car.environment?
90
+ return Lisp::Debug.process_error("environment-lookup requires a symbol for it's second argument, received: #{args.cadr}", env) unless args.cadr.symbol?
91
+ return Lisp::Debug.process_error("environment-lookup: #{args.cadr.to_s} is unbound", env) unless args.car.value.name_bound_locally?(args.cadr.name)
92
+ b = args.car.value.local_binding_for(args.cadr)
93
+ return Lisp::Debug.process_error("environment-lookup: #{args.cadr.to_s} is unassigned", env) if b.value.nil?
94
+ return Lisp::Debug.process_error("environment-lookup: #{args.cadr.to_s} is bound to a macro", env) if b.value.macro?
95
+ b.value
96
+ end
97
+
98
+
99
+ def self.environment_lookup_macro_impl(args, env)
100
+ return Lisp::Debug.process_error("environment-lookup-macro requires an environment for it's first argument, received: #{args.car}", env) unless args.car.environment?
101
+ return Lisp::Debug.process_error("environment-lookup-macro requires a symbol for it's second argument, received: #{args.cadr}", env) unless args.cadr.symbol?
102
+ return Lisp::Debug.process_error("environment-lookup-macro: #{args.cadr.to_s} is unbound", env) unless args.car.value.name_bound_locally?(args.cadr)
103
+ b = args.car.value.local_binding_for(args.cadr)
104
+ return Lisp::Debug.process_error("environment-lookup-macro: #{args.cadr.to_s} is unassigned", env) if b.value.nil?
105
+ return Lisp::Debug.process_error("environment-lookup-macro: #{args.cadr.to_s} is bound to a macro", env) if b.value.macro?
106
+ b.value
107
+ end
108
+
109
+
110
+ def self.environment_assignablep_impl(args, env)
111
+ return Lisp::Debug.process_error("environment-assignable? requires an environment for it's first argument, received: #{args.car}", env) unless args.car.environment?
112
+ return Lisp::Debug.process_error("environment-assignable? requires a symbol for it's second argument, received: #{args.cadr}", env) unless args.cadr.symbol?
113
+ local_env = args.car.value
114
+ binding = local_env.binding_for(args.cadr)
115
+ Lisp::Boolean.with_value(!binding.nil?)
116
+ end
117
+
118
+
119
+ def self.environment_assign_bang_impl_impl(args, env)
120
+ return Lisp::Debug.process_error("environment-assign! requires an environment for it's first argument, received: #{args.car}", env) unless args.car.environment?
121
+ return Lisp::Debug.process_error("environment-assign! requires a symbol for it's second argument, received: #{args.cadr}", env) unless args.cadr.symbol?
122
+ local_env = args.car.value
123
+ binding = local_env.binding_for(args.cadr)
124
+ binding.value = args.caddr unless binding.nil?
125
+ end
126
+
127
+
128
+ def self.environment_definablep_impl(args, env)
129
+ return Lisp::Debug.process_error("environment-definable?requires an environment for it's first argument, received: #{args.car}", env) unless args.car.environment?
130
+ return Lisp::Debug.process_error("environment-definable? requires a symbol for it's second argument, received: #{args.cadr}", env) unless args.cadr.symbol?
131
+ Lisp::TRUE
132
+ end
133
+
134
+
135
+ def self.environment_define_impl(args, env)
136
+ return Lisp::Debug.process_error("environment-define requires an environment for it's first argument, received: #{args.car}", env) unless args.car.environment?
137
+ return Lisp::Debug.process_error("environment-define requires a symbol for it's second argument, received: #{args.cadr}", env) unless args.cadr.symbol?
138
+ args.car.value.bind_locally(args.cadr, args.caddr)
139
+ Lisp::TRUE
140
+ end
141
+
142
+
143
+ def self.the_environment_impl(args, env)
144
+ Lisp::Environment.with_value(env) if env == Lisp.EnvironmentFrame.global || env.parent == Lisp.EnvironmentFrame.global
145
+ Lisp::Debug.process_error("the-environment can only be called from a top-level environment", env)
146
+ end
147
+
148
+
149
+ def self.procedure_environment_impl(args, env)
150
+ Lisp::Debug.process_error("procedure-environment requires a user written function as it's argument", env) unless args.car.function?
151
+ Lisp::Environment.with_value(args.car.env)
152
+ end
153
+
154
+
155
+ def self.environment_parent_impl(args, env)
156
+ return Lisp::Debug.process_error("environment-parent requires an environment for it's argument, received: #{args.car}", env) unless args.car.environment?
157
+ e = args.car.value
158
+ e.parent.nil? ? nil : Lisp::Environment.with_value(e.parent)
159
+ end
160
+
161
+
162
+ def self.system_global_environment_impl(args, env)
163
+ Lisp::Environment.with_value(Lisp::EnvironmentFrame.global)
164
+ end
165
+
166
+
167
+ def self.make_top_level_environment_impl(args, env)
168
+ if args.car.string?
169
+ name = args.car.value
170
+ args = args.cdr
171
+ else
172
+ name = "anonymous top level"
173
+ end
174
+
175
+ new_env = Lisp::EnvironmentFrame.extending(Lisp::EnvironmentFrame.global, name)
176
+ if args.length == 1
177
+ return Lisp::Debug.process_error("make-top-level-environment expects binding names to be a list", env) unless args.car.list?
178
+ args.to_a.map do |a|
179
+ return Lisp::Debug.process_error("make-top-level-environment expects each binding name to be a symbol", env) unless a.car.symbol?
180
+ new_env.bind_locally_to(a.car, nil)
181
+ end
182
+ elsif args.length == 2
183
+ return Lisp::Debug.process_error("make-top-level-environment expects binding names to be a list", env) unless args.car.list?
184
+ return Lisp::Debug.process_error("make-top-level-environment expects binding values to be a list", env) unless args.cadr.list?
185
+ return Lisp::Debug.process_error("make-top-level-environment expects binding name and value lists to be the same length", env) if args.car.length != args.cadr.length
186
+ args.car.zip(args.cadr).map do |name, value|
187
+ return Lisp::Debug.process_error("make-top-level-environment expects each binding name to be a symbol", env) unless name.symbol?
188
+ new_env.bind_locally_to(name, value)
189
+ end
190
+ end
191
+ return Lisp::Environment.with_value(new_env)
192
+ end
193
+
194
+
195
+ def self.find_top_level_environment_impl(args, env)
196
+ return Lisp::Debug.process_error("find-top-level-environment requires a symbol or sting environment name, received: #{args.cadr}", env) unless args.cadr.symbol? || args.cadr.string
197
+ e = Lisp::TopLevelEnvironments[args.car.to_s]
198
+ return e.nil? ? nil : Lisp::Environment.with_value(e)
199
+ end
200
+
201
+ end
202
+
203
+ end