#lang racket
(provide prims-list prim? reserved?
datum? scheme-exp? core-exp?
eval-scheme eval-core test-desugar)
(define prims-list
‘(= > < <= >= + – * /
cons? null? cons car cdr list first second third fourth fifth list
length list-tail drop take member memv map append foldl foldr
vector? vector make-vector vector-ref vector-set! vector-length
set set->list list->set set-add set-union set-count set-first set-rest set-remove
hash hash-ref hash-set hash-count hash-keys hash-has-key? hash?
list? void? promise? procedure? number? integer?
error void print display write exit halt eq? eqv? equal? not))
(define (prim? op) (member op prims-list))
; the list of reserved special forms
(define reserved-list ‘(letrec letrec* let let* if and or set! quote begin
cond case when unless delay force
call/cc prim apply-prim))
(define (reserved? id) (member id reserved-list))
;;;;;;;;;;;;;;;;;; Predicates for grammar conformity ;;;;;;;;;;;;;;;;;;
(define (datum? d)
(match d
[`#(,(? datum?) …) #t]
[`(,(? datum?) …) #t]
[(cons datum? datum?) #t]
[(? string?) #t]
[(? integer?) #t]
[(? symbol?) #t]
[(? boolean?) #t]
[else (pretty-print `(bad-datum ,d)) #f]))
(define (scheme-exp? e [env (set)])
(define (var? x) (symbol? x))
(define ((rec/with env) e)
(scheme-exp? e env))
(define (no-duplicates? lst)
(if (= (set-count (list->set lst)) (length lst))
#t
(begin (pretty-print `(duplicate vars ,lst))
#f)))
(define (ext env lst) (set-union env (list->set lst)))
(define (cond-clause? cls)
(match cls
[`(else ,(? rec/with env)) #t]
[`(,(? (rec/with env))) #t]
[`(,(? (rec/with env)) ,(? (rec/with env))) #t]
[else #f]))
(define (case-clause? cls)
(match cls
[`((,(? datum?) …) ,(? (rec/with env))) #t]
[else #f]))
(match e
[`(letrec* ([,(? var? xs) ,es] …) ,e0)
(and (no-duplicates? xs)
(andmap (rec/with (ext env xs))
(cons e0 es)))]
[`(letrec ([,(? var? xs) ,es] …) ,e0)
(and (no-duplicates? xs)
(andmap (rec/with (ext env xs))
(cons e0 es)))]
[`(let* () ,e0)
((rec/with env) e0)]
[`(let* ([,x ,e0]) ,e1)
((rec/with env) `(let ([,x ,e0]) ,e1))]
[`(let* ([,x ,e0] . ,rest) ,e1)
((rec/with env) `(let ([,x ,e0]) (let* ,rest ,e1)))]
[`(let ([,(? symbol? xs) ,(? (rec/with env) es)] …) ,e0)
(and (no-duplicates? xs)
((rec/with (ext env xs)) e0))]
[`(let ,(? var? lp) ([,xs ,es] …) ,e0)
((rec/with env) `(letrec ([,lp (lambda ,xs ,e0)]) (,lp . ,es)))]
[`(lambda (,(? var? xs) …) ,e0)
(and (no-duplicates? xs)
((rec/with (ext env xs)) e0))]
[`(lambda ,(? var? x) ,e0)
((rec/with (ext env (list x))) e0)]
[`(lambda (,(? var? x0) ,(? var? xs) … . ,(? var? improper-arg)) ,e0)
(and (no-duplicates? `(,x0 ,@xs ,improper-arg))
((rec/with (ext env `(,x0 ,@xs ,improper-arg))) e0))]
[`(delay ,(? (rec/with env))) #t]
[`(force ,(? (rec/with env))) #t]
[`(cond ,(? cond-clause?) … (else ,(? (rec/with env)))) #t]
[`(cond ,(? cond-clause?) …) #t]
[`(case ,(? (rec/with env)) ,(? case-clause?) …) #t]
[`(case ,(? (rec/with env)) ,(? case-clause?) … (else ,(? (rec/with env)))) #t]
[`(and ,(? (rec/with env)) …) #t]
[`(or ,(? (rec/with env)) …) #t]
[`(when ,(? (rec/with env)) ,(? (rec/with env))) #t]
[`(unless ,(? (rec/with env)) ,(? (rec/with env))) #t]
[`(if ,(? (rec/with env)) ,(? (rec/with env)) ,(? (rec/with env))) #t]
[`(set! ,(? symbol?) ,(? (rec/with env))) #t]
[`(begin ,(? (rec/with env)) ,(? (rec/with env)) …) #t]
[`(call/cc ,(? (rec/with env))) #t]
[`(let/cc ,(? symbol? x) ,eb) ((rec/with (ext env (list x))) eb)]
[(? var? x) (if (or (set-member? env x) (prim? x))
#t
(begin (pretty-print `(unbound-var: ,x)) #f))]
[`(quote ,(? datum?)) #t]
[`(,(? prim?) ,(? (rec/with env)) …) #t]
[`(apply ,(? (rec/with env)) ,(? (rec/with env))) #t]
[`#(,(? (rec/with env))) (displayln ‘invec) #t]
[`(,(? (rec/with env)) ,(? (rec/with env)) …) #t]
[else (pretty-print `(bad-scheme ,e ,env)) #f]))
(define (core-exp? e [env (set)])
(define (var? x) (symbol? x))
(define ((rec/with env) e)
(core-exp? e env))
(define (no-duplicates? lst)
(= (set-count (list->set lst)) (length lst)))
(define (ext env lst)
(set-union env (list->set lst)))
(match e
[`(let ([,(? var? xs) ,(? (rec/with env) es)] …) ,e0)
(and (no-duplicates? xs)
((rec/with (ext env xs)) e0))]
[`(lambda (,(? var? xs) …) ,e0)
(and (no-duplicates? xs)
((rec/with (ext env xs)) e0))]
[`(lambda ,(? var? x) ,e0)
((rec/with (ext env (list x))) e0)]
[`(apply ,(? (rec/with env)) ,(? (rec/with env))) #t]
[`(if ,(? (rec/with env)) ,(? (rec/with env)) ,(? (rec/with env))) #t]
[`(set! ,(? symbol?) ,(? (rec/with env))) #t]
[`(call/cc ,(? (rec/with env))) #t]
[(? var? x) (set-member? env x)]
[`(quote ,(? datum?)) #t]
[`(prim ,(? prim?) ,(? (rec/with env)) …) #t]
[`(apply-prim ,(? prim?) ,(? (rec/with env))) #t]
[`(,(? (rec/with env)) ,(? (rec/with env)) …) #t]
[else (pretty-print `(bad-core ,e ,env)) #f]))
;;;;;;;;;;;;;;;;;; evaluating code ;;;;;;;;;;;;;;;;;;
(define (eval-scheme e)
(if (scheme-exp? e)
(racket-compile-eval e)
(error ‘malformed-scheme)))
(define (eval-core e)
(if (core-exp? e)
(racket-compile-eval e)
(error ‘malformed-core)))
; this is be used to interpret IRs.
(define (racket-compile-eval e)
(with-handlers ([exn:fail? (lambda (x)
(pretty-print “Evaluation failed:”)
(newline)
(pretty-print x)
(error ‘eval-fail))])
(parameterize ([current-namespace (make-base-namespace)])
(namespace-require ‘rnrs)
(namespace-require ‘racket)
(namespace-require ‘srfi/34)
(eval (compile
`(call/cc (lambda (%%exit+)
(define (halt x) (%%exit+ x))
(define (prim op . args) (apply op args))
(define (apply-prim op args) (apply op args))
,e)))))))
; can be used to test small programs locally.
(define/contract (test-desugar desugar scheme-prog)
(-> (-> scheme-exp? core-exp?) scheme-exp? boolean?)
(define expected (eval-scheme scheme-prog))
(define core-e (desugar scheme-prog))
(define got (eval-core core-e))
(if (equal? expected got)
#t
(begin
(displayln (format “Test-desugar: different values. Expected: ~a, Got: ~a” expected got))
#f)))