PasteRack.org
Paste # 14959
2025-03-09 05:14:41

Fork as a new paste.

Paste viewed 1558 times.


Embed:

  1. #lang racket
  2.  
  3. ;; Input language, Core Scheme:
  4.  
  5. ; <M> ::= <V>
  6. ;      |  (let ([<x> <M>]) <M>)
  7. ;      |  (if <M> <M> <M>)
  8. ;      |  (<M> <M> ...)
  9. ;      |  (<O> <M> ...)
  10.  
  11. ; <V> ::= <c> | <x> | (λ (<x> ...) <M>)
  12.  
  13. ; <x> is a variable
  14. ; <c> is a constant
  15. ; <O> is a primitive operation
  16.  
  17.  
  18. ;; Output language:
  19.  
  20. ; <aexp> ::= <c> | <O>
  21. ;         |  (lambda (<x> ...) <exp>)
  22.  
  23. ; <cexp> ::= (<aexp> <aexp> ...)
  24. ;         |  (if <aexp> <exp> <exp>)
  25.  
  26. ; <exp>  ::= (let ([<x> <cexp>]) <exp>)
  27. ;         |  <cexp>
  28. ;         |  <aexp>
  29.  
  30.  
  31. (define (Value? M)
  32.   (match M
  33.     [`(quote ,_)   #t]
  34.     [(? number?)   #t]
  35.     [(? boolean?)  #t]
  36.     [(? string?)   #t]
  37.     [(? char?)     #t]
  38.     [(? symbol?)   #t]
  39.     [(or '+ '- '* '/ '=) #t]
  40.     [else          #f]))
  41.  
  42.  
  43. (define (normalize-term M) (normalize M (λ (x) x)))
  44.  
  45. (define (normalize M k)
  46.   (match M
  47.     [`(λ ,params ,body)
  48.       (k `(λ ,params ,(normalize-term body)))]
  49.  
  50.     [`(let ([,x ,M1]) ,M2)
  51.       (normalize M1 (λ (N1)
  52.        `(let ([,x ,N1])
  53.          ,(normalize M2 k))))]
  54.  
  55.     [`(if ,M1 ,M2 ,M3)
  56.       (normalize-name M1 (λ (t)
  57.        (k `(if ,t ,(normalize-term M2)
  58.                   ,(normalize-term M3)))))]
  59.  
  60.     [`(,Fn . ,M*)
  61.       (normalize-name Fn (λ (t)
  62.        (normalize-name* M* (λ (t*)
  63.         (k `(,t . ,t*))))))]
  64.  
  65.     [(? Value?)             (k M)]))
  66.  
  67. (define (normalize-name M k)
  68.   (normalize M (λ (N)
  69.     (if (Value? N) (k N)
  70.         (let ([t (gensym)])
  71.          `(let ([,t ,N]) ,(k t)))))))
  72.  
  73. (define (normalize-name* M* k)
  74.   (if (null? M*)
  75.       (k `())
  76.       (normalize-name (car M*) (λ (t)
  77.        (normalize-name* (cdr M*) (λ (t*)
  78.         (k `(,t . ,t*))))))))
  79.  
  80. ;; tests
  81.  
  82.  
  83. (define t1
  84.  '(let ((id (λ (x) x)))
  85.     (let ((apply (λ (f x) (f x))))
  86.       ((id apply) (id 3)))))
  87.  
  88. (pretty-print t1)
  89.  
  90. (pretty-print (normalize-term t1))
  91.  
  92.  
  93. (define t2
  94.   '(let ([x (let ([y 20]) y)])
  95.      x))
  96.  
  97.  
  98. (pretty-print t2)
  99.  
  100. (pretty-print (normalize-term t2))
  101.  
  102.  
  103.  
  104. (define t3
  105.   '(let ([x (if #t 1 2)])
  106.      x))
  107.  
  108.  
  109. (pretty-print t3)
  110.  
  111. (pretty-print (normalize-term t3))
  112.  
  113. (define t4
  114.   '(let ([x (let ([y 0]) y)]) x))
  115. (pretty-print t4)
  116. (pretty-print (normalize-term t4))

=>

'(let ((id (λ (x) x))) (let ((apply (λ (f x) (f x)))) ((id apply) (id 3))))

'(let ((id (λ (x) x)))

   (let ((apply (λ (f x) (f x))))

     (let ((g2465 (id apply))) (let ((g2466 (id 3))) (g2465 g2466)))))

'(let ((x (let ((y 20)) y))) x)

'(let ((y 20)) (let ((x y)) x))

'(let ((x (if #t 1 2))) x)

'(let ((x (if #t 1 2))) x)

'(let ((x (let ((y 0)) y))) x)

'(let ((y 0)) (let ((x y)) x))