1 ## experimental compiler to translate programs written in a generic
  2 ## expression-oriented language called 'lambda' into Mu
  3 
  4 # incomplete; code generator not done
  5 # potential enhancements:
  6 #   symbol table
  7 #   poor man's macros
  8 #     substitute one instruction with multiple, parameterized by inputs and products
  9 
 10 scenario convert-lambda [
 11   run [
 12     local-scope
 13     1:text/raw <- lambda-to-mu [(add a (multiply b c))]
 14     2:@:char/raw <- copy *1:text/raw
 15   ]
 16   memory-should-contain [
 17     2:array:character <- [t1 <- multiply b c
 18 result <- add a t1]
 19   ]
 20 ]
 21 
 22 def lambda-to-mu in:text -> out:text [
 23   local-scope
 24   load-inputs
 25   out <- copy 0
 26   cells:&:cell <- parse in
 27   out <- to-mu cells
 28 ]
 29 
 30 # 'parse' will turn lambda expressions into trees made of cells
 31 exclusive-container cell [
 32   atom:text
 33   pair:pair
 34 ]
 35 
 36 # printed below as < first | rest >
 37 container pair [
 38   first:&:cell
 39   rest:&:cell
 40 ]
 41 
 42 def new-atom name:text -> result:&:cell [
 43   local-scope
 44   load-inputs
 45   result <- new cell:type
 46   *result <- merge 0/tag:atom, name
 47 ]
 48 
 49 def new-pair a:&:cell, b:&:cell -> result:&:cell [
 50   local-scope
 51   load-inputs
 52   result <- new cell:type
 53   *result <- merge 1/tag:pair, a/first, b/rest
 54 ]
 55 
 56 def is-atom? x:&:cell -> result:bool [
 57   local-scope
 58   load-inputs
 59   return-unless x, 0/false
 60   _, result <- maybe-convert *x, atom:variant
 61 ]
 62 
 63 def is-pair? x:&:cell -> result:bool [
 64   local-scope
 65   load-inputs
 66   return-unless x, 0/false
 67   _, result <- maybe-convert *x, pair:variant
 68 ]
 69 
 70 scenario atom-is-not-pair [
 71   local-scope
 72   s:text <- new [a]
 73   x:&:cell <- new-atom s
 74   10:bool/raw <- is-atom? x
 75   11:bool/raw <- is-pair? x
 76   memory-should-contain [
 77     10 <- 1
 78     11 <- 0
 79   ]
 80 ]
 81 
 82 scenario pair-is-not-atom [
 83   local-scope
 84   # construct (a . nil)
 85   s:text <- new [a]
 86   x:&:cell <- new-atom s
 87   y:&:cell <- new-pair x, 0/nil
 88   10:bool/raw <- is-atom? y
 89   11:bool/raw <- is-pair? y
 90   memory-should-contain [
 91     10 <- 0
 92     11 <- 1
 93   ]
 94 ]
 95 
 96 def atom-match? x:&:cell, pat:text -> result:bool [
 97   local-scope
 98   load-inputs
 99   s:text, is-atom?:bool <- maybe-convert *x, atom:variant
100   return-unless is-atom?, 0/false
101   result <- equal pat, s
102 ]
103 
104 scenario atom-match [
105   local-scope
106   x:&:cell <- new-atom [abc]
107   10:bool/raw <- atom-match? x, [abc]
108   memory-should-contain [
109     10 <- 1
110   ]
111 ]
112 
113 def first x:&:cell -> result:&:cell [
114   local-scope
115   load-inputs
116   pair:pair, pair?:bool <- maybe-convert *x, pair:variant
117   return-unless pair?, 0/nil
118   result <- get pair, first:offset
119 ]
120 
121 def rest x:&:cell -> result:&:cell [
122   local-scope
123   load-inputs
124   pair:pair, pair?:bool <- maybe-convert *x, pair:variant
125   return-unless pair?, 0/nil
126   result <- get pair, rest:offset
127 ]
128 
129 def set-first base:&:cell, new-first:&:cell -> base:&:cell [
130   local-scope
131   load-inputs
132   pair:pair, is-pair?:bool <- maybe-convert *base, pair:variant
133   return-unless is-pair?
134   pair <- put pair, first:offset, new-first
135   *base <- merge 1/pair, pair
136 ]
137 
138 def set-rest base:&:cell, new-rest:&:cell -> base:&:cell [
139   local-scope
140   load-inputs
141   pair:pair, is-pair?:bool <- maybe-convert *base, pair:variant
142   return-unless is-pair?
143   pair <- put pair, rest:offset, new-rest
144   *base <- merge 1/pair, pair
145 ]
146 
147 scenario cell-operations-on-atom [
148   local-scope
149   s:text <- new [a]
150   x:&:cell <- new-atom s
151   10:&:cell/raw <- first x
152   11:&:cell/raw <- rest x
153   memory-should-contain [
154     10 <- 0  # first is nil
155     11 <- 0  # rest is nil
156   ]
157 ]
158 
159 scenario cell-operations-on-pair [
160   local-scope
161   # construct (a . nil)
162   s:text <- new [a]
163   x:&:cell <- new-atom s
164   y:&:cell <- new-pair x, 0/nil
165   x2:&:cell <- first y
166   10:bool/raw <- equal x, x2
167   11:&:cell/raw <- rest y
168   memory-should-contain [
169     10 <- 1  # first is correct
170     11 <- 0  # rest is nil
171   ]
172 ]
173 
174 ## convert lambda text to a tree of cells
175 
176 def parse in:text -> out:&:cell [
177   local-scope
178   load-inputs
179   s:&:stream:char <- new-stream in
180   out, s <- parse s
181   trace 2, [app/parse], out
182 ]
183 
184 def parse in:&:stream:char -> out:&:cell, in:&:stream:char [
185   local-scope
186   load-inputs
187   # skip whitespace
188   in <- skip-whitespace in
189   c:char, eof?:bool <- peek in
190   return-if eof?, 0/nil
191   pair?:bool <- equal c, 40/open-paren
192   {
193     break-if pair?
194     # atom
195     buf:&:buffer:char <- new-buffer 30
196     {
197       done?:bool <- end-of-stream? in
198       break-if done?
199       # stop before close paren or space
200       c:char <- peek in
201       done? <- equal c, 41/close-paren
202       break-if done?
203       done? <- space? c
204       break-if done?
205       c <- read in
206       buf <- append buf, c
207       loop
208     }
209     s:text <- buffer-to-array buf
210     out <- new-atom s
211   }
212   {
213     break-unless pair?
214     # pair
215     read in  # skip the open-paren
216     out <- new cell:type  # start out with nil
217     # read in first element of pair
218     {
219       end?:bool <- end-of-stream? in
220       not-end?:bool <- not end?
221       assert not-end?, [unbalanced '(' in expression]
222       c <- peek in
223       close-paren?:bool <- equal c, 41/close-paren
224       break-if close-paren?
225       first:&:cell, in <- parse in
226       *out <- merge 1/pair, first, 0/nil
227     }
228     # read in any remaining elements
229     curr:&:cell <- copy out
230     {
231       in <- skip-whitespace in
232       end?:bool <- end-of-stream? in
233       not-end?:bool <- not end?
234       assert not-end?, [unbalanced '(' in expression]
235       # termination check: ')'
236       c <- peek in
237       {
238         close-paren?:bool <- equal c, 41/close-paren
239         break-unless close-paren?
240         read in  # skip ')'
241         break +end-pair
242       }
243       # still here? read next element of pair
244       next:&:cell, in <- parse in
245       is-dot?:bool <- atom-match? next, [.]
246       {
247         break-if is-dot?
248         next-curr:&:cell <- new-pair next, 0/nil
249         curr <- set-rest curr, next-curr
250         curr <- rest curr
251       }
252       {
253         break-unless is-dot?
254         # deal with dotted pair
255         in <- skip-whitespace in
256         c <- peek in
257         not-close-paren?:bool <- not-equal c, 41/close-paren
258         assert not-close-paren?, [')' cannot immediately follow '.']
259         final:&:cell <- parse in
260         curr <- set-rest curr, final
261         # we're not gonna update curr, so better make sure the next iteration
262         # is going to end the pair
263         in <- skip-whitespace in
264         c <- peek in
265         close-paren?:bool <- equal c, 41/close-paren
266         assert close-paren?, ['.' must be followed by exactly one expression before ')']
267       }
268       loop
269     }
270     +end-pair
271   }
272 ]
273 
274 def skip-whitespace in:&:stream:char -> in:&:stream:char [
275   local-scope
276   load-inputs
277   {
278     done?:bool <- end-of-stream? in
279     return-if done?, 0/null
280     c:char <- peek in
281     space?:bool <- space? c
282     break-unless space?
283     read in  # skip
284     loop
285   }
286 ]
287 
288 def to-text x:&:cell -> out:text [
289   local-scope
290   load-inputs
291   buf:&:buffer:char <- new-buffer 30
292   buf <- to-buffer x, buf
293   out <- buffer-to-array buf
294 ]
295 
296 def to-buffer x:&:cell, buf:&:buffer:char -> buf:&:buffer:char [
297   local-scope
298   load-inputs
299   # base case: empty cell
300   {
301     break-if x
302     buf <- append buf, [<>]
303     return
304   }
305   # base case: atom
306   {
307     s:text, atom?:bool <- maybe-convert *x, atom:variant
308     break-unless atom?
309     buf <- append buf, s
310     return
311   }
312   # recursive case: pair
313   buf <- append buf, [< ]
314   first:&:cell <- first x
315   buf <- to-buffer first, buf
316   buf <- append buf, [ | ]
317   rest:&:cell <- rest x
318   buf <- to-buffer rest, buf
319   buf <- append buf, [ >]
320 ]
321 
322 scenario parse-single-letter-atom [
323   local-scope
324   s:text <- new [a]
325   x:&:cell <- parse s
326   s2:text, 10:bool/raw <- maybe-convert *x, atom:variant
327   11:@:char/raw <- copy *s2
328   memory-should-contain [
329     10 <- 1  # parse result is an atom
330     11:array:character <- [a]
331   ]
332 ]
333 
334 scenario parse-atom [
335   local-scope
336   s:text <- new [abc]
337   x:&:cell <- parse s
338   s2:text, 10:bool/raw <- maybe-convert *x, atom:variant
339   11:@:char/raw <- copy *s2
340   memory-should-contain [
341     10 <- 1  # parse result is an atom
342     11:array:character <- [abc]
343   ]
344 ]
345 
346 scenario parse-list-of-two-atoms [
347   local-scope
348   s:text <- new [(abc def)]
349   x:&:cell <- parse s
350   trace-should-contain [
351     app/parse: < abc | < def | <> > >
352   ]
353   10:bool/raw <- is-pair? x
354   x1:&:cell <- first x
355   x2:&:cell <- rest x
356   s1:text, 11:bool/raw <- maybe-convert *x1, atom:variant
357   12:bool/raw <- is-pair? x2
358   x3:&:cell <- first x2
359   s2:text, 13:bool/raw <- maybe-convert *x3, atom:variant
360   14:&:cell/raw <- rest x2
361   20:@:char/raw <- copy *s1
362   30:@:char/raw <- copy *s2
363   memory-should-contain [
364     10 <- 1  # parse result is a pair
365     11 <- 1  # result.first is an atom
366     12 <- 1  # result.rest is a pair
367     13 <- 1  # result.rest.first is an atom
368     14 <- 0  # result.rest.rest is nil
369     20:array:character <- [abc]  # result.first
370     30:array:character <- [def]  # result.rest.first
371   ]
372 ]
373 
374 scenario parse-list-with-extra-spaces [
375   local-scope
376   s:text <- new [ ( abc  def ) ]  # extra spaces
377   x:&:cell <- parse s
378   trace-should-contain [
379     app/parse: < abc | < def | <> > >
380   ]
381   10:bool/raw <- is-pair? x
382   x1:&:cell <- first x
383   x2:&:cell <- rest x
384   s1:text, 11:bool/raw <- maybe-convert *x1, atom:variant
385   12:bool/raw <- is-pair? x2
386   x3:&:cell <- first x2
387   s2:text, 13:bool/raw <- maybe-convert *x3, atom:variant
388   14:&:cell/raw <- rest x2
389   20:@:char/raw <- copy *s1
390   30:@:char/raw <- copy *s2
391   memory-should-contain [
392     10 <- 1  # parse result is a pair
393     11 <- 1  # result.first is an atom
394     12 <- 1  # result.rest is a pair
395     13 <- 1  # result.rest.first is an atom
396     14 <- 0  # result.rest.rest is nil
397     20:array:character <- [abc]  # result.first
398     30:array:character <- [def]  # result.rest.first
399   ]
400 ]
401 
402 scenario parse-list-of-more-than-two-atoms [
403   local-scope
404   s:text <- new [(abc def ghi)]
405   x:&:cell <- parse s
406   trace-should-contain [
407     app/parse: < abc | < def | < ghi | <> > > >
408   ]
409   10:bool/raw <- is-pair? x
410   x1:&:cell <- first x
411   x2:&:cell <- rest x
412   s1:text, 11:bool/raw <- maybe-convert *x1, atom:variant
413   12:bool/raw <- is-pair? x2
414   x3:&:cell <- first x2
415   s2:text, 13:bool/raw <- maybe-convert *x3, atom:variant
416   x4:&:cell <- rest x2
417   14:bool/raw <- is-pair? x4
418   x5:&:cell <- first x4
419   s3:text, 15:bool/raw <- maybe-convert *x5, atom:variant
420   16:&:cell/raw <- rest x4
421   20:@:char/raw <- copy *s1
422   30:@:char/raw <- copy *s2
423   40:@:char/raw <- copy *s3
424   memory-should-contain [
425     10 <- 1  # parse result is a pair
426     11 <- 1  # result.first is an atom
427     12 <- 1  # result.rest is a pair
428     13 <- 1  # result.rest.first is an atom
429     14 <- 1  # result.rest.rest is a pair
430     15 <- 1  # result.rest.rest.first is an atom
431     16 <- 0  # result.rest.rest.rest is nil
432     20:array:character <- [abc]  # result.first
433     30:array:character <- [def]  # result.rest.first
434     40:array:character <- [ghi]  # result.rest.rest
435   ]
436 ]
437 
438 scenario parse-nested-list [
439   local-scope
440   s:text <- new [((abc))]
441   x:&:cell <- parse s
442   trace-should-contain [
443     app/parse: < < abc | <> > | <> >
444   ]
445   10:bool/raw <- is-pair? x
446   x1:&:cell <- first x
447   11:bool/raw <- is-pair? x
448   x2:&:cell <- first x1
449   s1:text, 12:bool/raw <- maybe-convert *x2, atom:variant
450   13:&:cell/raw <- rest x1
451   14:&:cell/raw <- rest x
452   20:@:char/raw <- copy *s1
453   memory-should-contain [
454     10 <- 1  # parse result is a pair
455     11 <- 1  # result.first is a pair
456     12 <- 1  # result.first.first is an atom
457     13 <- 0  # result.first.rest is nil
458     14 <- 0  # result.rest is nil
459     20:array:character <- [abc]  # result.first.first
460   ]
461 ]
462 
463 scenario parse-nested-list-2 [
464   local-scope
465   s:text <- new [((abc) def)]
466   x:&:cell <- parse s
467   trace-should-contain [
468     app/parse: < < abc | <> > | < def | <> > >
469   ]
470   10:bool/raw <- is-pair? x
471   x1:&:cell <- first x
472   11:bool/raw <- is-pair? x
473   x2:&:cell <- first x1
474   s1:text, 12:bool/raw <- maybe-convert *x2, atom:variant
475   13:&:cell/raw <- rest x1
476   x3:&:cell <- rest x
477   x4:&:cell <- first x3
478   s2:text, 14:bool/raw <- maybe-convert *x4, atom:variant
479   15:&:cell/raw <- rest x3
480   20:@:char/raw <- copy *s1
481   30:@:char/raw <- copy *s2
482   memory-should-contain [
483     10 <- 1  # parse result is a pair
484     11 <- 1  # result.first is a pair
485     12 <- 1  # result.first.first is an atom
486     13 <- 0  # result.first.rest is nil
487     14 <- 1  # result.rest.first is an atom
488     15 <- 0  # result.rest.rest is nil
489     20:array:character <- [abc]  # result.first.first
490     30:array:character <- [def]  # result.rest.first
491   ]
492 ]
493 
494 # todo: uncomment these tests after we figure out how to continue tests after
495 # assertion failures
496 #? scenario parse-error [
497 #?   local-scope
498 #?   s:text <- new [(]
499 #? #?   hide-errors
500 #?   x:&:cell <- parse s
501 #? #?   show-errors
502 #?   trace-should-contain [
503 #?     error: unbalanced '(' in expression
504 #?   ]
505 #? ]
506 #? 
507 #? scenario parse-error-after-element [
508 #?   local-scope
509 #?   s:text <- new [(abc]
510 #? #?   hide-errors
511 #?   x:&:cell <- parse s
512 #? #?   show-errors
513 #?   trace-should-contain [
514 #?     error: unbalanced '(' in expression
515 #?   ]
516 #? ]
517 
518 scenario parse-dotted-list-of-two-atoms [
519   local-scope
520   s:text <- new [(abc . def)]
521   x:&:cell <- parse s
522   trace-should-contain [
523     app/parse: < abc | def >
524   ]
525   10:bool/raw <- is-pair? x
526   x1:&:cell <- first x
527   x2:&:cell <- rest x
528   s1:text, 11:bool/raw <- maybe-convert *x1, atom:variant
529   s2:text, 12:bool/raw <- maybe-convert *x2, atom:variant
530   20:@:char/raw <- copy *s1
531   30:@:char/raw <- copy *s2
532   memory-should-contain [
533     # parses to < abc | def >
534     10 <- 1  # parse result is a pair
535     11 <- 1  # result.first is an atom
536     12 <- 1  # result.rest is an atom
537     20:array:character <- [abc]  # result.first
538     30:array:character <- [def]  # result.rest
539   ]
540 ]
541 
542 scenario parse-dotted-list-of-more-than-two-atoms [
543   local-scope
544   s:text <- new [(abc def . ghi)]
545   x:&:cell <- parse s
546   trace-should-contain [
547     app/parse: < abc | < def | ghi > >
548   ]
549   10:bool/raw <- is-pair? x
550   x1:&:cell <- first x
551   x2:&:cell <- rest x
552   s1:text, 11:bool/raw <- maybe-convert *x1, atom:variant
553   12:bool/raw <- is-pair? x2
554   x3:&:cell <- first x2
555   s2:text, 13:bool/raw <- maybe-convert *x3, atom:variant
556   x4:&:cell <- rest x2
557   s3:text, 14:bool/raw <- maybe-convert *x4, atom:variant
558   20:@:char/raw <- copy *s1
559   30:@:char/raw <- copy *s2
560   40:@:char/raw <- copy *s3
561   memory-should-contain [
562     10 <- 1  # parse result is a pair
563     11 <- 1  # result.first is an atom
564     12 <- 1  # result.rest is a pair
565     13 <- 1  # result.rest.first is an atom
566     14 <- 1  # result.rest.rest is an atom
567     20:array:character <- [abc]  # result.first
568     30:array:character <- [def]  # result.rest.first
569     40:array:character <- [ghi]  # result.rest.rest
570   ]
571 ]
572 
573 ## convert tree of cells to Mu text
574 
575 def to-mu in:&:cell -> out:text [
576   local-scope
577   load-inputs
578   buf:&:buffer:char <- new-buffer 30
579   buf <- to-mu in, buf
580   out <- buffer-to-array buf
581 ]
582 
583 def to-mu in:&:cell, buf:&:buffer:char -> buf:&:buffer:char, result-name:text [
584   local-scope
585   load-inputs
586   # null cell? no change.
587   # pair with all atoms? gensym a new variable
588   # pair containing other pairs? recurse
589   result-name <- copy 0
590 ]