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 ]