?

Log in

No account? Create an account

Previous Entry | Next Entry

I know...I am such a dork...



(load "lang.scm")
(load "tests.scm")
(load "env-fun.ss")
(load "cont.scm")

(define type-check
(lambda (exp)
(check exp empty-env)))

(define check
(lambda (exp env)
(cond
[(or (true-exp? exp) (false-exp? exp)) 'bool]
[(number-exp? exp) 'int]
[(id-exp? exp) (lookup exp env)]
[(null-exp? exp) (result-type exp)]
[(add1-exp? exp) (if (int? (check (1st-arg exp) env))
'int
(error 'check "add1: arg of ~s is not an int." exp))]
[(sub1-exp? exp) (if (int? (check (1st-arg exp) env))
'int
(error 'check "sub1: arg of ~s is not an int." exp))]
[(car-exp? exp) (let ([arg-type (check (1st-arg exp) env)])
(if (list-type? arg-type)
(list-type arg-type)
(error 'check "car: arg ~s is not a list." exp)))]
[(cdr-exp? exp) (let ([arg-type (check (1st-arg exp) env)])
(if (list-type? arg-type)
arg-type
(error 'check "cdr: arg ~s is not a list." exp)))]
[(zero?-exp? exp) (if (int? (check (1st-arg exp) env))
'bool
(error 'check "zero?: arg of ~s is not an int." exp))]
[(null?-exp? exp) (let ([arg-type (check (1st-arg exp) env)])
(if (list-type? arg-type)
'bool
(error 'check "null?: arg ~s is not a list." exp)))]
[(cons-exp? exp) (let ([1st-arg-type (check (1st-arg exp) env)]
[2nd-arg-type (check (2nd-arg exp) env)])
(if (list-type? 2nd-arg-type)
(if (same-type? 1st-arg-type (list-type 2nd-arg-type))
2nd-arg-type
(error 'check "cons: list types ~s do not match." exp))
(error 'check "cons: 2nd-arg-type ~s is not a list." exp)))]
[(set-car!-exp? exp) (let ([1st-arg-type (check (1st-arg exp) env)]
[2nd-arg-type (check (2nd-arg exp) env)])
(if (list-type? 1st-arg-type)
(if (same-type? (list-type 1st-arg-type) 2nd-arg-type)
1st-arg-type
(error 'check
"set-car!: the types
~s do not match." exp))
(error 'check
"set-car!: the 1st-arg-type
~s is not a list." exp)))]
[(if-exp? exp) (let ([test-part-type (check (test-part exp) env)]
[then-part-type (check (then-part exp) env)]
[else-part-type (check (else-part exp) env)])
(if (bool? test-part-type)
(if (same-types? then-part-type else-part-type)
then-part-type
(error 'check
"if: the then-part and else-part
~s are not the same types." exp))
(error 'check
"if: the test-part
~s is not a bool." exp)))]
[(lambda-exp? exp) (mk-fun-type (formal-types exp)
(check (body exp)
(extend env
(formals exp)
(formal-types exp))))]
[(letrec-exp? exp)
(let ([declared-return-type (letrec-return-type exp)]
[fun-name (letrec-name exp)]
[formals (formals (letrec-lambda exp))]
[formal-types (formal-types (letrec-lambda exp))]
[letrec-function-body (letrec-function-body exp)]
[letrec-body (letrec-body exp)])
(let* ([fun-type (mk-fun-type formal-types declared-return-type)]
[env1 (extend env (list fun-name) (list fun-type))]
[env2 (extend env1 formals formal-types)]
[actual-return-type (check letrec-function-body env2)]
[body-type (check letrec-body env1)])
(if (same-type? actual-return-type declared-return-type)
body-type
(error 'check "letrec: arg ~s is not the same type." exp))))]
[(application-exp? exp) (let ([fun-type (check (function exp) env)]
[arg-type (map (lambda (exp) (check exp env))
(args exp))])
(if (fun-type? fun-type)
(if (same-types? arg-type (arg-types fun-type))
(result-type fun-type)
(error 'check
"application: the types
~s do not match." exp))
(error 'check
"application:
~s is not an expression type." exp)))]
[else (error 'check "Bad expression: ~s." exp)])))



(define interpret
(lambda (exp)
(interp exp empty-env initial-cont)))

(define interp
(lambda (exp env cont)
(cond
[(true-exp? exp) (cont exp)]
[(false-exp? exp) (cont exp)]
[(number-exp? exp) (cont exp)]
[(id-exp? exp) (lookup exp env)]
[(null-exp? exp) (cont '())]
[(add1-exp? exp) (interp (1st-arg exp) env
(lambda (1st-arg-value)
(cont (add1 1st-arg-value))))]
[(sub1-exp? exp) (interp (1st-arg exp) env
(lambda (1st-arg-value)
(cont (sub1 1st-arg-value))))]
[(car-exp? exp) (if (not (null? (1st-arg exp)))
(interp (1st-arg exp) env
(lambda (v)
(cont (car v))))
(error 'interp "car: 1st argument ~s is null." exp))]
[(cdr-exp? exp) (if (not (null? (1st-arg exp)))
(interp (1st-arg exp) env
(lambda (v)
(cont (cdr v))))
(error 'interp "cdr: 1st argument ~s is null." exp))]
[(zero?-exp? exp) (interp (1st-arg exp) env
(lambda (v)
(cont (zero? v))))]
[(null?-exp? exp) (interp (1st-arg exp) env
(lambda (v)
(cont (null? v))))]
[(cons-exp? exp) (interp (1st-arg exp) env
(lambda (v1)
(interp (2nd-arg exp) env
(lambda (v2)
(cont (cons v1 v2))))))]
[(set-car!-exp? exp)
(interp (1st-arg exp) env
(lambda (v1)
(interp (2nd-arg exp) env
(lambda (v2)
(cont (set-car! v1 v2))))))]
;(if (not (null? (1st-arg exp)))
; (begin (set-car! 1st 2nd) 1st)
; (error 'interp "set-car: 1st-argument ~s is null." exp)))]
[(if-exp? exp) (interp (test-part exp) env
(lambda (test-value)
(if test-value
(interp (then-part exp) env cont)
(interp (else-part exp) env cont))))]
[(lambda-exp? exp)
(mk-closure (formals exp) (body exp) env cont)]
[(letrec-exp? exp)
(let* ([fun (interp (letrec-lambda exp) 'junk)]
[new-env (extend env (list (letrec-name exp)) (list fun))])
(begin
(set-closure-env! fun new-env)
(interp (letrec-body exp) new-env)))]
[(application-exp? exp)
(interp (function exp) env
(lambda (fun-val)
(interp-args (args exp) env
(lambda (arg-vals)
(interp (closure-body fun-val) (closure-formals arg-v
als) cont)))))]
[else (error 'interp (format "bad expression: ~s" exp))])))

(define apply-fun
(lambda (fun args)
(interp (closure-body fun)
(extend (closure-env fun) (closure-formals fun) args))))

(define interp-args
(lambda (exp-list env cont)
(map (lambda (arg) (interp arg env cont)) exp-list)))

;; Closures

(define mk-closure list)
(define closure-formals car)
(define closure-body cadr)
(define closure-env caddr)
(define set-closure-env!
(lambda (closure env)
(set-car! (cddr closure) env)))



I know the spacing is off...it looks much better when you put it in Dr. Scheme...

Latest Month

April 2011
S M T W T F S
     12
3456789
10111213141516
17181920212223
24252627282930
Powered by LiveJournal.com
Designed by Lizzy Enger