Advertisement
Not a member of Pastebin yet?
Sign Up,
it unlocks many cool features!
- #lang eopl
- ;^;;;;;;;;;;;;;;; grammatical specification ;;;;;;;;;;;;;;;;
- (define the-lexical-spec
- '((whitespace (whitespace) skip)
- (comment ("%" (arbno (not #\newline))) skip)
- (identifier
- (letter (arbno (or letter digit "_" "-" "?")))
- symbol)
- (number (digit (arbno digit)) number)))
- (define the-grammar
- '((program ((arbno class-decl) expression) a-program)
- (expression (number) lit-exp)
- (expression (identifier) var-exp)
- (expression
- (primitive "(" (separated-list expression ",") ")")
- primapp-exp)
- (expression
- ("if" expression "then" expression "else" expression)
- if-exp)
- (expression
- ("let" (arbno identifier "=" expression) "in" expression)
- let-exp)
- (expression
- ("proc" "(" (separated-list identifier ",") ")" expression)
- proc-exp)
- (expression
- ("(" expression (arbno expression) ")")
- app-exp)
- (expression
- ("letrec"
- (arbno identifier "(" (separated-list identifier ",") ")"
- "=" expression)
- "in" expression)
- letrec-exp)
- (expression ("set" identifier "=" expression) varassign-exp)
- (expression
- ("begin" expression (arbno ";" expression) "end")
- begin-exp)
- (primitive ("+") add-prim)
- (primitive ("-") subtract-prim)
- (primitive ("*") mult-prim)
- (primitive ("add1") incr-prim)
- (primitive ("sub1") decr-prim)
- (primitive ("zero?") zero-test-prim)
- (primitive ("list") list-prim)
- (primitive ("cons") cons-prim)
- (primitive ("nil") nil-prim)
- (primitive ("car") car-prim)
- (primitive ("cdr") cdr-prim)
- (primitive ("null?") null?-prim)
- ;^;;;;;;;;;;;;;;; new productions for oop ;;;;;;;;;;;;;;;;
- (class-decl
- ("class" identifier
- "extends" identifier
- (arbno "field" identifier)
- (arbno method-decl)
- )
- a-class-decl)
- (method-decl
- ("method" identifier
- "(" (separated-list identifier ",") ")" ; method ids
- expression
- )
- a-method-decl)
- (expression
- ("new" identifier "(" (separated-list expression ",") ")")
- new-object-exp)
- (expression
- ("send" expression identifier
- "(" (separated-list expression ",") ")")
- method-app-exp)
- (expression
- ("super" identifier "(" (separated-list expression ",") ")")
- super-call-exp)
- (expression
- ("get" expression identifier )
- get-exp)
- (expression
- ("showEnv")
- show-env-exp)
- ;^;;;;;;;;;;;;;;; end new productions for oop ;;;;;;;;;;;;;;;;
- ))
- (sllgen:make-define-datatypes the-lexical-spec the-grammar)
- (define list-the-datatypes
- (lambda () (sllgen:list-define-datatypes the-lexical-spec the-grammar)))
- (define scan&parse
- (sllgen:make-string-parser the-lexical-spec the-grammar))
- (define just-scan
- (sllgen:make-string-scanner the-lexical-spec the-grammar))
- ;^;;;;;;;;;;;;;;; the interpreter ;;;;;;;;;;;;;;;;
- (define eval-program
- (lambda (pgm)
- (cases program pgm
- (a-program (c-decls exp)
- (elaborate-class-decls! c-decls) ;\new1
- (eval-expression exp (empty-env))))))
- (define eval-expression
- (lambda (exp env)
- (cases expression exp
- (lit-exp (datum) datum)
- (var-exp (id) (apply-env env id))
- (primapp-exp (prim rands)
- (let ((args (eval-rands rands env)))
- (apply-primitive prim args)))
- (if-exp (test-exp true-exp false-exp)
- (if (true-value? (eval-expression test-exp env))
- (eval-expression true-exp env)
- (eval-expression false-exp env)))
- (let-exp (ids rands body)
- (let ((args (eval-rands rands env)))
- (eval-expression body (extend-env ids args env))))
- (proc-exp (ids body)
- (closure ids body env))
- (app-exp (rator rands)
- (let ((proc (eval-expression rator env))
- (args (eval-rands rands env)))
- (if (procval? proc)
- (apply-procval proc args)
- (eopl:error 'eval-expression
- "Attempt to apply non-procedure ~s" proc))))
- (letrec-exp (proc-names idss bodies letrec-body)
- (eval-expression letrec-body
- (extend-env-recursively proc-names idss bodies env)))
- (varassign-exp (id rhs-exp)
- (setref!
- (apply-env-ref env id)
- (eval-expression rhs-exp env))
- 1)
- ;&
- (begin-exp (exp1 exps)
- (let loop ((acc (eval-expression exp1 env))
- (exps exps))
- (if (null? exps) acc
- (loop (eval-expression (car exps) env) (cdr exps)))))
- ;^;;;;;;;;;;;;;;; begin new cases for chap 5 ;;;;;;;;;;;;;;;;
- (new-object-exp (class-name rands)
- (let ((args (eval-rands rands env))
- (obj (new-object class-name)))
- (find-method-and-apply
- 'initialize class-name obj args)
- obj))
- (method-app-exp (obj-exp method-name rands)
- (let ((args (eval-rands rands env))
- (obj (eval-expression obj-exp env)))
- (find-method-and-apply
- method-name (object->class-name obj) obj args)))
- (super-call-exp (method-name rands)
- (let ((args (eval-rands rands env))
- (obj (apply-env env 'self)))
- (find-method-and-apply
- method-name (apply-env env '%super) obj args)))
- (get-exp (class identifier)
- (let ( [ e-class (eval-expression class env) ] )
- (let ( [ ids (part->field-ids (car e-class)) ] [ values (part->fields (car e-class)) ] )
- (let findField ( [pos 0] )
- (if (equal? identifier (list-ref ids pos))
- (vector-ref values pos)
- (findField (+ pos 1))
- )
- )
- )
- )
- )
- (show-env-exp () env)
- ;^;;;;;;;;;;;;;;; end new cases for chap 5 ;;;;;;;;;;;;;;;;
- )))
- (define eval-rands
- (lambda (exps env)
- (map
- (lambda (exp) (eval-expression exp env))
- exps)))
- (define apply-primitive
- (lambda (prim args)
- (cases primitive prim
- (add-prim () (+ (car args) (cadr args)))
- (subtract-prim () (- (car args) (cadr args)))
- (mult-prim () (* (car args) (cadr args)))
- (incr-prim () (+ (car args) 1))
- (decr-prim () (- (car args) 1))
- (zero-test-prim () (if (zero? (car args)) 1 0))
- (list-prim () args) ;already a list
- (nil-prim () '())
- (car-prim () (car (car args)))
- (cdr-prim () (cdr (car args)))
- (cons-prim () (cons (car args) (cadr args)))
- (null?-prim () (if (null? (car args)) 1 0))
- )))
- (define init-env
- (lambda ()
- (empty-env)))
- ;^;;;;;;;;;;;;;;; booleans ;;;;;;;;;;;;;;;;
- (define true-value?
- (lambda (x)
- (not (zero? x))))
- ;;;;;;;;;;;;;;;; declarations ;;;;;;;;;;;;;;;;
- (define class-decl->class-name
- (lambda (c-decl)
- (cases class-decl c-decl
- (a-class-decl (class-name super-name field-ids m-decls)
- class-name))))
- (define class-decl->super-name
- (lambda (c-decl)
- (cases class-decl c-decl
- (a-class-decl (class-name super-name field-ids m-decls)
- super-name))))
- (define class-decl->field-ids
- (lambda (c-decl)
- (cases class-decl c-decl
- (a-class-decl (class-name super-name field-ids m-decls)
- field-ids))))
- (define class-decl->method-decls
- (lambda (c-decl)
- (cases class-decl c-decl
- (a-class-decl (class-name super-name field-ids m-decls)
- m-decls))))
- (define method-decl->method-name
- (lambda (md)
- (cases method-decl md
- (a-method-decl (method-name ids body) method-name))))
- (define method-decl->ids
- (lambda (md)
- (cases method-decl md
- (a-method-decl (method-name ids body) ids))))
- (define method-decl->body
- (lambda (md)
- (cases method-decl md
- (a-method-decl (method-name ids body) body))))
- (define method-decls->method-names
- (lambda (mds)
- (map method-decl->method-name mds)))
- ;^;;;;;;;;;;;;;;; procedures ;;;;;;;;;;;;;;;;
- (define-datatype procval procval?
- (closure
- (ids (list-of symbol?))
- (body expression?)
- (env environment?)))
- (define apply-procval
- (lambda (proc args)
- (cases procval proc
- (closure (ids body env)
- (eval-expression body (extend-env ids args env))))))
- ;^;;;;;;;;;;;;;;; references ;;;;;;;;;;;;;;;;
- (define-datatype reference reference?
- (a-ref
- (position integer?)
- (vec vector?)))
- (define deref
- (lambda (ref)
- (cases reference ref
- (a-ref (pos vec)
- (vector-ref vec pos)))))
- (define setref!
- (lambda (ref val)
- (cases reference ref
- (a-ref (pos vec)
- (vector-set! vec pos val)))
- 1))
- ;^;;;;;;;;;;;;;;; environments ;;;;;;;;;;;;;;;;
- (define-datatype environment environment?
- (empty-env-record)
- (extended-env-record
- (syms (list-of symbol?))
- (vec vector?) ; can use this for anything.
- (env environment?))
- )
- (define empty-env
- (lambda ()
- (empty-env-record)))
- (define extend-env
- (lambda (syms vals env)
- (extended-env-record syms (list->vector vals) env)))
- (define apply-env-ref
- (lambda (env sym)
- (cases environment env
- (empty-env-record ()
- (eopl:error 'apply-env-ref "No binding for ~s" sym))
- (extended-env-record (syms vals env)
- (let ((pos (rib-find-position sym syms)))
- (if (number? pos)
- (a-ref pos vals)
- (apply-env-ref env sym)))))))
- (define apply-env
- (lambda (env sym)
- (deref (apply-env-ref env sym))))
- (define extend-env-recursively
- (lambda (proc-names idss bodies old-env)
- (let ((len (length proc-names)))
- (let ((vec (make-vector len)))
- (let ((env (extended-env-record proc-names vec old-env)))
- (for-each
- (lambda (pos ids body)
- (vector-set! vec pos (closure ids body env)))
- (iota len) idss bodies)
- env)))))
- (define rib-find-position
- (lambda (sym los)
- (list-find-position sym los)))
- (define list-find-position
- (lambda (sym los)
- (list-index (lambda (sym1) (eqv? sym1 sym)) los)))
- (define list-index
- (lambda (pred ls)
- (cond
- ((null? ls) #f)
- ((pred (car ls)) 0)
- (else (let ((list-index-r (list-index pred (cdr ls))))
- (if (number? list-index-r)
- (+ list-index-r 1)
- #f))))))
- (define iota
- (lambda (end)
- (let loop ((next 0))
- (if (>= next end) '()
- (cons next (loop (+ 1 next)))))))
- (define difference
- (lambda (set1 set2)
- (cond
- ((null? set1) '())
- ((memv (car set1) set2)
- (difference (cdr set1) set2))
- (else (cons (car set1) (difference (cdr set1) set2))))))
- ;^; new for ch 5
- (define extend-env-refs
- (lambda (syms vec env)
- (extended-env-record syms vec env)))
- ;^; waiting for 5-4-2. Brute force code.
- (define list-find-last-position
- (lambda (sym los)
- (let loop
- ((los los) (curpos 0) (lastpos #f))
- (cond
- ((null? los) lastpos)
- ((eqv? sym (car los))
- (loop (cdr los) (+ curpos 1) curpos))
- (else (loop (cdr los) (+ curpos 1) lastpos))))))
- ;; evaluar
- (define aux
- (lambda (x)
- x))
- (define-datatype part part?
- (a-part
- (class-name symbol?)
- (fields vector?)))
- (define new-object
- (lambda (class-name)
- (if (eqv? class-name 'object)
- '()
- (let ((c-decl (lookup-class class-name)))
- (cons
- (make-first-part c-decl)
- (new-object (class-decl->super-name c-decl)))))))
- (define make-first-part
- (lambda (c-decl)
- (a-part
- (class-decl->class-name c-decl)
- (make-vector (length (class-decl->field-ids c-decl))))))
- ;;;;;;;;;;;;;;;; methods ;;;;;;;;;;;;;;;;
- ;;; methods are represented by their declarations. They are closed
- ;;; over their fields at application time, by apply-method.
- (define find-method-and-apply
- (lambda (m-name host-name self args)
- (if (eqv? host-name 'object)
- (eopl:error 'find-method-and-apply
- "No method for name ~s" m-name)
- (let ((m-decl (lookup-method-decl m-name
- (class-name->method-decls host-name))))
- (if (method-decl? m-decl)
- (apply-method m-decl host-name self args)
- (find-method-and-apply m-name
- (class-name->super-name host-name)
- self args))))))
- (define view-object-as
- (lambda (parts class-name)
- (if (eqv? (part->class-name (car parts)) class-name)
- parts
- (view-object-as (cdr parts) class-name))))
- (define apply-method
- (lambda (m-decl host-name self args)
- (let ((ids (method-decl->ids m-decl))
- (body (method-decl->body m-decl))
- (super-name (class-name->super-name host-name)))
- (eval-expression body
- (extend-env
- (cons '%super (cons 'self ids))
- (cons super-name (cons self args))
- (build-field-env
- (view-object-as self host-name)))))))
- (define build-field-env
- (lambda (parts)
- (if (null? parts)
- (empty-env)
- (extend-env-refs
- (part->field-ids (car parts))
- (part->fields (car parts))
- (build-field-env (cdr parts))))))
- ;;;;;;;;;;;;;;;; method environments ;;;;;;;;;;;;;;;;
- ;; find a method in a list of method-decls, else return #f
- (define lookup-method-decl
- (lambda (m-name m-decls)
- (cond
- ((null? m-decls) #f)
- ((eqv? m-name (method-decl->method-name (car m-decls)))
- (car m-decls))
- (else (lookup-method-decl m-name (cdr m-decls))))))
- ;;;;;;;;;;;;;;;; class environments ;;;;;;;;;;;;;;;;
- ;;; we'll just use the list of class-decls.
- (define the-class-env '())
- (define elaborate-class-decls!
- (lambda (c-decls)
- (set! the-class-env c-decls)))
- (define lookup-class
- (lambda (name)
- (let loop ((env the-class-env))
- (cond
- ((null? env)
- (eopl:error 'lookup-class
- "Unknown class ~s" name))
- ((eqv? (class-decl->class-name (car env)) name) (car env))
- (else (loop (cdr env)))))))
- ;;;;;;;;;;;;;;;; selectors of all sorts ;;;;;;;;;;;;;;;;
- (define part->class-name
- (lambda (prt)
- (cases part prt
- (a-part (class-name fields)
- class-name))))
- (define part->fields
- (lambda (prt)
- (cases part prt
- (a-part (class-name fields)
- fields))))
- (define part->field-ids
- (lambda (part)
- (class-decl->field-ids (part->class-decl part))))
- (define part->class-decl
- (lambda (part)
- (lookup-class (part->class-name part))))
- (define part->method-decls
- (lambda (part)
- (class-decl->method-decls (part->class-decl part))))
- (define part->super-name
- (lambda (part)
- (class-decl->super-name (part->class-decl part))))
- (define class-name->method-decls
- (lambda (class-name)
- (class-decl->method-decls (lookup-class class-name))))
- (define class-name->super-name
- (lambda (class-name)
- (class-decl->super-name (lookup-class class-name))))
- (define object->class-name
- (lambda (parts)
- (part->class-name (car parts))))
- ;;
- (define read-eval-print
- (sllgen:make-rep-loop "-->" eval-program
- (sllgen:make-stream-parser
- the-lexical-spec
- the-grammar)))
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement