#lang plai (require redex/reduction-semantics) ;; Step 4: change the second argument to 'find' to be a (d -> L2e) ;; function and use that in the context records as well. ;; This change amounts to using 'fill' to translate from a context ;; record into a (d -> L2e) function (which means the old ;; calls to fill now just call the (d -> L2e) function directly) (define-type context [let-ctxt (x var?) (b L4-e?) (k (-> d? L3-e?))] [if-ctxt (t L4-e?) (e L4-e?) (k (-> d? L3-e?))] [fun-ctxt (a L4-e?) (k (-> d? L3-e?))] [arg-ctxt (f val?) (k (-> d? L3-e?))] [no-ctxt]) ;; find : L3e (d -> L2e) -> L2e (define (find e k) (match e [`(,f ,a) (find f (fill (fun-ctxt a k)))] [`(let ([,x ,r]) ,b) (find r (fill (let-ctxt x b k)))] [`(if ,c ,t ,e) (find c (fill (if-ctxt t e k)))] [(? val?) (k e)])) ;; fill : context -> d -> L2e (define (fill k+) (type-case context k+ [fun-ctxt (a k) (λ (d) (if (val? d) (find a (fill (arg-ctxt d k))) (let ([x (fresh-var)]) `(let ([,x ,d]) ,(find a (fill (arg-ctxt x k)))))))] [arg-ctxt (f k) (λ (d) (if (val? d) (k `(,f ,d)) (let ([x (fresh-var)]) `(let ([,x ,d]) ,(k `(,f ,x))))))] [let-ctxt (x b k) (λ (d) `(let ([,x ,d]) ,(find b k)))] [if-ctxt (t e k) (λ (d) (if (val? d) `(if ,d ,(find t k) ,(find e k)) (let ([x (fresh-var)]) `(let ([,x ,d]) (if ,x ,(find t k) ,(find e k))))))] [no-ctxt () (λ (d) d)])) (define (norm e) (find e (fill (no-ctxt)))) (define-language L3 (p (e (l (x ...) e) ...)) ;; a main expression followed by function definitions (d (biop v v) (pred v) (v v ...) (new-array v v) (new-tuple v ...) (aref v v) (aset v v v) (alen v) (print v) (make-closure l v) (closure-proc v) (closure-vars v) v) (e d (let ([x d]) e) (if v e e)) (v x l num) (x (side-condition (name x variable-not-otherwise-mentioned) (variable? (term x)))) (l (side-condition (name x (variable-prefix :)) (regexp-match #rx"^:[a-zA-Z_0-9]*$" (symbol->string (term x))))) (biop + - * cmpop) (cmpop < <= =) (pred number? a?) (num (side-condition number_1 (32-bit-int? (term number_1))))) (define-extended-language L4 L3 (e x l (biop e e) (pred e) (let ([x e]) e) (if e e e) (new-array e e) (new-tuple e ...) (aref e e) (aset e e e) (alen e) (e e ...) (begin e e) (print e) (make-closure l e) (closure-proc e) (closure-vars e) num)) (define (variable? x) (and (not (label? x)) (not (real-register? x)))) (define (label? x) (and (symbol? x) (regexp-match #rx"^:" (symbol->string x)))) (define (real-register? x) (member x '(eax ebx ecx edx esi edi esp ebp))) (define (32-bit-int? x) (and (integer? x) (<= (- (expt 2 31)) x) (< x (expt 2 31)))) (define (var? x) (symbol? x)) (define (val? x) (or (symbol? x) (number? x))) (define d? (redex-match L3 d)) (define L4-e? (redex-match L4 e)) (define L3-e? (redex-match L3 e)) (define count 0) (define (fresh-var) (set! count (+ count 1)) (string->symbol (format "x_~a" count))) (print-only-errors #t) (test (norm '((a b) (c d))) '(let ([x_1 (a b)]) (let ([x_2 (c d)]) (x_1 x_2)))) (test (norm '(f (if a b c))) '(if a (f b) (f c))) (test (norm '(if (a b) c d)) '(let ([x_3 (a b)]) (if x_3 c d))) (test (norm '(f (let ([x (a b)]) x))) '(let ([x (a b)]) (f x)))