rubymotionlisp 0.1.3

Sign up to get free protection for your applications and to get access to all the features.
@@ -0,0 +1,383 @@
1
+ # -*- coding: utf-8 -*-
2
+ module Lisp
3
+
4
+ class Character < Atom
5
+
6
+ def self.register
7
+ Primitive.register("char->name", "(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::Character::char_name_impl(args, env)
9
+ end
10
+
11
+ Primitive.register("name->char", "(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::Character::name_char_impl(args, env)
13
+ end
14
+
15
+ Primitive.register("char=?", "(char=? char1 char2)\n\nReturn whether char1 and char2 are the same") do |args, env|
16
+ Lisp::Character::char_eq_impl(args, env)
17
+ end
18
+
19
+ Primitive.register("char<?", "(char<? char1 char2)\n\nReturn whether char1 is less than char2") do |args, env|
20
+ Lisp::Character::char_lt_impl(args, env)
21
+ end
22
+
23
+ Primitive.register("char>?", "(char>? char1 char2)\n\nReturn whether char1 is greater than char2") do |args, env|
24
+ Lisp::Character::char_gt_impl(args, env)
25
+ end
26
+
27
+ Primitive.register("char<=?", "(char<=? char1 char2)\n\nReturn whether char1 is less than or equal to char2") do |args, env|
28
+ Lisp::Character::char_lteq_impl(args, env)
29
+ end
30
+
31
+ Primitive.register("char>=?", "(char>=? char1 char2)\n\nReturn whether char1 is greater than or equal to char2") do |args, env|
32
+ Lisp::Character::char_gteq_impl(args, env)
33
+ end
34
+
35
+ Primitive.register("char-ci=?", "(char=? char1 char2)\n\nReturn whether char1 is equal to char2, ignoring case") do |args, env|
36
+ Lisp::Character::char_ci_eq_impl(args, env)
37
+ end
38
+
39
+ Primitive.register("char-ci<?", "(char=? char1 char2)\n\nReturn whether char1 is less than char2, ignoring case") do |args, env|
40
+ Lisp::Character::char_ci_lt_impl(args, env)
41
+ end
42
+
43
+ Primitive.register("char-ci>?", "(char=? char1 char2)\n\nReturn whether char1 is greater than char2, ignoring case") do |args, env|
44
+ Lisp::Character::char_ci_gt_impl(args, env)
45
+ end
46
+
47
+ Primitive.register("char-ci<=?", "(char=? char1 char2)\n\nReturn whether char1 is less than or equal to char2, ignoring case") do |args, env|
48
+ Lisp::Character::char_ci_lteq_impl(args, env)
49
+ end
50
+
51
+ Primitive.register("char-ci>=?", "(char=? char1 char2)\n\nReturn whether char1 is greater than orequal to char2, ignoring case") do |args, env|
52
+ Lisp::Character::char_ci_gteq_impl(args, env)
53
+ end
54
+
55
+ Primitive.register("char?", "(char? sexpr)\n\nReturns #t if object is a character; otherwise returns #f.") do |args, env|
56
+ Lisp::Character::charp_impl(args, env)
57
+ end
58
+
59
+ Primitive.register("char-upcase", "(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::Character::char_upcase_impl(args, env)
61
+ end
62
+
63
+ Primitive.register("char-downcase", "(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::Character::char_downcase_impl(args, env)
65
+ end
66
+
67
+ Primitive.register("char->digit", "(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::Character::char_digit_impl(args, env)
69
+ end
70
+
71
+ Primitive.register("digit->char", "(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::Character::digit_char_impl(args, env)
73
+ end
74
+
75
+ Primitive.register("char->integer", "(char->integer char)\n\nchar->integer returns the character code representation for char.") do |args, env|
76
+ Lisp::Character::char_int_impl(args, env)
77
+ end
78
+
79
+ Primitive.register("integer->char", "(integer->char k)\n\ninteger->char returns the character whose character code representation is k.") do |args, env|
80
+ Lisp::Character::int_char_impl(args, env)
81
+ end
82
+ end
83
+
84
+
85
+ def self.find_character_for_chr(ch)
86
+ @@character_constants.each_value {|v| return v if v.value == ch}
87
+ return @@character_constants[ch] = Lisp::Character.new(ch)
88
+ end
89
+
90
+
91
+ def self.find_character_for_name(n)
92
+ return @@character_constants[n] if @@character_constants.has_key?(n)
93
+ if n.length == 1
94
+ ch = self.new(n[0])
95
+ return @@character_constants[n] = ch
96
+ end
97
+ nil
98
+ end
99
+
100
+
101
+ def self.char_name_impl(args, env)
102
+ raise "char->name requires a single argument, found #{args.length}" unless args.length == 1
103
+ char = args.car.evaluate(env)
104
+ raise "char->name requires a character argument" unless char.character?
105
+ kv = @@character_constants.rassoc(char)
106
+ return Lisp::String.with_value(kv[0]) unless kv.nil?
107
+ raise "char->name was passed an invalid character"
108
+ end
109
+
110
+
111
+ def self.name_char_impl(args, env)
112
+ raise "name->char requires a single argument, found #{args.length}" unless args.length == 1
113
+ name = args.car.evaluate(env)
114
+ raise "name->char requires a string argument" unless name.string?
115
+ ch = find_character_for_name(name.value)
116
+ return ch unless ch.nil?
117
+ raise "There is no character with the name #{name}"
118
+ end
119
+
120
+
121
+ def self.get_one_character_arg(func, args, env)
122
+ raise "#{func} requires a character argument, found no args" unless args.length >= 1
123
+ char1 = args.car.evaluate(env)
124
+ raise "#{func} requires a character argument, found #{char1}" unless char1.character?
125
+ return char1
126
+ end
127
+
128
+
129
+ def self.get_two_character_args(func, args, env)
130
+ raise "#{func} requires two arguments, found #{args.length}" unless args.length == 2
131
+ char1 = args.car.evaluate(env)
132
+ raise "#{func} requires character arguments, found #{char1}" unless char1.character?
133
+ char2 = args.cadr.evaluate(env)
134
+ raise "#{func} requires character arguments, found #{char2}" unless char2.character?
135
+ return [char1, char2]
136
+ end
137
+
138
+
139
+ def self.char_eq_impl(args, env)
140
+ char1, char2 = get_two_character_args("char=?", args, env)
141
+ Lisp::Boolean.with_value(char1.value == char2.value)
142
+ end
143
+
144
+
145
+ def self.char_lt_impl(args, env)
146
+ char1, char2 = get_two_character_args("char<?", args, env)
147
+ Lisp::Boolean.with_value(char1.value < char2.value)
148
+ end
149
+
150
+
151
+ def self.char_gt_impl(args, env)
152
+ char1, char2 = get_two_character_args("char>?", args, env)
153
+ Lisp::Boolean.with_value(char1.value > char2.value)
154
+ end
155
+
156
+
157
+ def self.char_lteq_impl(args, env)
158
+ char1, char2 = get_two_character_args("char<=?", args, env)
159
+ Lisp::Boolean.with_value(char1.value <= char2.value)
160
+ end
161
+
162
+
163
+ def self.char_gteq_impl(args, env)
164
+ char1, char2 = get_two_character_args("char>=?", args, env)
165
+ Lisp::Boolean.with_value(char1.value >= char2.value)
166
+ end
167
+
168
+
169
+ def self.char_ci_eq_impl(args, env)
170
+ char1, char2 = get_two_character_args("char-ci=?", args, env)
171
+ Lisp::Boolean.with_value(char1.value.downcase == char2.value.downcase)
172
+ end
173
+
174
+
175
+ def self.char_ci_lt_impl(args, env)
176
+ char1, char2 = get_two_character_args("char-ci<?", args, env)
177
+ Lisp::Boolean.with_value(char1.value.downcase < char2.value.downcase)
178
+ end
179
+
180
+
181
+ def self.char_ci_gt_impl(args, env)
182
+ char1, char2 = get_two_character_args("char-ci>?", args, env)
183
+ Lisp::Boolean.with_value(char1.value.downcase > char2.value.downcase)
184
+ end
185
+
186
+
187
+ def self.char_ci_lteq_impl(args, env)
188
+ char1, char2 = get_two_character_args("char-ci<=?", args, env)
189
+ Lisp::Boolean.with_value(char1.value.downcase <= char2.value.downcase)
190
+ end
191
+
192
+
193
+ def self.char_ci_gteq_impl(args, env)
194
+ char1, char2 = get_two_character_args("char-ci>=?", args, env)
195
+ Lisp::Boolean.with_value(char1.value.downcase >= char2.value.downcase)
196
+ end
197
+
198
+
199
+ def self.charp_impl(args, env)
200
+ raise "char->name requires a single argument, found #{args.length}" unless args.length == 1
201
+ char = args.car.evaluate(env)
202
+ Lisp::Boolean.with_value(char.character?)
203
+ end
204
+
205
+
206
+ def self.char_upcase_impl(args, env)
207
+ char = get_one_character_arg("char->digit", args, env)
208
+ find_character_for_chr(char.value.upcase)
209
+ end
210
+
211
+
212
+ def self.char_downcase_impl(args, env)
213
+ char = get_one_character_arg("char->digit", args, env)
214
+ find_character_for_chr(char.value.downcase)
215
+ end
216
+
217
+
218
+ def self.char_digit_impl(args, env)
219
+ char = get_one_character_arg("char->digit", args, env)
220
+ base = if args.length == 1
221
+ 10
222
+ else
223
+ b = args.cadr.evaluate(env)
224
+ raise "Base for char->digit has to be an integer" unless b.integer?
225
+ raise "Base for char->digit has to be between 2 and 36" unless b.value >=2 && b.value <= 36
226
+ b.value
227
+ end
228
+ ch = char.value.upcase
229
+ value = case ch
230
+ when /[0-9]/
231
+ ch[0].ord - 48
232
+ when /[A-Z]/
233
+ 10 + ch[0].ord - 65
234
+ else
235
+ -1
236
+ end
237
+ if value == -1
238
+ Lisp::FALSE
239
+ elsif value >= base
240
+ Lisp::FALSE
241
+ else
242
+ Lisp::Number.with_value(value)
243
+ end
244
+ end
245
+
246
+
247
+ def self.digit_char_impl(args, env)
248
+ d = args.car.evaluate(env)
249
+ raise "Digit value for digit->char has to be an integer" unless d.integer?
250
+ base = if args.length == 1
251
+ 10
252
+ else
253
+ b = args.cadr.evaluate(env)
254
+ raise "Base for char->digit has to be an integer" unless b.integer?
255
+ raise "Base for char->digit has to be between 2 and 36" unless b.value >=2 && b.value <= 36
256
+ b.value
257
+ end
258
+ val = d.value
259
+ return Lisp::FALSE if val < 0 || val >= base
260
+ find_character_for_chr((((val < 10) ? 48 : 55) + val).chr)
261
+ end
262
+
263
+
264
+ def self.char_int_impl(args, env)
265
+ char = get_one_character_arg("char->int", args, env)
266
+ Lisp::Number.with_value(char.value.ord)
267
+ end
268
+
269
+
270
+ def self.int_char_impl(args, env)
271
+ i = args.car.evaluate(env)
272
+ raise "Integer value for int->char has to be an integer" unless i.integer?
273
+ find_character_for_chr(i.value.chr)
274
+ end
275
+
276
+
277
+ def initialize(n)
278
+ @value = n
279
+ end
280
+
281
+
282
+ def set!(n)
283
+ @value = n
284
+ end
285
+
286
+
287
+ def character?
288
+ true
289
+ end
290
+
291
+
292
+ def type
293
+ :character
294
+ end
295
+
296
+
297
+ def to_s
298
+ @value
299
+ end
300
+
301
+
302
+ def to_sym
303
+ @value.to_sym
304
+ end
305
+
306
+
307
+ def find_charactername
308
+ @@character_constants.each {|k, v| return k if v == self}
309
+ "UNKNOWN"
310
+ end
311
+
312
+
313
+ def print_string
314
+ return "#\\#{find_charactername}"
315
+ end
316
+
317
+
318
+ @@character_constants = {}
319
+ @@character_constants["altmode"] = Lisp::Character.new("\e")
320
+ @@character_constants["backnext"] = Lisp::Character.new("\x1F")
321
+ @@character_constants["backspace"] = Lisp::Character.new("\b")
322
+ @@character_constants["call"] = Lisp::Character.new("\x1A")
323
+ @@character_constants["linefeed"] = Lisp::Character.new("\n")
324
+ @@character_constants["newline"] = Lisp::Character.new("\n")
325
+ @@character_constants["page"] = Lisp::Character.new("\f")
326
+ @@character_constants["return"] = Lisp::Character.new("\r")
327
+ @@character_constants["rubout"] = Lisp::Character.new("\x7F")
328
+ @@character_constants["space"] = Lisp::Character.new(" ")
329
+ @@character_constants["tab"] = Lisp::Character.new("\t")
330
+ @@character_constants["NUL"] = Lisp::Character.new("\x00")
331
+ @@character_constants["SOH"] = Lisp::Character.new("\x01")
332
+ @@character_constants["STX"] = Lisp::Character.new("\x02")
333
+ @@character_constants["ETX"] = Lisp::Character.new("\x03")
334
+ @@character_constants["EOT"] = Lisp::Character.new("\x04")
335
+ @@character_constants["ENQ"] = Lisp::Character.new("\x05")
336
+ @@character_constants["ACK"] = Lisp::Character.new("\x06")
337
+ @@character_constants["BEL"] = Lisp::Character.new("\x07")
338
+ @@character_constants["BS"] = Lisp::Character.new("\x08")
339
+ @@character_constants["HT"] = Lisp::Character.new("\x09")
340
+ @@character_constants["LF"] = Lisp::Character.new("\x0A")
341
+ @@character_constants["VT"] = Lisp::Character.new("\x0B")
342
+ @@character_constants["FF"] = Lisp::Character.new("\x0C")
343
+ @@character_constants["CR"] = Lisp::Character.new("\x0D")
344
+ @@character_constants["SO"] = Lisp::Character.new("\x0E")
345
+ @@character_constants["SI"] = Lisp::Character.new("\x0F")
346
+ @@character_constants["DLE"] = Lisp::Character.new("\x10")
347
+ @@character_constants["DC1"] = Lisp::Character.new("\x11")
348
+ @@character_constants["DC2"] = Lisp::Character.new("\x12")
349
+ @@character_constants["DC3"] = Lisp::Character.new("\x13")
350
+ @@character_constants["DC4"] = Lisp::Character.new("\x14")
351
+ @@character_constants["NAK"] = Lisp::Character.new("\x15")
352
+ @@character_constants["SYN"] = Lisp::Character.new("\x16")
353
+ @@character_constants["ETB"] = Lisp::Character.new("\x17")
354
+ @@character_constants["CAN"] = Lisp::Character.new("\x18")
355
+ @@character_constants["EM"] = Lisp::Character.new("\x19")
356
+ @@character_constants["SUB"] = Lisp::Character.new("\x1A")
357
+ @@character_constants["ESC"] = Lisp::Character.new("\x1B")
358
+ @@character_constants["FS"] = Lisp::Character.new("\x1C")
359
+ @@character_constants["GS"] = Lisp::Character.new("\x1D")
360
+ @@character_constants["RS"] = Lisp::Character.new("\x1E")
361
+ @@character_constants["US"] = Lisp::Character.new("\x1F")
362
+ @@character_constants["DEL"] = Lisp::Character.new("\x7F")
363
+
364
+
365
+ def self.with_value(n)
366
+ if n.length == 1
367
+ ch = find_character_for_chr(n[0])
368
+ return ch unless ch.nil?
369
+ ch = self.new(n[0])
370
+ @@character_constants[n] = ch
371
+ ch
372
+ elsif @@character_constants.has_key?(n)
373
+ @@character_constants[n]
374
+ elsif n[0..1] == "U+"
375
+ find_character_for_chr(n[2..-1].to_i(16).chr)
376
+ else
377
+ raise "Invalid character name: #{n}"
378
+ end
379
+ end
380
+
381
+ end
382
+
383
+ end
@@ -0,0 +1,255 @@
1
+ module Lisp
2
+
3
+ class ConsCell < Object
4
+ include Enumerable
5
+ attr_reader :car, :cdr
6
+
7
+ def self.cons(a=nil, b=nil)
8
+ ConsCell.new(a, b)
9
+ end
10
+
11
+ def initialize(car=nil, cdr=nil)
12
+ @car = car
13
+ @cdr = cdr
14
+ end
15
+
16
+ def value
17
+ self
18
+ end
19
+
20
+ def set_car!(d)
21
+ @car = d
22
+ end
23
+
24
+ def lisp_object?
25
+ true
26
+ end
27
+
28
+ def set_cdr!(d)
29
+ @cdr = d
30
+ end
31
+
32
+
33
+ def set_nth!(n, d)
34
+ c = self
35
+ (n-1).times {|i| c = c.cdr}
36
+ c.set_car!(d)
37
+ end
38
+
39
+
40
+ def empty?
41
+ @car.nil? && @cdr.nil?
42
+ end
43
+
44
+ def string?
45
+ false
46
+ end
47
+
48
+ def character?
49
+ false
50
+ end
51
+
52
+ def number?
53
+ false
54
+ end
55
+
56
+ def positive?
57
+ false
58
+ end
59
+
60
+ def zero?
61
+ false
62
+ end
63
+
64
+ def negative?
65
+ false
66
+ end
67
+
68
+ def symbol?
69
+ false
70
+ end
71
+
72
+ def primitive?
73
+ false
74
+ end
75
+
76
+ def special?
77
+ false
78
+ end
79
+
80
+ def function?
81
+ false
82
+ end
83
+
84
+ def macro?
85
+ false
86
+ end
87
+
88
+ def pair?
89
+ true
90
+ end
91
+
92
+ def list?
93
+ true
94
+ end
95
+
96
+ def alist?
97
+ false
98
+ end
99
+
100
+ def frame?
101
+ false
102
+ end
103
+
104
+ def vector?
105
+ false
106
+ end
107
+
108
+ def eq?(sexpr)
109
+ return false unless sexpr.pair?
110
+ (@car == sexpr.car || @car.eq?(sexpr.car)) && (@cdr == sexpr.cdr || @cdr.eq?(sexpr.cdr))
111
+ end
112
+
113
+ def type
114
+ :pair
115
+ end
116
+
117
+ def to_s_helper
118
+ return "#{@car.to_s}" if @cdr.nil?
119
+ return "#{@car.to_s} . #{@cdr.to_s}" unless @cdr.pair?
120
+ "#{@car.to_s} #{@cdr.to_s_helper}"
121
+ end
122
+
123
+ def to_s
124
+ return "()" if self.empty?
125
+ return "'#{@cdr.car.to_s}" if @car.symbol? && @car.name == "quote"
126
+ return "(#{@car.to_s} . #{@cdr.to_s})" if !@cdr.nil? && !@cdr.pair?
127
+ return "(#{self.to_s_helper})"
128
+ end
129
+
130
+ def print_string_helper
131
+ @cdr.nil? ? "#{@car.print_string}" : "#{@car.print_string} #{@cdr.print_string_helper}"
132
+ end
133
+
134
+ def print_string
135
+ return "()" if self.empty?
136
+ return "'#{@cdr.car.print_string}" if @car.symbol? && @car.name == "quote"
137
+ return "(#{@car.print_string} . #{@cdr.print_string})" if !@cdr.nil? && !@cdr.pair?
138
+ return "(#{self.print_string_helper})"
139
+ end
140
+
141
+ def to_a
142
+ a = []
143
+ c = self
144
+ until c.nil?
145
+ a << c.car()
146
+ c = c.cdr
147
+ end
148
+ a
149
+ end
150
+
151
+ def each &block
152
+ c = self
153
+ if self.length > 0
154
+ until c.nil?
155
+ yield c.car
156
+ c = c.cdr
157
+ end
158
+ end
159
+ end
160
+
161
+ def self.array_to_list(cells, tail=nil)
162
+ return tail if cells.empty?
163
+ head = ConsCell.new
164
+ last_cell = head
165
+ cells.each do |d|
166
+ new_cell = self.cons(d, nil)
167
+ last_cell.set_cdr!(new_cell)
168
+ last_cell = new_cell
169
+ end
170
+ last_cell.set_cdr!(tail)
171
+ head.cdr
172
+ end
173
+
174
+ def traverse(path)
175
+ return self if path.empty?
176
+ next_cell = (path[0] == ?a) ? @car : @cdr
177
+ return next_cell if path.length == 1
178
+ return nil if next_cell.nil? || !next_cell.pair?
179
+ next_cell.traverse(path[1..-1])
180
+ end
181
+
182
+ def method_missing(name, *args, &block)
183
+ if name[0] == ?c && name[-1] == ?r && (name[1..-2].chars.all? {|e| "ad".include?(e)})
184
+ self.traverse(name[1..-2].reverse)
185
+ else
186
+ super
187
+ end
188
+ end
189
+
190
+ def nth(n)
191
+ c = self
192
+ (n-1).times {|i| c = c.cdr}
193
+ c.car
194
+ end
195
+
196
+ def nth_tail(n)
197
+ c = self
198
+ (n-1).times {|i| c = c.cdr}
199
+ c
200
+ end
201
+
202
+ def objc_object_or_nil(obj)
203
+ return nil unless obj.object?
204
+ return obj.value
205
+ end
206
+
207
+
208
+ def evaluate(env)
209
+ return self if empty?
210
+ func = @car.evaluate(env)
211
+ raise "There is no function or macro named #{@car}" if func.nil?
212
+ func.apply_to(@cdr, env)
213
+ end
214
+
215
+ def evaluate_each(env)
216
+ result = @car.evaluate(env)
217
+ return result if @cdr.nil?
218
+ @cdr.evaluate_each(env)
219
+ end
220
+
221
+ def length
222
+ return 0 if empty?
223
+ return 1 if @cdr.nil?
224
+ return 1 + @cdr.length
225
+ end
226
+
227
+ def true?
228
+ true
229
+ end
230
+
231
+ def false?
232
+ false
233
+ end
234
+
235
+ def quoted
236
+ Lisp::ConsCell.array_to_list([Symbol.named("quote"), self])
237
+ end
238
+
239
+ def last
240
+ c = self
241
+ while !c.cdr.nil? && c.cdr.pair? do
242
+ c = c.cdr
243
+ end
244
+ c
245
+ end
246
+
247
+ def flatten
248
+ ary = to_a.collect {|s| s.list? ? s.to_a : s}
249
+ ConsCell.array_to_list(ary.flatten)
250
+ end
251
+
252
+
253
+ end
254
+
255
+ end